diff options
-rw-r--r-- | libguile/control.c | 5 | ||||
-rw-r--r-- | libguile/control.h | 7 | ||||
-rw-r--r-- | libguile/vm-i-system.c | 12 | ||||
-rw-r--r-- | module/language/assembly/compile-bytecode.scm | 3 | ||||
-rw-r--r-- | module/language/assembly/decompile-bytecode.scm | 4 | ||||
-rw-r--r-- | module/language/glil.scm | 13 | ||||
-rw-r--r-- | module/language/glil/compile-assembly.scm | 6 | ||||
-rw-r--r-- | module/language/tree-il/compile-glil.scm | 71 | ||||
-rw-r--r-- | module/language/tree-il/inline.scm | 34 | ||||
-rw-r--r-- | module/language/tree-il/primitives.scm | 22 |
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* |