mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-30 00:40:20 +02:00
Code Activity

peval: elide make-prompt-tag in effect context

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2011-09-27 13:42:43 +02:00
parent ea726a53b2
commit 6c4ffe2b25
2 changed files with 17 additions and 7 deletions
Download patch file Download diff file Expand all files Collapse all files

10
module/language/tree-il/optimize.scm
View file

@ -769,8 +769,7 @@ it does not handle <fix> and <let-values>, it should be called before
(($ <primitive-ref> _ (? constructor-primitive? name)) (($ <primitive-ref> _ (? constructor-primitive? name))
(case ctx (case ctx
((effect test) ((effect test)
(let ((exp (for-value exp)) (let ((res (if (eq? ctx 'effect)
(res (if (eq? ctx 'effect)
(make-void #f) (make-void #f)
(make-const #f #t)))) (make-const #f #t))))
(match (for-value exp) (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) (($ <application> _ ($ <primitive-ref> _ 'vector) elts)
(for-tail (for-tail
(make-sequence src (append elts (list res))))) (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 (else
(match (cons name (map for-value orig-args)) (match (cons name (map for-value orig-args))
(('cons head tail) (('cons head tail)

14
test-suite/tests/tree-il.test
View file

@ -1282,10 +1282,16 @@
(call-with-prompt tag (call-with-prompt tag
(lambda () 1) (lambda () 1)
(lambda args args))) (lambda args args)))
;; FIXME: elide the (make-prompt-tag) call (const 1))
(begin
(apply (primitive make-prompt-tag)) (pass-if-peval
(const 1))) 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))
) )