diff options
author | Andy Wingo <wingo@pobox.com> | 2011-09-21 08:56:09 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2011-09-21 08:56:09 +0200 |
commit | 65a32655253cdfcf4e2caf03a73ac66b05da5f71 (patch) | |
tree | d6a2076707ec1a2dda4b3db32530f8c6e7c3efc8 | |
parent | 03026d0fb888c4d19b87a995c641cb3e93afd973 (diff) | |
download | guile-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.scm | 29 |
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) |