summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2010-02-19 15:30:34 +0100
committerAndy Wingo <wingo@pobox.com>2010-02-19 15:30:34 +0100
commitea6b18e82f3ac2122d07c80bc0f320ea839a25b6 (patch)
treecd5e3c02694e73a2453b1cc9d06f160580c5c92f
parentf5b1f76af492f3c398527ee040e8bf09fc438a9a (diff)
downloadguile-ea6b18e82f3ac2122d07c80bc0f320ea839a25b6.tar.gz
prompt handlers are always inline
* libguile/control.h (SCM_F_PROMPT_INLINE, SCM_PROMPT_INLINE_P): Remove; prompts always have "inline" handlers now. * libguile/control.c (scm_c_make_prompt): Remove inline_handler_p arg. * libguile/vm-i-system.c (prompt): * module/language/assembly/decompile-bytecode.scm (decode-load-program): * module/language/assembly/compile-bytecode.scm (write-bytecode): Adapt to prompt changes. * module/language/glil.scm (make-glil-prompt, glil-prompt-inline?): Remove inline? flag. (parse-glil, unparse-glil): * module/language/glil/compile-assembly.scm (glil->assembly): Adapt to <glil-prompt> change. * module/language/tree-il/compile-glil.scm (flatten): Require the handler of a <prompt> to be a lambda-case. * module/language/tree-il/primitives.scm (*primitive-expand-table*): Ensure that the handler of a <prompt> is a lambda-case. * module/language/tree-il/inline.scm (inline!): Simplify a degenerate case: (lambda args (apply (lambda ...) args)) => (lambda ...).
-rw-r--r--libguile/control.c5
-rw-r--r--libguile/control.h7
-rw-r--r--libguile/vm-i-system.c12
-rw-r--r--module/language/assembly/compile-bytecode.scm3
-rw-r--r--module/language/assembly/decompile-bytecode.scm4
-rw-r--r--module/language/glil.scm13
-rw-r--r--module/language/glil/compile-assembly.scm6
-rw-r--r--module/language/tree-il/compile-glil.scm71
-rw-r--r--module/language/tree-il/inline.scm34
-rw-r--r--module/language/tree-il/primitives.scm22
10 files changed, 78 insertions, 99 deletions
diff --git a/libguile/control.c b/libguile/control.c
index 0686924d5..b9ecff1e1 100644
--- a/libguile/control.c
+++ b/libguile/control.c
@@ -49,16 +49,13 @@ SCM_DEFINE (scm_atprompt, "@prompt", 4, 0, 0,
#undef FUNC_NAME
SCM
-scm_c_make_prompt (SCM vm, SCM k, SCM handler, scm_t_uint8 inline_handler_p,
- scm_t_uint8 escape_only_p)
+scm_c_make_prompt (SCM vm, SCM k, SCM handler, scm_t_uint8 escape_only_p)
{
scm_t_bits tag;
SCM ret;
struct scm_prompt_registers *regs;
tag = scm_tc7_prompt;
- if (inline_handler_p)
- tag |= SCM_F_PROMPT_INLINE;
if (escape_only_p)
tag |= SCM_F_PROMPT_ESCAPE;
ret = scm_words (tag, 5);
diff --git a/libguile/control.h b/libguile/control.h
index 9fe880b11..e95ef99ff 100644
--- a/libguile/control.h
+++ b/libguile/control.h
@@ -20,14 +20,12 @@
#define SCM_CONTROL_H
-#define SCM_F_PROMPT_INLINE 0x1
-#define SCM_F_PROMPT_ESCAPE 0x2
+#define SCM_F_PROMPT_ESCAPE 0x1
#define SCM_PROMPT_P(x) (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_prompt)
#define SCM_PROMPT_FLAGS(x) (SCM_CELL_WORD ((x), 0) >> 8)
-#define SCM_PROMPT_INLINE_P(x) (SCM_PROMPT_FLAGS (x) & SCM_F_PROMPT_INLINE)
#define SCM_PROMPT_ESCAPE_P(x) (SCM_PROMPT_FLAGS (x) & SCM_F_PROMPT_ESCAPE)
-#define SCM_PROMPT_TAG(x) (SCM_CELL_OBJECT ((x), 1)
+#define SCM_PROMPT_TAG(x) (SCM_CELL_OBJECT ((x), 1))
#define SCM_PROMPT_REGISTERS(x) ((struct scm_prompt_registers*)SCM_CELL_WORD ((x), 2))
#define SCM_PROMPT_DYNENV(x) (SCM_CELL_OBJECT ((x), 3))
#define SCM_PROMPT_HANDLER(x) (SCM_CELL_OBJECT ((x), 4))
@@ -44,7 +42,6 @@ struct scm_prompt_registers
SCM_INTERNAL SCM scm_c_make_prompt (SCM vm, SCM k, SCM handler,
- scm_t_uint8 inline_handler_p,
scm_t_uint8 escape_only_p);
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index a262d443f..98ef189e4 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -1450,13 +1450,12 @@ VM_DEFINE_INSTRUCTION (82, make_symbol, "make-symbol", 0, 1, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (83, prompt, "prompt", 5, 2, 0)
+VM_DEFINE_INSTRUCTION (83, prompt, "prompt", 4, 2, 0)
{
scm_t_int32 offset;
- scm_t_uint8 inline_handler_p, escape_only_p;
+ scm_t_uint8 escape_only_p;
SCM k, handler, prompt;
- inline_handler_p = FETCH ();
escape_only_p = FETCH ();
FETCH_OFFSET (offset);
POP (handler);
@@ -1466,14 +1465,13 @@ VM_DEFINE_INSTRUCTION (83, prompt, "prompt", 5, 2, 0)
/* Push the prompt onto the dynamic stack. The setjmp itself has to be local
to this procedure. */
/* FIXME: do more error checking */
- prompt = scm_c_make_prompt (vm, k, handler, inline_handler_p, escape_only_p);
+ prompt = scm_c_make_prompt (vm, k, handler, escape_only_p);
scm_i_set_dynwinds (scm_cons (prompt, scm_i_dynwinds ()));
if (SCM_PROMPT_SETJMP (prompt))
{
/* The prompt exited nonlocally. Cache the regs back from the vp, and go
- to the handler or post-handler label. (The meaning of the label differs
- depending on whether the prompt's handler is rendered inline or not.)
- */
+ to the handler.
+ */
CACHE_REGISTER (); /* Really we only need SP. FP and IP should be
unmodified. */
ip += offset;
diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm
index 98fb27fed..5c0e11533 100644
--- a/module/language/assembly/compile-bytecode.scm
+++ b/module/language/assembly/compile-bytecode.scm
@@ -119,8 +119,7 @@
((br-if-nargs-lt ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l))
((br-if-nargs-gt ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l))
((mv-call ,n ,l) (write-byte n) (write-break l))
- ((prompt ,inline-handler? ,escape-only? ,l)
- (write-byte inline-handler?) (write-byte escape-only?) (write-break l))
+ ((prompt ,escape-only? ,l) (write-byte escape-only?) (write-break l))
(else
(cond
((< (instruction-length inst) 0)
diff --git a/module/language/assembly/decompile-bytecode.scm b/module/language/assembly/decompile-bytecode.scm
index a021b5738..3ae96d2eb 100644
--- a/module/language/assembly/decompile-bytecode.scm
+++ b/module/language/assembly/decompile-bytecode.scm
@@ -90,8 +90,8 @@
(lp (cons `(,br ,hi ,lo ,(ensure-label rel1 rel2 rel3)) out)))
((mv-call ,n ,rel1 ,rel2 ,rel3)
(lp (cons `(mv-call ,n ,(ensure-label rel1 rel2 rel3)) out)))
- ((prompt ,n0 ,n1 ,rel1 ,rel2 ,rel3)
- (lp (cons `(prompt ,n0 ,n1 ,(ensure-label rel1 rel2 rel3)) out)))
+ ((prompt ,n0 ,rel1 ,rel2 ,rel3)
+ (lp (cons `(prompt ,n0 ,(ensure-label rel1 rel2 rel3)) out)))
(else
(lp (cons exp out))))))))))
diff --git a/module/language/glil.scm b/module/language/glil.scm
index 1874c80ab..9c238547d 100644
--- a/module/language/glil.scm
+++ b/module/language/glil.scm
@@ -75,8 +75,7 @@
<glil-mv-call> make-glil-mv-call glil-mv-call?
glil-mv-call-nargs glil-mv-call-ra
- <glil-prompt> make-glil-prompt glil-prompt?
- glil-prompt-label glil-prompt-inline? glil-prompt-escape-only?
+ <glil-prompt> make-glil-prompt glil-prompt? glil-prompt-label glil-prompt-escape-only?
parse-glil unparse-glil))
@@ -105,7 +104,7 @@
(<glil-branch> inst label)
(<glil-call> inst nargs)
(<glil-mv-call> nargs ra)
- (<glil-prompt> label inline? escape-only?))
+ (<glil-prompt> label escape-only?))
@@ -133,8 +132,8 @@
((branch ,inst ,label) (make-glil-branch inst label))
((call ,inst ,nargs) (make-glil-call inst nargs))
((mv-call ,nargs ,ra) (make-glil-mv-call nargs ra))
- ((prompt ,label ,inline? ,escape-only?)
- (make-glil-prompt label inline? escape-only?))
+ ((prompt ,label ,escape-only?)
+ (make-glil-prompt label escape-only?))
(else (error "invalid glil" x))))
(define (unparse-glil glil)
@@ -167,5 +166,5 @@
((<glil-branch> inst label) `(branch ,inst ,label))
((<glil-call> inst nargs) `(call ,inst ,nargs))
((<glil-mv-call> nargs ra) `(mv-call ,nargs ,ra))
- ((<glil-prompt> label inline? escape-only?)
- `(prompt ,label ,inline? escape-only?))))
+ ((<glil-prompt> label escape-only?)
+ `(prompt ,label escape-only?))))
diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm
index 95804eca2..47002a8fc 100644
--- a/module/language/glil/compile-assembly.scm
+++ b/module/language/glil/compile-assembly.scm
@@ -514,10 +514,8 @@
((<glil-mv-call> nargs ra)
(emit-code `((mv-call ,nargs ,ra))))
- ((<glil-prompt> label inline? escape-only?)
- (emit-code `((prompt ,(if inline? 1 0)
- ,(if escape-only? 1 0)
- ,label))))))
+ ((<glil-prompt> label escape-only?)
+ (emit-code `((prompt ,(if escape-only? 1 0) ,label))))))
(define (dump-object x addr)
(define (too-long x)
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index 64514d855..064668864 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -1041,14 +1041,10 @@
((<prompt> src tag body handler)
(let ((H (make-label))
(POST (make-label))
- (inline? (lambda-case? handler))
(escape-only? (hashq-ref allocation x)))
;; First, set up the prompt.
(comp-push tag)
- (if inline?
- (emit-code #f (make-glil-const #f)) ;; push #f as handler
- (comp-push handler))
- (emit-code src (make-glil-prompt H inline? escape-only?))
+ (emit-code src (make-glil-prompt H escape-only?))
;; Then we compile the body, with its normal return path, unwinding
;; before proceeding.
@@ -1087,51 +1083,30 @@
(emit-code #f (make-glil-call 'unwind 0))
(emit-branch #f 'br (or RA POST))))
- ;; Now the handler.
(emit-label H)
- (cond
- (inline?
- ;; The inlined handler. The stack is now made up of the continuation,
- ;; and then the args to the continuation (pushed separately), and
- ;; then the number of args, including the continuation.
- (record-case handler
- ((<lambda-case> req opt kw rest vars body alternate)
- (if (or opt kw alternate)
- (error "unexpected lambda-case in prompt" x))
- (emit-code src (make-glil-mv-bind
- (vars->bind-list
- (append req (if rest (list rest) '()))
- vars allocation self)
- (and rest #t)))
- (for-each (lambda (v)
- (pmatch (hashq-ref (hashq-ref allocation v) self)
- ((#t #f . ,n)
- (emit-code src (make-glil-lexical #t #f 'set n)))
- ((#t #t . ,n)
- (emit-code src (make-glil-lexical #t #t 'box n)))
- (,loc (error "badness" x loc))))
- (reverse vars))
- (comp-tail body)
- (emit-code #f (make-glil-unbind)))))
- (else
- ;; The handler was on the heap, so here we're just processing its
- ;; return values.
- (case context
- ((tail)
- (emit-code #f (make-glil-call 'return/nvalues 1)))
- ((push)
- ;; truncate to one value, leave on stack
- (emit-code #f (make-glil-mv-bind '(handler-ret) #f))
- (emit-code #f (make-glil-unbind)))
- ((vals)
- (emit-branch #f 'br MVRA))
- ((drop)
- ;; truncate to 0 vals
- (emit-code #f (make-glil-mv-bind '() #f))
- (emit-code #f (make-glil-unbind))
- (if RA (emit-branch #f 'br RA))))))
+ ;; Now the handler. The stack is now made up of the continuation, and
+ ;; then the args to the continuation (pushed separately), and then the
+ ;; number of args, including the continuation.
+ (record-case handler
+ ((<lambda-case> req opt kw rest vars body alternate)
+ (if (or opt kw alternate)
+ (error "unexpected lambda-case in prompt" x))
+ (emit-code src (make-glil-mv-bind
+ (vars->bind-list
+ (append req (if rest (list rest) '()))
+ vars allocation self)
+ (and rest #t)))
+ (for-each (lambda (v)
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
+ ((#t #f . ,n)
+ (emit-code src (make-glil-lexical #t #f 'set n)))
+ ((#t #t . ,n)
+ (emit-code src (make-glil-lexical #t #t 'box n)))
+ (,loc (error "badness" x loc))))
+ (reverse vars))
+ (comp-tail body)
+ (emit-code #f (make-glil-unbind))))
- ;; The POST label, if necessary.
(if (or (eq? context 'push)
(and (eq? context 'drop) (not RA)))
(emit-label POST))))
diff --git a/module/language/tree-il/inline.scm b/module/language/tree-il/inline.scm
index 0653db188..905622d65 100644
--- a/module/language/tree-il/inline.scm
+++ b/module/language/tree-il/inline.scm
@@ -110,15 +110,29 @@
((<fix> vars body)
(if (null? vars) body x))
- ((<prompt> src tag body handler)
- ;; If the handler is a simple lambda, inline it.
- (if (and (lambda? handler)
- (record-case (lambda-body handler)
- ((<lambda-case> req opt kw rest alternate)
- (and (pair? req) (not opt) (not kw) (not alternate)))
- (else #f)))
- (make-prompt src tag body (lambda-body handler))
- x))
-
+ ((<lambda-case> req opt rest kw vars body alternate)
+ (let ()
+ (define (args-compatible? args vars)
+ (let lp ((args args) (vars vars))
+ (cond
+ ((null? args) (null? vars))
+ ((null? vars) #f)
+ ((and (lexical-ref? (car args))
+ (eq? (lexical-ref-gensym (car args)) (car vars)))
+ (lp (cdr args) (cdr vars)))
+ (else #f))))
+
+ (and (not opt) (not kw) (not alternate)
+ (record-case body
+ ((<application> proc args)
+ ;; (lambda args (apply (lambda ...) args)) => (lambda ...)
+ (and (primitive-ref? proc)
+ (eq? (primitive-ref-name proc) '@apply)
+ (pair? args)
+ (lambda? (car args))
+ (args-compatible? (cdr args) vars)
+ (lambda-body (car args))))
+ (else #f)))))
+
(else #f)))
(post-order! inline1 x))
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index 4f8364224..58b75fc10 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -435,18 +435,20 @@
(else #f)))
(hashq-set! *primitive-expand-table*
- 'prompt
- (case-lambda
- ((src tag thunk handler)
- (make-prompt src tag (make-application #f thunk '())
- handler #f))
- (else #f)))
-(hashq-set! *primitive-expand-table*
'@prompt
(case-lambda
- ((src tag thunk handler)
- (make-prompt src tag (make-application #f thunk '())
- handler))
+ ((src tag exp handler)
+ (let ((args-sym (gensym)))
+ (make-prompt
+ src tag exp
+ ;; If handler itself is a lambda, the inliner can do some
+ ;; trickery here.
+ (make-lambda-case
+ (tree-il-src handler) '() #f 'args #f '() (list args-sym)
+ (make-application #f (make-primitive-ref #f 'apply)
+ (list handler
+ (make-lexical-ref #f 'args args-sym)))
+ #f))))
(else #f)))
(hashq-set! *primitive-expand-table*