mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 13:30:26 +02:00
Code Activity

peval handles lexical-set

Browse source 
* module/language/tree-il/optimize.scm (alpha-rename, peval): Add
  support for lexical-set, while avoiding copy propagation and pruning
  of assigned variables.
This commit is contained in:
Andy Wingo 2011-09-22 13:16:36 +02:00
parent b8a2b628e9
commit e43921a982
1 changed files with 34 additions and 15 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -88,6 +88,10 @@ references to the new symbols."
(if val (if val
(make-lexical-ref src name (cdr val)) (make-lexical-ref src name (cdr val))
exp))) 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) (($ <lambda> src meta body)
(make-lambda src meta (loop body mapping))) (make-lambda src meta (loop body mapping)))
(($ <let> src names gensyms vals body) (($ <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 ;; Unlike a full-blown partial evaluator, it does not emit definitions
;; of specialized versions of lambdas encountered on its way. Also, ;; of specialized versions of lambdas encountered on its way. Also,
;; it's very conservative: it bails out if `set!', `prompt', etc. are ;; it's not yet complete: it bails out for `prompt', etc.
;; met.
(define local-toplevel-env (define local-toplevel-env
;; The top-level environment of the module being compiled. ;; 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) (define (assigned-lexical? sym)
(let ((v (vhash-assq sym var-table))) (let ((v (vhash-assq sym var-table)))
(and v (var-set? (cdr v))))) (and v (var-set? (cdr v)))))
(define (unreferenced-lexical? sym) (define (lexical-refcount sym)
(let ((v (vhash-assq sym var-table))) (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) (define (apply-primitive name args)
;; todo: further optimize commutative primitives ;; todo: further optimize commutative primitives
@ -297,9 +300,10 @@ it does not handle <fix> and <let-values>, it should be called before
($ <module-ref>) ($ <module-ref>)
($ <primitive-ref>) ($ <primitive-ref>)
($ <dynref>) ($ <dynref>)
($ <toplevel-set>) ; FIXME: these set! expressions ($ <lexical-set>) ; FIXME: these set! expressions
($ <toplevel-define>) ; could return zero values in ($ <toplevel-set>) ; could return zero values in
($ <module-set>)) ; the future ($ <toplevel-define>) ; the future
($ <module-set>)) ;
(and (= (length names) 1) (and (= (length names) 1)
(make-let src names gensyms (list exp) body))) (make-let src names gensyms (list exp) body)))
(($ <application> src (($ <application> src
@ -374,7 +378,8 @@ it does not handle <fix> and <let-values>, it should be called before
(($ <lambda>) #t) (($ <lambda>) #t)
(($ <lambda-case> _ req opt rest kw inits _ body alternate) (($ <lambda-case> _ req opt rest kw inits _ body alternate)
(and (every loop inits) (loop body) (loop alternate))) (and (every loop inits) (loop body) (loop alternate)))
(($ <lexical-ref>) #t) (($ <lexical-ref> _ _ gensym)
(not (assigned-lexical? gensym)))
(($ <primitive-ref>) #t) (($ <primitive-ref>) #t)
(($ <conditional> _ condition subsequent alternate) (($ <conditional> _ condition subsequent alternate)
(and (loop condition) (loop subsequent) (loop 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. ;; This is an anonymous lambda that we're going to inline.
;; Inlining creates new variable bindings, so we need to provide ;; Inlining creates new variable bindings, so we need to provide
;; the new code with fresh names. ;; the new code with fresh names.
(make-lambda src '() (alpha-rename lc))) (make-lambda src '() (record-lexicals! (alpha-rename lc))))
(_ new))) (_ new)))
(catch 'match-error (catch 'match-error
@ -489,14 +494,24 @@ it does not handle <fix> and <let-values>, it should be called before
((effect) (make-void #f)) ((effect) (make-void #f))
(else (else
(let ((val (lookup gensym))) (let ((val (lookup gensym)))
(if (constant-expression? val) (if (and (not (assigned-lexical? gensym))
(constant-expression? val))
(case ctx (case ctx
;; fixme: cache this? it is a divergence from ;; fixme: cache this? it is a divergence from
;; O(n). ;; O(n).
((test) (loop val env calls 'test)) ((test) (loop val env calls 'test))
(else val)) (else val))
exp))))) 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> src names gensyms vals body)
(let* ((vals* (map (cut loop <> env calls 'value) vals)) (let* ((vals* (map (cut loop <> env calls 'value) vals))
(vals (map maybe-unconst vals 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 body
;; Constants have already been propagated, so there is ;; Constants have already been propagated, so there is
;; no need to bind them to lexicals. ;; no need to bind them to lexicals.
(let*-values (((stripped) (remove (compose const? car) (let*-values (((stripped) (remove
(zip vals gensyms names))) (lambda (x)
(and (const? (car x))
(not (assigned-lexical?
(cadr x)))))
(zip vals gensyms names)))
((vals gensyms names) (unzip3 stripped))) ((vals gensyms names) (unzip3 stripped)))
(if (null? stripped) (if (null? stripped)
body body
@ -721,6 +740,6 @@ it does not handle <fix> and <let-values>, it should be called before
(else (else
(lp rest (cons head effects)))))))))))) (lp rest (cons head effects))))))))))))
(lambda _ (lambda _
;; We encountered something we don't handle, like `<lexical-set>', ;; We encountered something we don't handle, like <abort> or
;; <abort>, or some other effecting construct, so bail out. ;; <prompt>, so bail out.
exp))) exp)))