diff options
author | Andy Wingo <wingo@pobox.com> | 2013-07-29 21:55:39 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2013-08-11 16:45:31 +0200 |
commit | 99983d544a931c29065ecb749acd349efc5f36c5 (patch) | |
tree | a2c5855685ba71d16fc65dad3a5e5ebbc6de6737 | |
parent | c1bff879980c3a2f107e8d7b54d0a6d8a18eefe4 (diff) | |
download | guile-99983d544a931c29065ecb749acd349efc5f36c5.tar.gz |
Inline escape-only prompt bodies in the Tree-IL
* module/language/scheme/decompile-tree-il.scm (do-decompile):
* module/language/tree-il/analyze.scm (analyze-lexicals):
* module/language/tree-il/canonicalize.scm (canonicalize):
* module/language/tree-il/compile-glil.scm (flatten-lambda-case):
* module/language/tree-il/cse.scm (cse):
* module/language/tree-il/peval.scm (peval):
* test-suite/tests/peval.test ("partial evaluation"): Partially revert
178a40928, so that escape-only prompts explicitly inline their bodies.
-rw-r--r-- | module/language/scheme/decompile-tree-il.scm | 6 | ||||
-rw-r--r-- | module/language/tree-il/analyze.scm | 22 | ||||
-rw-r--r-- | module/language/tree-il/canonicalize.scm | 66 | ||||
-rw-r--r-- | module/language/tree-il/compile-glil.scm | 7 | ||||
-rw-r--r-- | module/language/tree-il/cse.scm | 5 | ||||
-rw-r--r-- | module/language/tree-il/peval.scm | 13 | ||||
-rw-r--r-- | test-suite/tests/peval.test | 5 |
7 files changed, 45 insertions, 79 deletions
diff --git a/module/language/scheme/decompile-tree-il.scm b/module/language/scheme/decompile-tree-il.scm index 74778b4ca..2decd9749 100644 --- a/module/language/scheme/decompile-tree-il.scm +++ b/module/language/scheme/decompile-tree-il.scm @@ -432,10 +432,12 @@ `(call-with-values (lambda () ,@(recurse-body exp)) ,(recurse (make-lambda #f '() body)))) - ((<prompt> tag body handler) + ((<prompt> escape-only? tag body handler) `(call-with-prompt ,(recurse tag) - ,(recurse body) + ,(if escape-only? + `(lambda () ,(recurse body)) + (recurse body)) ,(recurse handler))) diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index 6b6df18c3..2f6e36960 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -338,15 +338,8 @@ (lset-union eq? (step exp) (step body))) ((<prompt> escape-only? tag body handler) - (match x - ;; Escape-only: the body is inlined. - (($ <prompt> _ #t tag - ($ <lambda> _ _ - ($ <lambda-case> _ () #f #f #f () () body #f)) - ($ <lambda> _ _ handler)) - (lset-union eq? (step tag) (step body) (step-tail handler))) - ;; Full: we make a closure. - (($ <prompt> _ #f tag body ($ <lambda> _ _ handler)) + (match handler + (($ <lambda> _ _ handler) (lset-union eq? (step tag) (step body) (step-tail handler))))) ((<abort> tag args tail) @@ -509,15 +502,8 @@ (max (recur exp) (recur body))) ((<prompt> escape-only? tag body handler) - (match x - ;; Escape-only: the body is inlined. - (($ <prompt> _ #t tag - ($ <lambda> _ _ - ($ <lambda-case> _ () #f #f #f () () body #f)) - ($ <lambda> _ _ handler)) - (max (recur tag) (recur body) (recur handler))) - ;; Full: we make a closure. - (($ <prompt> _ #f tag body ($ <lambda> _ _ handler)) + (match handler + (($ <lambda> _ _ handler) (max (recur tag) (recur body) (recur handler))))) ((<abort> tag args tail) diff --git a/module/language/tree-il/canonicalize.scm b/module/language/tree-il/canonicalize.scm index 47c1db7ac..9de4caae4 100644 --- a/module/language/tree-il/canonicalize.scm +++ b/module/language/tree-il/canonicalize.scm @@ -55,48 +55,28 @@ (make-const #f '()) (make-const #f #f))) #f))) - (($ <prompt> src) - (define (ensure-lambda-body prompt) - ;; If the prompt is escape-only, the body should be a thunk. - (match prompt - (($ <prompt> _ escape-only? tag body handler) - (match body - ((or ($ <lambda> _ _ ($ <lambda-case> _ () #f #f #f)) - (? (lambda _ (not escape-only?)))) - prompt) - (else - (make-prompt - src escape-only? tag - (make-lambda #f '() - (make-lambda-case #f '() #f #f #f '() '() - (make-call #f body '()) - #f)) - handler)))))) - (define (ensure-lambda-handler prompt) - (match prompt - (($ <prompt> _ escape-only? tag body handler) - ;; The prompt handler should be a simple lambda, so that we - ;; can inline it. - (match handler - (($ <lambda> _ _ - ($ <lambda-case> _ req #f rest #f () syms body #f)) - prompt) - (else - (let ((handler-sym (gensym)) - (args-sym (gensym))) - (make-let - #f (list 'handler) (list handler-sym) (list handler) - (make-prompt - src escape-only? tag body - (make-lambda - #f '() - (make-lambda-case - #f '() #f 'args #f '() (list args-sym) - (make-primcall - #f 'apply - (list (make-lexical-ref #f 'handler handler-sym) - (make-lexical-ref #f 'args args-sym))) - #f)))))))))) - (ensure-lambda-handler (ensure-lambda-body x))) + (($ <prompt> src escape-only? tag body handler) + ;; The prompt handler should be a simple lambda, so that we + ;; can inline it. + (match handler + (($ <lambda> _ _ + ($ <lambda-case> _ req #f rest #f () syms body #f)) + x) + (else + (let ((handler-sym (gensym)) + (args-sym (gensym))) + (make-let + #f (list 'handler) (list handler-sym) (list handler) + (make-prompt + src escape-only? tag body + (make-lambda + #f '() + (make-lambda-case + #f '() #f 'args #f '() (list args-sym) + (make-primcall + #f 'apply + (list (make-lexical-ref #f 'handler handler-sym) + (make-lexical-ref #f 'args args-sym))) + #f)))))))) (_ x))) x)) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index fd67471f2..34855b9bd 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -958,12 +958,7 @@ ((<prompt> src escape-only? tag body handler) (let ((H (make-label)) (POST (make-label)) - (body (if escape-only? - (match body - (($ <lambda> _ _ - ($ <lambda-case> _ () #f #f #f () () body #f)) - body)) - (make-call #f body '())))) + (body (if escape-only? body (make-call #f body '())))) ;; First, set up the prompt. (comp-push tag) diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm index 9e5157c73..5d0277f39 100644 --- a/module/language/tree-il/cse.scm +++ b/module/language/tree-il/cse.scm @@ -533,8 +533,9 @@ (concat db** db*))))))) (($ <prompt> src escape-only? tag body handler) (let*-values (((tag db*) (visit tag db env 'value)) - ((body _) (visit body (concat db* db) env ctx)) - ((handler _) (visit handler (concat db* db) env ctx))) + ((body _) (visit body (concat db* db) env + (if escape-only? ctx 'value))) + ((handler _) (visit handler (concat db* db) env 'value))) (return (make-prompt src escape-only? tag body handler) db*))) (($ <abort> src tag args tail) diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index 57832a698..3d350392e 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -1522,7 +1522,7 @@ top-level bindings from ENV and return the resulting expression." (_ #f))) (let ((tag (for-value tag)) - (body (for-value body))) + (body (if escape-only? (for-tail body) (for-value body)))) (cond ((find-definition tag 1) (lambda (val op) @@ -1532,7 +1532,7 @@ top-level bindings from ENV and return the resulting expression." ;; for this <prompt>, so we can elide the <prompt> ;; entirely. (unrecord-operand-uses op 1) - (for-tail (make-call src body '())))) + (for-tail (if escape-only? body (make-call src body '()))))) (else (let ((handler (for-value handler))) (define (escape-only-handler? handler) @@ -1545,8 +1545,13 @@ top-level bindings from ENV and return the resulting expression." (_ #f)) body))) (else #f))) - (make-prompt src (or escape-only? (escape-only-handler? handler)) - tag body (for-value handler))))))) + (if (and (not escape-only?) (escape-only-handler? handler)) + ;; Prompt transitioning to escape-only; transition body + ;; to be an expression. + (for-tail + (make-prompt src #t tag (make-call #f body '()) handler)) + (make-prompt src escape-only? tag body handler))))))) + (($ <abort> src tag args tail) (make-abort src (for-value tag) (map for-value args) (for-value tail)))))) diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test index 6d83fb79c..0b981d805 100644 --- a/test-suite/tests/peval.test +++ b/test-suite/tests/peval.test @@ -1137,10 +1137,7 @@ (lambda (k x) x)) (prompt #t (toplevel tag) - (lambda _ - (lambda-case - ((() #f #f #f () ()) - (const 1)))) + (const 1) (lambda _ (lambda-case (((k x) #f #f #f () (_ _)) |