diff options
author | Andy Wingo <wingo@pobox.com> | 2011-09-27 13:42:43 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2011-09-28 00:13:56 +0200 |
commit | 6c4ffe2b2560eaeb0fe5aedb266183e3bb80dbd8 (patch) | |
tree | e89450e2ae6998e0e0e062627767d0d6a26b944d | |
parent | ea726a53b2180ee4548723f81d9b1be7732ef5d8 (diff) | |
download | guile-6c4ffe2b2560eaeb0fe5aedb266183e3bb80dbd8.tar.gz |
peval: elide make-prompt-tag in effect context
* module/language/tree-il/optimize.scm (peval): Fix a duplicate
traversal for constructors in effect or test context. Add support for
eliding make-prompt-tag.
* test-suite/tests/tree-il.test ("partial evaluation"): Update the test
for make-prompt-tag elision.
-rw-r--r-- | module/language/tree-il/optimize.scm | 10 | ||||
-rw-r--r-- | test-suite/tests/tree-il.test | 14 |
2 files changed, 17 insertions, 7 deletions
diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm index 6c55d64eb..c40330ce7 100644 --- a/module/language/tree-il/optimize.scm +++ b/module/language/tree-il/optimize.scm @@ -769,8 +769,7 @@ it does not handle <fix> and <let-values>, it should be called before (($ <primitive-ref> _ (? constructor-primitive? name)) (case ctx ((effect test) - (let ((exp (for-value exp)) - (res (if (eq? ctx 'effect) + (let ((res (if (eq? ctx 'effect) (make-void #f) (make-const #f #t)))) (match (for-value exp) @@ -783,7 +782,12 @@ it does not handle <fix> and <let-values>, it should be called before (($ <application> _ ($ <primitive-ref> _ 'vector) elts) (for-tail (make-sequence src (append elts (list res))))) - (_ exp)))) + (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag) ()) + res) + (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag) + (($ <const> _ (? string?)))) + res) + (exp exp)))) (else (match (cons name (map for-value orig-args)) (('cons head tail) diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index 9bb45eede..cd3314307 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -1282,10 +1282,16 @@ (call-with-prompt tag (lambda () 1) (lambda args args))) - ;; FIXME: elide the (make-prompt-tag) call - (begin - (apply (primitive make-prompt-tag)) - (const 1))) + (const 1)) + + (pass-if-peval + resolve-primitives + ;; Prompt is removed if tag is unreferenced, with explicit stem + (let ((tag (make-prompt-tag "foo"))) + (call-with-prompt tag + (lambda () 1) + (lambda args args))) + (const 1)) ) |