diff options
Diffstat (limited to 'module')
-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 |
7 files changed, 70 insertions, 83 deletions
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* |