summaryrefslogtreecommitdiff
path: root/module/language/tree-il/optimize.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2011-09-22 13:16:36 +0200
committerAndy Wingo <wingo@pobox.com>2011-09-24 19:02:53 +0200
commite43921a982fe207c99695c6eb01abffb0c9a559b (patch)
treec5134fb88c815d47be5b4883a6ea530197ee7c7f /module/language/tree-il/optimize.scm
parentb8a2b628e9c663ff58d442a895c4d20541d54b1f (diff)
downloadguile-e43921a982fe207c99695c6eb01abffb0c9a559b.tar.gz
peval handles lexical-set
* module/language/tree-il/optimize.scm (alpha-rename, peval): Add support for lexical-set, while avoiding copy propagation and pruning of assigned variables.
Diffstat (limited to 'module/language/tree-il/optimize.scm')
-rw-r--r--module/language/tree-il/optimize.scm49
1 files changed, 34 insertions, 15 deletions
diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm
index 2e119d969..aa793696a 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -88,6 +88,10 @@ references to the new symbols."
(if val
(make-lexical-ref src name (cdr val))
exp)))
+ (($ <lexical-set> src name gensym exp)
+ (let ((val (vhash-assq gensym mapping)))
+ (make-lexical-set src name (if val (cdr val) gensym)
+ (loop exp mapping))))
(($ <lambda> src meta body)
(make-lambda src meta (loop body mapping)))
(($ <let> src names gensyms vals body)
@@ -241,8 +245,7 @@ it does not handle <fix> and <let-values>, it should be called before
;;
;; Unlike a full-blown partial evaluator, it does not emit definitions
;; of specialized versions of lambdas encountered on its way. Also,
- ;; it's very conservative: it bails out if `set!', `prompt', etc. are
- ;; met.
+ ;; it's not yet complete: it bails out for `prompt', etc.
(define local-toplevel-env
;; The top-level environment of the module being compiled.
@@ -269,9 +272,9 @@ it does not handle <fix> and <let-values>, it should be called before
(define (assigned-lexical? sym)
(let ((v (vhash-assq sym var-table)))
(and v (var-set? (cdr v)))))
- (define (unreferenced-lexical? sym)
+ (define (lexical-refcount sym)
(let ((v (vhash-assq sym var-table)))
- (if v (zero? (var-refcount (cdr v))) #t)))
+ (if v (var-refcount (cdr v)) 0)))
(define (apply-primitive name args)
;; todo: further optimize commutative primitives
@@ -297,9 +300,10 @@ it does not handle <fix> and <let-values>, it should be called before
($ <module-ref>)
($ <primitive-ref>)
($ <dynref>)
- ($ <toplevel-set>) ; FIXME: these set! expressions
- ($ <toplevel-define>) ; could return zero values in
- ($ <module-set>)) ; the future
+ ($ <lexical-set>) ; FIXME: these set! expressions
+ ($ <toplevel-set>) ; could return zero values in
+ ($ <toplevel-define>) ; the future
+ ($ <module-set>)) ;
(and (= (length names) 1)
(make-let src names gensyms (list exp) body)))
(($ <application> src
@@ -374,7 +378,8 @@ it does not handle <fix> and <let-values>, it should be called before
(($ <lambda>) #t)
(($ <lambda-case> _ req opt rest kw inits _ body alternate)
(and (every loop inits) (loop body) (loop alternate)))
- (($ <lexical-ref>) #t)
+ (($ <lexical-ref> _ _ gensym)
+ (not (assigned-lexical? gensym)))
(($ <primitive-ref>) #t)
(($ <conditional> _ condition subsequent alternate)
(and (loop condition) (loop subsequent) (loop alternate)))
@@ -462,7 +467,7 @@ it does not handle <fix> and <let-values>, it should be called before
;; This is an anonymous lambda that we're going to inline.
;; Inlining creates new variable bindings, so we need to provide
;; the new code with fresh names.
- (make-lambda src '() (alpha-rename lc)))
+ (make-lambda src '() (record-lexicals! (alpha-rename lc))))
(_ new)))
(catch 'match-error
@@ -489,14 +494,24 @@ it does not handle <fix> and <let-values>, it should be called before
((effect) (make-void #f))
(else
(let ((val (lookup gensym)))
- (if (constant-expression? val)
+ (if (and (not (assigned-lexical? gensym))
+ (constant-expression? val))
(case ctx
;; fixme: cache this? it is a divergence from
;; O(n).
((test) (loop val env calls 'test))
(else val))
exp)))))
- ;; Lexical set! causes a bailout.
+ (($ <lexical-set> src name gensym exp)
+ (if (zero? (lexical-refcount gensym))
+ (let ((exp (loop exp env calls 'effect)))
+ (if (void? exp)
+ exp
+ (make-sequence src (list exp (make-void #f)))))
+ (make-lexical-set src name gensym
+ (maybe-unconst
+ exp
+ (loop exp env calls 'value)))))
(($ <let> src names gensyms vals body)
(let* ((vals* (map (cut loop <> env calls 'value) vals))
(vals (map maybe-unconst vals vals*))
@@ -509,8 +524,12 @@ it does not handle <fix> and <let-values>, it should be called before
body
;; Constants have already been propagated, so there is
;; no need to bind them to lexicals.
- (let*-values (((stripped) (remove (compose const? car)
- (zip vals gensyms names)))
+ (let*-values (((stripped) (remove
+ (lambda (x)
+ (and (const? (car x))
+ (not (assigned-lexical?
+ (cadr x)))))
+ (zip vals gensyms names)))
((vals gensyms names) (unzip3 stripped)))
(if (null? stripped)
body
@@ -721,6 +740,6 @@ it does not handle <fix> and <let-values>, it should be called before
(else
(lp rest (cons head effects))))))))))))
(lambda _
- ;; We encountered something we don't handle, like `<lexical-set>',
- ;; <abort>, or some other effecting construct, so bail out.
+ ;; We encountered something we don't handle, like <abort> or
+ ;; <prompt>, so bail out.
exp)))