summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2011-09-21 08:56:09 +0200
committerAndy Wingo <wingo@pobox.com>2011-09-21 08:56:09 +0200
commit65a32655253cdfcf4e2caf03a73ac66b05da5f71 (patch)
treed6a2076707ec1a2dda4b3db32530f8c6e7c3efc8
parent03026d0fb888c4d19b87a995c641cb3e93afd973 (diff)
downloadguile-65a32655253cdfcf4e2caf03a73ac66b05da5f71.tar.gz
peval support for more forms
* module/language/tree-il/optimize.scm (peval): Add support for fix, dynwind, dynlet, dynref, module-set, and toplevel-set. (Mutating a variable directly is similar to calling a function that does so behind our backs, so this presents no additional problem.)
-rw-r--r--module/language/tree-il/optimize.scm29
1 files changed, 29 insertions, 0 deletions
diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm
index b926081cc..5f053c17c 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -320,6 +320,7 @@ it does not handle <fix> and <let-values>, it should be called before
;; Propagate only pure expressions.
(let ((val (lookup gensym)))
(or (and (pure-expression? val) val) exp)))
+ ;; Lexical set! causes a bailout.
(($ <let> src names gensyms vals body)
(let* ((vals* (map (cut loop <> env calls) vals))
(vals (map maybe-unconst vals vals*))
@@ -348,6 +349,28 @@ it does not handle <fix> and <let-values>, it should be called before
(if (const? body*)
body
(make-letrec src in-order? names gensyms vals body))))
+ (($ <fix> src names gensyms vals body)
+ (let* ((vals (map (cut loop <> env calls) vals))
+ (body* (loop body
+ (fold vhash-consq env gensyms vals)
+ calls))
+ (body (maybe-unconst body body*)))
+ (if (const? body*)
+ body
+ (make-fix src names gensyms vals body))))
+ (($ <dynwind> src winder body unwinder)
+ (make-dynwind src (loop winder env calls)
+ (loop body env calls)
+ (loop unwinder env calls)))
+ (($ <dynlet> src fluids vals body)
+ (make-dynlet src
+ (map maybe-unconst fluids
+ (map (cut loop <> env calls) fluids))
+ (map maybe-unconst vals
+ (map (cut loop <> env calls) vals))
+ (maybe-unconst body (loop body env calls))))
+ (($ <dynref> src fluid)
+ (make-dynref src (maybe-unconst fluid (loop fluid env calls))))
(($ <toplevel-ref> src (? effect-free-primitive? name))
(if (local-toplevel? name)
exp
@@ -357,9 +380,15 @@ it does not handle <fix> and <let-values>, it should be called before
exp)
(($ <module-ref>)
exp)
+ (($ <module-set> src mod name public? exp)
+ (make-module-set src mod name public?
+ (maybe-unconst exp (loop exp env '()))))
(($ <toplevel-define> src name exp)
(make-toplevel-define src name
(maybe-unconst exp (loop exp env '()))))
+ (($ <toplevel-set> src name exp)
+ (make-toplevel-set src name
+ (maybe-unconst exp (loop exp env '()))))
(($ <primitive-ref>)
exp)
(($ <conditional> src condition subsequent alternate)