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

thread a context through peval

Browse source 
* module/language/tree-il/optimize.scm (peval): Thread a "context"
  through the evaluator.
This commit is contained in:
Andy Wingo 2011-09-22 11:23:06 +02:00
parent 8f6dfb9ad2
commit e535a37db8
1 changed files with 62 additions and 49 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -427,7 +427,8 @@ it does not handle <fix> and <let-values>, it should be called before
(lambda () (lambda ()
(let loop ((exp exp) (let loop ((exp exp)
(env vlist-null) ; static environment (env vlist-null) ; static environment
(calls '())) ; inlined call stack (calls '()) ; inlined call stack
(ctx 'value)) ; effect, value, or call
(define (lookup var) (define (lookup var)
(and=> (vhash-assq var env) cdr)) (and=> (vhash-assq var env) cdr))
@ -437,16 +438,17 @@ it does not handle <fix> and <let-values>, it should be called before
(($ <void>) (($ <void>)
exp) exp)
(($ <lexical-ref> _ _ gensym) (($ <lexical-ref> _ _ gensym)
;; Propagate only pure expressions. ;; Propagate only pure expressions that are not assigned to.
(let ((val (lookup gensym))) (let ((val (lookup gensym)))
(if (pure-expression? val) val exp))) (if (pure-expression? val) val exp)))
;; Lexical set! causes a bailout. ;; Lexical set! causes a bailout.
(($ <let> src names gensyms vals body) (($ <let> src names gensyms vals body)
(let* ((vals* (map (cut loop <> env calls) vals)) (let* ((vals* (map (cut loop <> env calls 'value) vals))
(vals (map maybe-unconst vals vals*)) (vals (map maybe-unconst vals vals*))
(body* (loop body (body* (loop body
(fold vhash-consq env gensyms vals) (fold vhash-consq env gensyms vals)
calls)) calls
ctx))
(body (maybe-unconst body body*))) (body (maybe-unconst body body*)))
(if (const? body*) (if (const? body*)
body body
@ -460,20 +462,22 @@ it does not handle <fix> and <let-values>, it should be called before
;; Things could be done more precisely when IN-ORDER? but ;; Things could be done more precisely when IN-ORDER? but
;; it's OK not to do it---at worst we lost an optimization ;; it's OK not to do it---at worst we lost an optimization
;; opportunity. ;; opportunity.
(let* ((vals* (map (cut loop <> env calls) vals)) (let* ((vals* (map (cut loop <> env calls 'value) vals))
(vals (map maybe-unconst vals vals*)) (vals (map maybe-unconst vals vals*))
(body* (loop body (body* (loop body
(fold vhash-consq env gensyms vals) (fold vhash-consq env gensyms vals)
calls)) calls
ctx))
(body (maybe-unconst body body*))) (body (maybe-unconst body body*)))
(if (const? body*) (if (const? body*)
body body
(make-letrec src in-order? names gensyms vals body)))) (make-letrec src in-order? names gensyms vals body))))
(($ <fix> src names gensyms vals body) (($ <fix> src names gensyms vals body)
(let* ((vals (map (cut loop <> env calls) vals)) (let* ((vals (map (cut loop <> env calls 'value) vals))
(body* (loop body (body* (loop body
(fold vhash-consq env gensyms vals) (fold vhash-consq env gensyms vals)
calls)) calls
ctx))
(body (maybe-unconst body body*))) (body (maybe-unconst body body*)))
(if (const? body*) (if (const? body*)
body body
@ -482,29 +486,31 @@ it does not handle <fix> and <let-values>, it should be called before
;; Peval the producer, then try to inline the consumer into ;; Peval the producer, then try to inline the consumer into
;; the producer. If that succeeds, peval again. Otherwise ;; the producer. If that succeeds, peval again. Otherwise
;; reconstruct the let-values, pevaling the consumer. ;; reconstruct the let-values, pevaling the consumer.
(let ((producer (maybe-unconst producer (loop producer env calls)))) (let ((producer (maybe-unconst producer
(loop producer env calls 'value))))
(or (match consumer (or (match consumer
(($ <lambda-case> src req #f #f #f () gensyms body #f) (($ <lambda-case> src req #f #f #f () gensyms body #f)
(cond (cond
((inline-values producer src req gensyms body) ((inline-values producer src req gensyms body)
=> (cut loop <> env calls)) => (cut loop <> env calls ctx))
(else #f))) (else #f)))
(_ #f)) (_ #f))
(make-let-values lv-src producer (make-let-values lv-src producer
(loop consumer env calls))))) (loop consumer env calls ctx)))))
(($ <dynwind> src winder body unwinder) (($ <dynwind> src winder body unwinder)
(make-dynwind src (loop winder env calls) (make-dynwind src (loop winder env calls 'effect)
(loop body env calls) (loop body env calls ctx)
(loop unwinder env calls))) (loop unwinder env calls 'effect)))
(($ <dynlet> src fluids vals body) (($ <dynlet> src fluids vals body)
(make-dynlet src (make-dynlet src
(map maybe-unconst fluids (map maybe-unconst fluids
(map (cut loop <> env calls) fluids)) (map (cut loop <> env calls 'value) fluids))
(map maybe-unconst vals (map maybe-unconst vals
(map (cut loop <> env calls) vals)) (map (cut loop <> env calls 'value) vals))
(maybe-unconst body (loop body env calls)))) (maybe-unconst body (loop body env calls ctx))))
(($ <dynref> src fluid) (($ <dynref> src fluid)
(make-dynref src (maybe-unconst fluid (loop fluid env calls)))) (make-dynref src
(maybe-unconst fluid (loop fluid env calls 'value))))
(($ <toplevel-ref> src (? effect-free-primitive? name)) (($ <toplevel-ref> src (? effect-free-primitive? name))
(if (local-toplevel? name) (if (local-toplevel? name)
exp exp
@ -516,42 +522,42 @@ it does not handle <fix> and <let-values>, it should be called before
exp) exp)
(($ <module-set> src mod name public? exp) (($ <module-set> src mod name public? exp)
(make-module-set src mod name public? (make-module-set src mod name public?
(maybe-unconst exp (loop exp env '())))) (maybe-unconst exp (loop exp env '() 'value))))
(($ <toplevel-define> src name exp) (($ <toplevel-define> src name exp)
(make-toplevel-define src name (make-toplevel-define src name
(maybe-unconst exp (loop exp env '())))) (maybe-unconst exp (loop exp env '() 'value))))
(($ <toplevel-set> src name exp) (($ <toplevel-set> src name exp)
(make-toplevel-set src name (make-toplevel-set src name
(maybe-unconst exp (loop exp env '())))) (maybe-unconst exp (loop exp env '() 'value))))
(($ <primitive-ref>) (($ <primitive-ref>)
exp) exp)
(($ <conditional> src condition subsequent alternate) (($ <conditional> src condition subsequent alternate)
(let ((condition (loop condition env calls))) (let ((condition (loop condition env calls 'value)))
(if (const*? condition) (if (const*? condition)
(if (or (lambda? condition) (void? condition) (if (or (lambda? condition) (void? condition)
(const-exp condition)) (const-exp condition))
(loop subsequent env calls) (loop subsequent env calls ctx)
(loop alternate env calls)) (loop alternate env calls ctx))
(make-conditional src condition (make-conditional src condition
(loop subsequent env calls) (loop subsequent env calls ctx)
(loop alternate env calls))))) (loop alternate env calls ctx)))))
(($ <application> src (($ <application> src
($ <primitive-ref> _ '@call-with-values) ($ <primitive-ref> _ '@call-with-values)
(producer (producer
($ <lambda> _ _ ($ <lambda> _ _
(and consumer (and consumer
;; No optional or kwargs. ;; No optional or kwargs.
($ <lambda-case> ($ <lambda-case>
_ req #f rest #f () gensyms body #f))))) _ req #f rest #f () gensyms body #f)))))
(loop (make-let-values src (make-application src producer '()) (loop (make-let-values src (make-application src producer '())
consumer) consumer)
env calls)) env calls ctx))
(($ <application> src orig-proc orig-args) (($ <application> src orig-proc orig-args)
;; todo: augment the global env with specialized functions ;; todo: augment the global env with specialized functions
(let* ((proc (loop orig-proc env calls)) (let* ((proc (loop orig-proc env calls 'call))
(proc* (maybe-unlambda orig-proc proc env)) (proc* (maybe-unlambda orig-proc proc env))
(args (map (cut loop <> env calls) orig-args)) (args (map (cut loop <> env calls 'value) orig-args))
(args* (map (cut maybe-unlambda <> <> env) (args* (map (cut maybe-unlambda <> <> env)
orig-args orig-args
(map maybe-unconst orig-args args))) (map maybe-unconst orig-args args)))
@ -594,7 +600,8 @@ it does not handle <fix> and <let-values>, it should be called before
(body (body
(loop body (loop body
(fold vhash-consq env gensyms params) (fold vhash-consq env gensyms params)
(cons (cons proc args) calls)))) (cons (cons proc args) calls)
ctx)))
;; If the residual code contains recursive ;; If the residual code contains recursive
;; calls, give up inlining. ;; calls, give up inlining.
(if (code-contains-calls? body proc lookup) (if (code-contains-calls? body proc lookup)
@ -614,23 +621,29 @@ it does not handle <fix> and <let-values>, it should be called before
app))) app)))
(($ <lambda> src meta body) (($ <lambda> src meta body)
(make-lambda src meta (loop body env calls))) (make-lambda src meta (loop body env calls 'value)))
(($ <lambda-case> src req opt rest kw inits gensyms body alt) (($ <lambda-case> src req opt rest kw inits gensyms body alt)
(make-lambda-case src req opt rest kw (make-lambda-case src req opt rest kw
(map maybe-unconst inits (map maybe-unconst inits
(map (cut loop <> env calls) inits)) (map (cut loop <> env calls 'value) inits))
gensyms gensyms
(maybe-unconst body (loop body env calls)) (maybe-unconst body (loop body env calls ctx))
alt)) alt))
(($ <sequence> src exps) (($ <sequence> src exps)
(let ((exps (map (cut loop <> env calls) exps))) (let lp ((exps exps) (effects '()))
(if (every pure-expression? exps) (match exps
(last exps) ((last)
(match (reverse exps) (if (null? effects)
;; Remove all expressions but the last one. (loop last env calls ctx)
((keep rest ...) (make-sequence src (append (reverse effects)
(let ((rest (remove pure-expression? rest))) (list
(make-sequence src (reverse (cons keep rest)))))))))))) (loop last env calls ctx))))))
((head . rest)
(let ((head (loop head env calls 'effect)))
(lp rest
(if (pure-expression? head)
effects
(cons head effects)))))))))))
(lambda _ (lambda _
;; We encountered something we don't handle, like `<lexical-set>', ;; We encountered something we don't handle, like `<lexical-set>',
;; <abort>, or some other effecting construct, so bail out. ;; <abort>, or some other effecting construct, so bail out.