summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2013-07-29 21:55:39 +0200
committerAndy Wingo <wingo@pobox.com>2013-08-11 16:45:31 +0200
commit99983d544a931c29065ecb749acd349efc5f36c5 (patch)
treea2c5855685ba71d16fc65dad3a5e5ebbc6de6737
parentc1bff879980c3a2f107e8d7b54d0a6d8a18eefe4 (diff)
downloadguile-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.scm6
-rw-r--r--module/language/tree-il/analyze.scm22
-rw-r--r--module/language/tree-il/canonicalize.scm66
-rw-r--r--module/language/tree-il/compile-glil.scm7
-rw-r--r--module/language/tree-il/cse.scm5
-rw-r--r--module/language/tree-il/peval.scm13
-rw-r--r--test-suite/tests/peval.test5
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 () (_ _))