summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2011-09-27 13:42:43 +0200
committerAndy Wingo <wingo@pobox.com>2011-09-28 00:13:56 +0200
commit6c4ffe2b2560eaeb0fe5aedb266183e3bb80dbd8 (patch)
treee89450e2ae6998e0e0e062627767d0d6a26b944d
parentea726a53b2180ee4548723f81d9b1be7732ef5d8 (diff)
downloadguile-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.scm10
-rw-r--r--test-suite/tests/tree-il.test14
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))
)