mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

peval refactor

Browse source 
* module/language/tree-il/optimize.scm (peval): Add for-value, for-test,
  for-effect, and for-tail helpers.  Use them.
This commit is contained in:
Andy Wingo 2011-09-23 00:05:27 +02:00
parent f6123e4fda
commit ded8ad84a7
1 changed files with 48 additions and 46 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -485,6 +485,15 @@ it does not handle <fix> and <let-values>, it should be called before
(define (lookup var) (define (lookup var)
(and=> (vhash-assq var env) cdr)) (and=> (vhash-assq var env) cdr))
(define (for-value exp)
(loop exp env calls 'value))
(define (for-test exp)
(loop exp env calls 'test))
(define (for-effect exp)
(loop exp env calls 'effect))
(define (for-tail exp)
(loop exp env calls ctx))
(match exp (match exp
(($ <const>) (($ <const>)
(case ctx (case ctx
@ -515,35 +524,34 @@ it does not handle <fix> and <let-values>, it should be called before
;; Always propagate simple values that cannot lead to ;; Always propagate simple values that cannot lead to
;; code bloat. ;; code bloat.
(case ctx (case ctx
((test) (loop val env calls 'test)) ((test) (for-test val))
(else val))) (else val)))
((= 1 (lexical-refcount gensym)) ((= 1 (lexical-refcount gensym))
;; Always propagate values referenced only once. ;; Always propagate values referenced only once.
;; There is no need to rename the bindings, as they ;; There is no need to rename the bindings, as they
;; are only being moved, not copied. ;; are only being moved, not copied.
(case ctx (case ctx
((test) (loop val env calls 'test)) ((test) (for-test val))
(else val))) (else val)))
(else (else
;; Always propagate constant expressions. FIXME: leads to ;; Always propagate constant expressions. FIXME: leads to
;; divergence! ;; divergence!
(case ctx (case ctx
((test) (loop val env calls 'test)) ((test) (for-test val))
(else val)))))))) (else val))))))))
(($ <lexical-set> src name gensym exp) (($ <lexical-set> src name gensym exp)
(if (zero? (lexical-refcount gensym)) (if (zero? (lexical-refcount gensym))
(let ((exp (loop exp env calls 'effect))) (let ((exp (for-effect exp)))
(if (void? exp) (if (void? exp)
exp exp
(make-sequence src (list exp (make-void #f))))) (make-sequence src (list exp (make-void #f)))))
(begin (begin
(record-residual-lexical-reference! gensym) (record-residual-lexical-reference! gensym)
(make-lexical-set src name gensym (make-lexical-set src name gensym
(maybe-unconst (maybe-unconst exp
exp (for-value 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 for-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)
@ -574,7 +582,7 @@ 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 'value) vals)) (let* ((vals* (map for-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)
@ -585,7 +593,7 @@ it does not handle <fix> and <let-values>, it should be called before
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 'value) vals)) (let* ((vals (map for-value vals))
(body* (loop body (body* (loop body
(fold vhash-consq env gensyms vals) (fold vhash-consq env gensyms vals)
calls calls
@ -598,31 +606,26 @@ 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 (let ((producer (maybe-unconst producer (for-value 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 ctx)) => for-tail)
(else #f))) (else #f)))
(_ #f)) (_ #f))
(make-let-values lv-src producer (make-let-values lv-src producer (for-tail consumer)))))
(loop consumer env calls ctx)))))
(($ <dynwind> src winder body unwinder) (($ <dynwind> src winder body unwinder)
(make-dynwind src (loop winder env calls 'value) (make-dynwind src (for-value winder) (for-tail body)
(loop body env calls ctx) (for-value unwinder)))
(loop unwinder env calls 'value)))
(($ <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 for-value fluids))
(map (cut loop <> env calls 'value) fluids)) (map maybe-unconst vals (map for-value vals))
(map maybe-unconst vals (maybe-unconst body (for-tail body))))
(map (cut loop <> env calls 'value) vals))
(maybe-unconst body (loop body env calls ctx))))
(($ <dynref> src fluid) (($ <dynref> src fluid)
(make-dynref src (make-dynref src
(maybe-unconst fluid (loop fluid env calls 'value)))) (maybe-unconst fluid (for-value fluid))))
(($ <toplevel-ref> src (? effect-free-primitive? name)) (($ <toplevel-ref> src (? effect-free-primitive? name))
(if (local-toplevel? name) (if (local-toplevel? name)
exp exp
@ -634,27 +637,27 @@ 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 '() 'value)))) (maybe-unconst exp (for-value exp))))
(($ <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 '() 'value)))) (maybe-unconst exp (for-value exp))))
(($ <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 '() 'value)))) (maybe-unconst exp (for-value exp))))
(($ <primitive-ref>) (($ <primitive-ref>)
(case ctx (case ctx
((effect) (make-void #f)) ((effect) (make-void #f))
((test) (make-const #f #t)) ((test) (make-const #f #t))
(else exp))) (else exp)))
(($ <conditional> src condition subsequent alternate) (($ <conditional> src condition subsequent alternate)
(let ((condition (loop condition env calls 'test))) (let ((condition (for-test condition)))
(if (const? condition) (if (const? condition)
(if (const-exp condition) (if (const-exp condition)
(loop subsequent env calls ctx) (for-tail subsequent)
(loop alternate env calls ctx)) (for-tail alternate))
(make-conditional src condition (make-conditional src condition
(loop subsequent env calls ctx) (for-tail subsequent)
(loop alternate env calls ctx))))) (for-tail alternate)))))
(($ <application> src (($ <application> src
($ <primitive-ref> _ '@call-with-values) ($ <primitive-ref> _ '@call-with-values)
(producer (producer
@ -663,15 +666,14 @@ it does not handle <fix> and <let-values>, it should be called before
;; 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 '()) (for-tail (make-let-values src (make-application src producer '())
consumer) consumer)))
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 'call)) (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 'value) orig-args)) (args (map for-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)))
@ -722,9 +724,9 @@ it does not handle <fix> and <let-values>, it should be called before
(+ nreq nopt)))))) (+ nreq nopt))))))
(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))) 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)
@ -748,26 +750,26 @@ it does not handle <fix> and <let-values>, it should be called before
((effect) (make-void #f)) ((effect) (make-void #f))
((test) (make-const #f #t)) ((test) (make-const #f #t))
(else (else
(make-lambda src meta (loop body env calls 'value))))) (make-lambda src meta (for-value body)))))
(($ <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 'value) inits)) (map for-value inits))
gensyms gensyms
(maybe-unconst body (loop body env calls ctx)) (maybe-unconst body (for-tail body))
alt)) (and alt (for-tail alt))))
(($ <sequence> src exps) (($ <sequence> src exps)
(let lp ((exps exps) (effects '())) (let lp ((exps exps) (effects '()))
(match exps (match exps
((last) ((last)
(if (null? effects) (if (null? effects)
(loop last env calls ctx) (for-tail last)
(make-sequence src (append (reverse effects) (make-sequence src (append (reverse effects)
(list (list
(maybe-unconst last (maybe-unconst last
(loop last env calls ctx))))))) (for-tail last)))))))
((head . rest) ((head . rest)
(let ((head (loop head env calls 'effect))) (let ((head (for-effect head)))
(cond (cond
((sequence? head) ((sequence? head)
(lp (append (sequence-exps head) rest) effects)) (lp (append (sequence-exps head) rest) effects))