summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2011-11-09 15:23:58 +0100
committerAndy Wingo <wingo@pobox.com>2011-11-09 16:54:30 +0100
commit8ee0b28b4d51dac704c151bf7f6d1874018ed3ae (patch)
tree006f566a1f8502e9b46a0995957b173da6c1288c
parent5e9b9059a334be0427eeb37eee6627dd595dc567 (diff)
downloadguile-8ee0b28b4d51dac704c151bf7f6d1874018ed3ae.tar.gz
peval: fix dynwind bug.
* module/language/tree-il/peval.scm (peval): The <dynwind> compiler will copy the winder and unwinder values, so make sure that they are constant, and if not, create lexical bindings. Fixes http://debbugs.gnu.org/9844. * test-suite/tests/tree-il.test ("partial evaluation"): Add a couple <dynwind> tests.
-rw-r--r--module/language/tree-il/peval.scm35
-rw-r--r--test-suite/tests/tree-il.test20
2 files changed, 53 insertions, 2 deletions
diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index 9524133bf..634c6c91c 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -870,8 +870,39 @@ top-level bindings from ENV and return the resulting expression."
(_ #f))
(make-let-values lv-src producer (for-tail consumer)))))
(($ <dynwind> src winder body unwinder)
- (make-dynwind src (for-value winder) (for-tail body)
- (for-value unwinder)))
+ (let ((pre (for-value winder))
+ (body (for-tail body))
+ (post (for-value unwinder)))
+ (cond
+ ((not (constant-expression? pre))
+ (cond
+ ((not (constant-expression? post))
+ (let ((pre-sym (gensym "pre ")) (post-sym (gensym "post ")))
+ (record-new-temporary! 'pre pre-sym 1)
+ (record-new-temporary! 'post post-sym 1)
+ (make-let src '(pre post) (list pre-sym post-sym) (list pre post)
+ (make-dynwind src
+ (make-lexical-ref #f 'pre pre-sym)
+ body
+ (make-lexical-ref #f 'post post-sym)))))
+ (else
+ (let ((pre-sym (gensym "pre ")))
+ (record-new-temporary! 'pre pre-sym 1)
+ (make-let src '(pre) (list pre-sym) (list pre)
+ (make-dynwind src
+ (make-lexical-ref #f 'pre pre-sym)
+ body
+ post))))))
+ ((not (constant-expression? post))
+ (let ((post-sym (gensym "post ")))
+ (record-new-temporary! 'post post-sym 1)
+ (make-let src '(post) (list post-sym) (list post)
+ (make-dynwind src
+ pre
+ body
+ (make-lexical-ref #f 'post post-sym)))))
+ (else
+ (make-dynwind src pre body post)))))
(($ <dynlet> src fluids vals body)
(make-dynlet src (map for-value fluids) (map for-value vals)
(for-tail body)))
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 011fef5a4..e9ac34f8f 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -1457,6 +1457,26 @@
(pass-if-peval
resolve-primitives
+ ;; Non-constant guards get lexical bindings.
+ (dynamic-wind foo (lambda () bar) baz)
+ (let (pre post) (_ _) ((toplevel foo) (toplevel baz))
+ (dynwind (lexical pre _) (toplevel bar) (lexical post _))))
+
+ (pass-if-peval
+ resolve-primitives
+ ;; Constant guards don't need lexical bindings.
+ (dynamic-wind (lambda () foo) (lambda () bar) (lambda () baz))
+ (dynwind
+ (lambda ()
+ (lambda-case
+ ((() #f #f #f () ()) (toplevel foo))))
+ (toplevel bar)
+ (lambda ()
+ (lambda-case
+ ((() #f #f #f () ()) (toplevel baz))))))
+
+ (pass-if-peval
+ resolve-primitives
;; Prompt is removed if tag is unreferenced
(let ((tag (make-prompt-tag)))
(call-with-prompt tag