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

peval: visit operands on-demand, to inline mutually recursive bindings

Browse source 
This commit changes to use <operand> structures to hold the context
needed to visit lexical bindings lazily, in context, instead of eagerly
visiting them for value.  This laziness enables inlining of mutually
recursive bindings.

* module/language/tree-il/peval.scm (<var>): Remove comment about copy
  propagation having to run build-var-table; things don't work like that
  any more.
  (build-var-table): Build <var> entries for all variables, even
  unreferenced variables.
  (alpha-rename): Remove.  We will rename bindings on-demand now.

  (peval lookup-var): New helper, to fetch the <var> of a gensym.

  (peval fresh-gensyms): Fold here, under peval, and in it, handle
  updating the store to record a mapping between new names and <var>
  entries from the source program.

  (peval record-source-expression): Don't call build-var-table on the
  new expression, as alpha-renaming happens on-demand now.

  (peval prune-bindings): Rewrite to work with mutually-recursive
  bindings, while optionally preserving binding order.

  (peval extend-env): New helper.

  (peval loop): OK, here goes... Remove the `operand' context, as now we
  visit operands lazily.  Add a `call' context, which does not
  copy-propagate lambda expressions, used to residualize a call after
  aborting an inlining attempt.  Change the `env' to be a mapping of
  gensym to <operand>.  Instead of looking up the operand's binding then
  alpha-renaming it, just rely on the fact that visiting the operand
  will rename it if necessary.

  If we residualize a lexical, do so with the fresh name from the
  environment.  If we visit an operand and it doesn't turn out to be
  constant, we will never be able to copy it, and so cache that fact in
  the operand.  If we residualize a binding and we know what the value
  should be, record that binding so that prune-bindings won't have to
  visit it again.  If the operand folds to a constant, cache that too,
  to save effort when unrolling loops.

  For let, letrec, fix, and lambda-case, instead of visiting the
  bindings eagerly for value, simply record the source expressions and
  environments in an <operand> and rely on copy-propagation to visit
  them later in the right context.  In the case of letrec and fix, this
  allows mutually-recursive bindings to be inlined.

  Refactor folding of "constructors" (which still need renaming) to
  avoid visiting operands twice in some contexts.

  For applications, if we have to abort, process the procedure in call
  context, which allows some folding but avoids copying lambdas.  If we
  find a recursive procedure, mark intervening counters as recursive
  too, to allow for mutual recursion at the top level.

  For lambdas, if we are processing for value, record the source
  expression so we can detect recursion.  This was previously done in
  the lexical-ref copy propagator.

* test-suite/tests/tree-il.test ("partial evaluation"): Remove unused
  recursive lexicals in a couple of cases.  Add a couple test cases for
  pruning.  Add a few recursive binding cases.
This commit is contained in:
Andy Wingo 2011-10-10 12:58:28 +02:00
parent 580a59e75e
commit 751708726b
2 changed files with 478 additions and 388 deletions
Download patch file Download diff file Expand all files Collapse all files

710
module/language/tree-il/peval.scm
View file

@ -103,10 +103,6 @@
;; the set of assigned lexicals, and to identify unreferenced and ;; the set of assigned lexicals, and to identify unreferenced and
;; singly-referenced lexicals. ;; singly-referenced lexicals.
;; ;;
;; If peval introduces more code, via copy-propagation, it will need to
;; run `build-var-table' on the new code to add to make sure it can find
;; a <var> for each gensym bound in the program.
;;
(define-record-type <var> (define-record-type <var>
(make-var name gensym refcount set?) (make-var name gensym refcount set?)
var? var?
@ -120,22 +116,36 @@
(lambda (exp res) (lambda (exp res)
(match exp (match exp
(($ <lexical-ref> src name gensym) (($ <lexical-ref> src name gensym)
(let ((var (vhash-assq gensym res))) (let ((var (cdr (vhash-assq gensym res))))
(if var (set-var-refcount! var (1+ (var-refcount var)))
(begin res))
(set-var-refcount! (cdr var) (1+ (var-refcount (cdr var))))
res)
(vhash-consq gensym (make-var name gensym 1 #f) res))))
(_ res))) (_ res)))
(lambda (exp res) (lambda (exp res)
(match exp (match exp
(($ <lambda-case> src req opt rest kw init gensyms body alt)
(fold (lambda (name sym res)
(vhash-consq sym (make-var name sym 0 #f) res))
res
(append req (or opt '()) (if rest (list rest) '())
(match kw
((aok? (kw name sym) ...) name)
(_ '())))
gensyms))
(($ <let> src names gensyms vals body)
(fold (lambda (name sym res)
(vhash-consq sym (make-var name sym 0 #f) res))
res names gensyms))
(($ <letrec> src in-order? names gensyms vals body)
(fold (lambda (name sym res)
(vhash-consq sym (make-var name sym 0 #f) res))
res names gensyms))
(($ <fix> src names gensyms vals body)
(fold (lambda (name sym res)
(vhash-consq sym (make-var name sym 0 #f) res))
res names gensyms))
(($ <lexical-set> src name gensym exp) (($ <lexical-set> src name gensym exp)
(let ((var (vhash-assq gensym res))) (set-var-set?! (cdr (vhash-assq gensym res)) #t)
(if var res)
(begin
(set-var-set?! (cdr var) #t)
res)
(vhash-consq gensym (make-var name gensym 0 #t) res))))
(_ res))) (_ res)))
(lambda (exp res) res) (lambda (exp res) res)
table exp)) table exp))
@ -180,7 +190,7 @@
(effort effort-counter) (effort effort-counter)
(size size-counter) (size size-counter)
(continuation counter-continuation) (continuation counter-continuation)
(recursive? counter-recursive?) (recursive? counter-recursive? set-counter-recursive?!)
(data counter-data) (data counter-data)
(prev counter-prev)) (prev counter-prev))
@ -250,6 +260,8 @@
;; eagerly. By doing so, hopefully we can get process them in a way ;; eagerly. By doing so, hopefully we can get process them in a way
;; appropriate to their use contexts. Operands also prevent values from ;; appropriate to their use contexts. Operands also prevent values from
;; being visited multiple times, wasting effort. ;; being visited multiple times, wasting effort.
;;
;; TODO: Record value size in operand structure?
;; ;;
(define-record-type <operand> (define-record-type <operand>
(%make-operand var sym visit source visit-count residualize? (%make-operand var sym visit source visit-count residualize?
@ -313,127 +325,6 @@
;; FIXME: add more cases? ;; FIXME: add more cases?
(else #f))) (else #f)))
(define (fresh-gensyms syms)
(map (lambda (x) (gensym (string-append (symbol->string x) " ")))
syms))
;; Copy propagation of terms that bind variables, like `lambda' terms,
;; will need to bind fresh variables. This procedure renames all the
;; lexicals in a term.
;;
(define (alpha-rename exp)
"Alpha-rename EXP. For any lambda in EXP, generate new symbols and
replace all lexical references to the former symbols with lexical
references to the new symbols."
;; XXX: This should be factorized somehow.
(let loop ((exp exp)
(mapping vlist-null)) ; maps old to new gensyms
(match exp
(($ <lambda-case> src req opt rest kw inits gensyms body alt)
;; Create new symbols to replace GENSYMS and propagate them down
;; in BODY and ALT.
(let* ((new (fresh-gensyms
(append req
(or opt '())
(if rest (list rest) '())
(match kw
((aok? (_ name _) ...) name)
(_ '())))))
(mapping (fold vhash-consq mapping gensyms new)))
(make-lambda-case src req opt rest
(match kw
((aok? (kw name old) ...)
(cons aok? (map list
kw
name
(take-right new (length old)))))
(_ #f))
(map (cut loop <> mapping) inits)
new
(loop body mapping)
(and alt (loop alt mapping)))))
(($ <lexical-ref> src name gensym)
;; Possibly replace GENSYM by the new gensym defined in MAPPING.
(let ((val (vhash-assq gensym mapping)))
(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)
;; As for `lambda-case' rename GENSYMS to avoid any collision.
(let* ((new (fresh-gensyms names))
(mapping (fold vhash-consq mapping gensyms new))
(vals (map (cut loop <> mapping) vals))
(body (loop body mapping)))
(make-let src names new vals body)))
(($ <letrec> src in-order? names gensyms vals body)
;; Likewise.
(let* ((new (fresh-gensyms names))
(mapping (fold vhash-consq mapping gensyms new))
(vals (map (cut loop <> mapping) vals))
(body (loop body mapping)))
(make-letrec src in-order? names new vals body)))
(($ <fix> src names gensyms vals body)
;; Likewise.
(let* ((new (fresh-gensyms names))
(mapping (fold vhash-consq mapping gensyms new))
(vals (map (cut loop <> mapping) vals))
(body (loop body mapping)))
(make-fix src names new vals body)))
(($ <let-values> src exp body)
(make-let-values src (loop exp mapping) (loop body mapping)))
(($ <const>)
exp)
(($ <void>)
exp)
(($ <toplevel-ref>)
exp)
(($ <module-ref>)
exp)
(($ <primitive-ref>)
exp)
(($ <toplevel-set> src name exp)
(make-toplevel-set src name (loop exp mapping)))
(($ <toplevel-define> src name exp)
(make-toplevel-define src name (loop exp mapping)))
(($ <module-set> src mod name public? exp)
(make-module-set src mod name public? (loop exp mapping)))
(($ <dynlet> src fluids vals body)
(make-dynlet src
(map (cut loop <> mapping) fluids)
(map (cut loop <> mapping) vals)
(loop body mapping)))
(($ <dynwind> src winder body unwinder)
(make-dynwind src
(loop winder mapping)
(loop body mapping)
(loop unwinder mapping)))
(($ <dynref> src fluid)
(make-dynref src (loop fluid mapping)))
(($ <dynset> src fluid exp)
(make-dynset src (loop fluid mapping) (loop exp mapping)))
(($ <conditional> src condition subsequent alternate)
(make-conditional src
(loop condition mapping)
(loop subsequent mapping)
(loop alternate mapping)))
(($ <application> src proc args)
(make-application src (loop proc mapping)
(map (cut loop <> mapping) args)))
(($ <sequence> src exps)
(make-sequence src (map (cut loop <> mapping) exps)))
(($ <prompt> src tag body handler)
(make-prompt src (loop tag mapping) (loop body mapping)
(loop handler mapping)))
(($ <abort> src tag args tail)
(make-abort src (loop tag mapping) (map (cut loop <> mapping) args)
(loop tail mapping))))))
(define* (peval exp #:optional (cenv (current-module)) (env vlist-null) (define* (peval exp #:optional (cenv (current-module)) (env vlist-null)
#:key #:key
(operator-size-limit 40) (operator-size-limit 40)
@ -478,21 +369,29 @@ top-level bindings from ENV and return the resulting expression."
;; ;;
(define store (build-var-table exp)) (define store (build-var-table exp))
(define (assigned-lexical? sym) (define (lookup-var sym)
(let ((v (vhash-assq sym store))) (let ((v (vhash-assq sym store)))
(and v (var-set? (cdr v))))) (if v (cdr v) (error "unbound var" sym (vlist->list store)))))
(define (fresh-gensyms vars)
(map (lambda (var)
(let ((new (gensym (string-append (symbol->string (var-name var))
" "))))
(set! store (vhash-consq new var store))
new))
vars))
(define (assigned-lexical? sym)
(var-set? (lookup-var sym)))
(define (lexical-refcount sym) (define (lexical-refcount sym)
(let ((v (vhash-assq sym store))) (var-refcount (lookup-var sym)))
(if v (var-refcount (cdr v)) 0)))
;; ORIG has been alpha-renamed to NEW. Analyze NEW and record a link ;; ORIG has been alpha-renamed to NEW. Analyze NEW and record a link
;; from it to ORIG. ;; from it to ORIG.
;; ;;
(define (record-source-expression! orig new) (define (record-source-expression! orig new)
(set! store (vhash-consq new (set! store (vhash-consq new (source-expression orig) store))
(source-expression orig)
(build-var-table new store)))
new) new)
;; Find the source expression corresponding to NEW. Used to detect ;; Find the source expression corresponding to NEW. Used to detect
@ -502,10 +401,12 @@ top-level bindings from ENV and return the resulting expression."
(let ((x (vhash-assq new store))) (let ((x (vhash-assq new store)))
(if x (cdr x) new))) (if x (cdr x) new)))
(define residual-lexical-references (make-hash-table)) (define* (residualize-lexical op #:optional ctx val)
(log 'residualize op)
(define (record-residual-lexical-reference! sym) (set-operand-residualize?! op #t)
(hashq-set! residual-lexical-references sym #t)) (if (eq? ctx 'value)
(set-operand-residual-value! op val))
(make-lexical-ref #f (var-name (operand-var op)) (operand-sym op)))
(define (apply-primitive name args) (define (apply-primitive name args)
;; todo: further optimize commutative primitives ;; todo: further optimize commutative primitives
@ -638,33 +539,81 @@ top-level bindings from ENV and return the resulting expression."
(and (loop tag) (loop body) (loop handler))) (and (loop tag) (loop body) (loop handler)))
(_ #f)))) (_ #f))))
(define (prune-bindings names syms vals body for-effect (define (prune-bindings ops in-order? body counter ctx build-result)
build-result) ;; This helper handles both `let' and `letrec'/`fix'. In the latter
(let lp ((names names) (syms syms) (vals vals) ;; cases we need to make sure that if referenced binding A needs
(names* '()) (syms* '()) (vals* '()) ;; as-yet-unreferenced binding B, that B is processed for value.
(effects '())) ;; Likewise if C, when processed for effect, needs otherwise
(match (list names syms vals) ;; unreferenced D, then D needs to be processed for value too.
((() () ()) ;;
(let ((body (if (null? effects) (define (referenced? op)
body ;; When we visit lambdas in operator context, we just copy them,
(make-sequence #f (reverse (cons body effects)))))) ;; as we will process their body later. However this does have
(if (null? names*) ;; the problem that any free var referenced by the lambda is not
;; marked as needing residualization. Here we hack around this
;; and treat all bindings as referenced if we are in operator
;; context.
(or (eq? ctx 'operator) (operand-residualize? op)))
;; values := (op ...)
;; effects := (op ...)
(define (residualize values effects)
;; Note, values and effects are reversed.
(cond
(in-order?
(let ((values (filter operand-residual-value ops)))
(if (null? values)
body body
(build-result (reverse names*) (reverse syms*) (build-result (map (compose var-name operand-var) values)
(reverse vals*) body)))) (map operand-sym values)
(((name . names) (sym . syms) (val . vals)) (map operand-residual-value values)
(if (hashq-ref residual-lexical-references sym) body))))
(lp names syms vals (else
(cons name names*) (cons sym syms*) (cons val vals*) (let ((body
effects) (if (null? effects)
(let ((effect (for-effect val))) body
(lp names syms vals (let ((effect-vals (map operand-residual-value effects)))
names* syms* vals* (make-sequence #f (reverse (cons body effect-vals)))))))
(if (void? effect) (if (null? values)
(begin body
(log 'prune sym) (let ((values (reverse values)))
effects) (build-result (map (compose var-name operand-var) values)
(cons effect effects))))))))) (map operand-sym values)
(map operand-residual-value values)
body)))))))
;; old := (bool ...)
;; values := (op ...)
;; effects := ((op . value) ...)
(let prune ((old (map referenced? ops)) (values '()) (effects '()))
(let lp ((ops* ops) (values values) (effects effects))
(cond
((null? ops*)
(let ((new (map referenced? ops)))
(if (not (equal? new old))
(prune new values '())
(residualize values
(map (lambda (op val)
(set-operand-residual-value! op val)
op)
(map car effects) (map cdr effects))))))
(else
(let ((op (car ops*)))
(cond
((memq op values)
(lp (cdr ops*) values effects))
((operand-residual-value op)
(lp (cdr ops*) (cons op values) effects))
((referenced? op)
(set-operand-residual-value! op (visit-operand op counter 'value))
(lp (cdr ops*) (cons op values) effects))
(else
(lp (cdr ops*)
values
(let ((effect (visit-operand op counter 'effect)))
(if (void? effect)
effects
(acons op effect effects))))))))))))
(define (small-expression? x limit) (define (small-expression? x limit)
(let/ec k (let/ec k
@ -680,20 +629,25 @@ top-level bindings from ENV and return the resulting expression."
0 x) 0 x)
#t)) #t))
(define (extend-env sym op env)
(vhash-consq (operand-sym op) op (vhash-consq sym op env)))
(let loop ((exp exp) (let loop ((exp exp)
(env vlist-null) ; static environment (env vlist-null) ; vhash of gensym -> <operand>
(counter #f) ; inlined call stack (counter #f) ; inlined call stack
(ctx 'value)) ; effect, value, test, operator, or operand (ctx 'value)) ; effect, value, test, operator, or call
(define (lookup var) (define (lookup var)
(and=> (vhash-assq var env) cdr)) (cond
((vhash-assq var env) => cdr)
(else (error "unbound var" var))))
(define (visit exp ctx) (define (visit exp ctx)
(loop exp env counter ctx)) (loop exp env counter ctx))
(define (for-value exp) (visit exp 'value)) (define (for-value exp) (visit exp 'value))
(define (for-operand exp) (visit exp 'operand))
(define (for-test exp) (visit exp 'test)) (define (for-test exp) (visit exp 'test))
(define (for-effect exp) (visit exp 'effect)) (define (for-effect exp) (visit exp 'effect))
(define (for-call exp) (visit exp 'call))
(define (for-tail exp) (visit exp ctx)) (define (for-tail exp) (visit exp ctx))
(if counter (if counter
@ -712,102 +666,117 @@ top-level bindings from ENV and return the resulting expression."
((test) (make-const #f #t)) ((test) (make-const #f #t))
(else exp))) (else exp)))
(($ <lexical-ref> _ _ gensym) (($ <lexical-ref> _ _ gensym)
(case ctx (log 'begin-copy gensym)
((effect) (make-void #f)) (let ((op (lookup gensym)))
(else (cond
(log 'begin-copy gensym) ((eq? ctx 'effect)
(let ((val (lookup gensym))) (log 'lexical-for-effect gensym)
(cond (make-void #f))
((or (not val) ((eq? ctx 'call)
(assigned-lexical? gensym) ;; Don't propagate copies if we are residualizing a call.
(not (constant-expression? val))) (log 'residualize-lexical-call gensym op)
;; Don't copy-propagate through assigned variables, (residualize-lexical op))
;; and don't reorder effects. ((var-set? (operand-var op))
(log 'unbound-or-not-constant gensym val) ;; Assigned lexicals don't copy-propagate.
(record-residual-lexical-reference! gensym) (log 'assigned-var gensym op)
exp) (residualize-lexical op))
((lexical-ref? val) ((not (operand-copyable? op))
(for-tail val)) ;; We already know that this operand is not copyable.
((or (const? val) (log 'not-copyable gensym op)
(void? val) (residualize-lexical op))
(primitive-ref? val)) ((and=> (operand-constant-value op)
;; Always propagate simple values that cannot lead to (lambda (x) (or (const? x) (void? x) (primitive-ref? x))))
;; code bloat. ;; A cache hit.
(log 'copy-simple gensym val) (let ((val (operand-constant-value op)))
(for-tail val)) (log 'memoized-constant gensym val)
((= 1 (lexical-refcount gensym)) (for-tail val)))
;; Always propagate values referenced only once. ((visit-operand op counter ctx recursive-effort-limit operand-size-limit)
;; There is no need to rename the bindings, as they =>
;; are only being moved, not copied. However in ;; If we end up deciding to residualize this value instead of
;; operator context we do rename it, as that ;; copying it, save that residualized value.
;; effectively clears out the residualized-lexical (lambda (val)
;; flags that may have been set when this value was (cond
;; visited previously as an operand. ((not (constant-expression? val))
(log 'copy-single gensym val) (log 'not-constant gensym op)
(case ctx ;; At this point, ctx is operator, test, or value. A
((test) (for-test val)) ;; value that is non-constant in one context will be
((operator) (record-source-expression! val (alpha-rename val))) ;; non-constant in the others, so it's safe to record
(else val))) ;; that here, and avoid future visits.
;; FIXME: do demand-driven size accounting rather than (set-operand-copyable?! op #f)
;; these heuristics. (residualize-lexical op ctx val))
((eq? ctx 'operator) ((or (const? val)
;; A pure expression in the operator position. Inline (void? val)
;; if it's a lambda that's small enough. (primitive-ref? val))
(if (and (lambda? val) ;; Always propagate simple values that cannot lead to
(small-expression? val operator-size-limit)) ;; code bloat.
(begin (log 'copy-simple gensym val)
(log 'copy-operator gensym val) ;; It could be this constant is the result of folding.
(record-source-expression! val (alpha-rename val))) ;; If that is the case, cache it. This helps loop
(begin ;; unrolling get farther.
(log 'too-big-for-operator gensym val) (if (eq? ctx 'value)
(record-residual-lexical-reference! gensym) (begin
exp))) (log 'memoize-constant gensym val)
((eq? ctx 'operand) (set-operand-constant-value! op val)))
;; A pure expression in the operand position. Inline val)
;; if it's small enough. ((= 1 (var-refcount (operand-var op)))
(if (small-expression? val operand-size-limit) ;; Always propagate values referenced only once.
(begin (log 'copy-single gensym val)
(log 'copy-operand gensym val) val)
(record-source-expression! val (alpha-rename val))) ;; FIXME: do demand-driven size accounting rather than
(begin ;; these heuristics.
(log 'too-big-for-operand gensym val) ((eq? ctx 'operator)
(record-residual-lexical-reference! gensym) ;; A pure expression in the operator position. Inline
exp))) ;; if it's a lambda that's small enough.
(else (if (and (lambda? val)
;; A pure expression, processed for value. Don't (small-expression? val operator-size-limit))
;; inline lambdas, because they will probably won't (begin
;; fold because we don't know the operator. (log 'copy-operator gensym val)
(if (and (small-expression? val value-size-limit) val)
(not (tree-il-any lambda? val))) (begin
(begin (log 'too-big-for-operator gensym val)
(log 'copy-value gensym val) (residualize-lexical op ctx val))))
(record-source-expression! val (alpha-rename val))) (else
(begin ;; A pure expression, processed for call or for value.
(log 'too-big-or-has-lambda gensym val) ;; Don't inline lambdas, because they will probably won't
(record-residual-lexical-reference! gensym) ;; fold because we don't know the operator.
exp)))))))) (if (and (small-expression? val value-size-limit)
(not (tree-il-any lambda? val)))
(begin
(log 'copy-value gensym val)
val)
(begin
(log 'too-big-or-has-lambda gensym val)
(residualize-lexical op ctx val)))))))
(else
;; Visit failed. Either the operand isn't bound, as in
;; lambda formal parameters, or the copy was aborted.
(log 'unbound-or-aborted gensym op)
(residualize-lexical op)))))
(($ <lexical-set> src name gensym exp) (($ <lexical-set> src name gensym exp)
(if (zero? (lexical-refcount gensym)) (let ((op (lookup gensym)))
(let ((exp (for-effect exp))) (if (zero? (var-refcount (operand-var op)))
(if (void? exp) (let ((exp (for-effect exp)))
exp (if (void? exp)
(make-sequence src (list exp (make-void #f))))) exp
(begin (make-sequence src (list exp (make-void #f)))))
(record-residual-lexical-reference! gensym) (begin
(make-lexical-set src name gensym (for-value exp))))) (set-operand-residualize?! op #t)
(make-lexical-set src name (operand-sym op) (for-value exp))))))
(($ <let> src names gensyms vals body) (($ <let> src names gensyms vals body)
(let* ((vals (map for-operand vals)) (let* ((vars (map lookup-var gensyms))
(body (loop body (new (fresh-gensyms vars))
(fold vhash-consq env gensyms vals) (ops (make-bound-operands vars new vals
counter (lambda (exp counter ctx)
ctx))) (loop exp env counter ctx))))
(env (fold extend-env env gensyms ops))
(body (loop body env counter ctx)))
(cond (cond
((const? body) ((const? body)
(for-tail (make-sequence src (append vals (list body))))) (for-tail (make-sequence src (append vals (list body)))))
((and (lexical-ref? body) ((and (lexical-ref? body)
(memq (lexical-ref-gensym body) gensyms)) (memq (lexical-ref-gensym body) new))
(let ((sym (lexical-ref-gensym body)) (let ((sym (lexical-ref-gensym body))
(pairs (map cons gensyms vals))) (pairs (map cons new vals)))
;; (let ((x foo) (y bar) ...) x) => (begin bar ... foo) ;; (let ((x foo) (y bar) ...) x) => (begin bar ... foo)
(for-tail (for-tail
(make-sequence (make-sequence
@ -817,35 +786,39 @@ top-level bindings from ENV and return the resulting expression."
(else (else
;; Only include bindings for which lexical references ;; Only include bindings for which lexical references
;; have been residualized. ;; have been residualized.
(prune-bindings names gensyms vals body for-effect (prune-bindings ops #f body counter ctx
(lambda (names gensyms vals body) (lambda (names gensyms vals body)
(if (null? names) (error "what!" names)) (if (null? names) (error "what!" names))
(make-let src names gensyms vals body))))))) (make-let src names gensyms vals body)))))))
(($ <letrec> src in-order? names gensyms vals body) (($ <letrec> src in-order? names gensyms vals body)
;; Things could be done more precisely when IN-ORDER? but ;; Note the difference from the `let' case: here we use letrec*
;; it's OK not to do it---at worst we lost an optimization ;; so that the `visit' procedure for the new operands closes over
;; opportunity. ;; an environment that includes the operands.
(let* ((vals (map for-operand vals)) (letrec* ((visit (lambda (exp counter ctx)
(body (loop body (loop exp env* counter ctx)))
(fold vhash-consq env gensyms vals) (vars (map lookup-var gensyms))
counter (new (fresh-gensyms vars))
ctx))) (ops (make-bound-operands vars new vals visit))
(if (and (const? body) (env* (fold extend-env env gensyms ops))
(body* (visit body counter ctx)))
(if (and (const? body*)
(every constant-expression? vals)) (every constant-expression? vals))
body body*
(prune-bindings names gensyms vals body for-effect (prune-bindings ops in-order? body* counter ctx
(lambda (names gensyms vals body) (lambda (names gensyms vals body)
(make-letrec src in-order? (make-letrec src in-order?
names gensyms vals body)))))) names gensyms vals body))))))
(($ <fix> src names gensyms vals body) (($ <fix> src names gensyms vals body)
(let* ((vals (map for-operand vals)) (letrec* ((visit (lambda (exp counter ctx)
(body (loop body (loop exp env* counter ctx)))
(fold vhash-consq env gensyms vals) (vars (map lookup-var gensyms))
counter (new (fresh-gensyms vars))
ctx))) (ops (make-bound-operands vars new vals visit))
(if (const? body) (env* (fold extend-env env gensyms ops))
body (body* (visit body counter ctx)))
(prune-bindings names gensyms vals body for-effect (if (const? body*)
body*
(prune-bindings ops #f body* counter ctx
(lambda (names gensyms vals body) (lambda (names gensyms vals body)
(make-fix src names gensyms vals body)))))) (make-fix src names gensyms vals body))))))
(($ <let-values> lv-src producer consumer) (($ <let-values> lv-src producer consumer)
@ -874,7 +847,10 @@ top-level bindings from ENV and return the resulting expression."
(($ <toplevel-ref> src (? effect-free-primitive? name)) (($ <toplevel-ref> src (? effect-free-primitive? name))
(if (local-toplevel? name) (if (local-toplevel? name)
exp exp
(resolve-primitives! exp cenv))) (let ((exp (resolve-primitives! exp cenv)))
(if (primitive-ref? exp)
(for-tail exp)
exp))))
(($ <toplevel-ref>) (($ <toplevel-ref>)
;; todo: open private local bindings. ;; todo: open private local bindings.
exp) exp)
@ -922,71 +898,65 @@ top-level bindings from ENV and return the resulting expression."
(($ <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 counter 'operator))) (let ((proc (visit orig-proc 'operator)))
(match proc (match proc
(($ <primitive-ref> _ (? constructor-primitive? name)) (($ <primitive-ref> _ (? constructor-primitive? name))
(case ctx (cond
((effect test) ((and (memq ctx '(effect test))
(let ((res (if (eq? ctx 'effect) (match (cons name orig-args)
(make-void #f) ((or ('cons _ _)
(make-const #f #t)))) ('list . _)
(match (for-value exp) ('vector . _)
(($ <application> _ ($ <primitive-ref> _ 'cons) (x xs)) ('make-prompt-tag)
(for-tail ('make-prompt-tag ($ <const> _ (? string?))))
(make-sequence src (list x xs res)))) #t)
(($ <application> _ ($ <primitive-ref> _ 'list) elts) (_ #f)))
(for-tail ;; Some expressions can be folded without visiting the
(make-sequence src (append elts (list res))))) ;; arguments for value.
(($ <application> _ ($ <primitive-ref> _ 'vector) elts) (let ((res (if (eq? ctx 'effect)
(for-tail (make-void #f)
(make-sequence src (append elts (list res))))) (make-const #f #t))))
(($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag) ()) (for-tail (make-sequence src (append orig-args (list res))))))
res) (else
(($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag) (match (cons name (map for-value orig-args))
(($ <const> _ (? string?)))) (('cons head tail)
res) (match tail
(exp exp)))) (($ <const> src ())
(else (make-application src (make-primitive-ref #f 'list)
(match (cons name (map for-value orig-args)) (list head)))
(('cons head tail) (($ <application> src ($ <primitive-ref> _ 'list) elts)
(match tail (make-application src (make-primitive-ref #f 'list)
(($ <const> src ()) (cons head elts)))
(make-application src (make-primitive-ref #f 'list) (_ (make-application src proc
(list head))) (list head tail)))))
(($ <application> src ($ <primitive-ref> _ 'list) elts)
(make-application src (make-primitive-ref #f 'list)
(cons head elts)))
(_ (make-application src proc
(list head tail)))))
;; FIXME: these for-tail recursions could take ;; FIXME: these for-tail recursions could take
;; place outside an effort counter. ;; place outside an effort counter.
(('car ($ <application> src ($ <primitive-ref> _ 'cons) (head tail))) (('car ($ <application> src ($ <primitive-ref> _ 'cons) (head tail)))
(for-tail (make-sequence src (list tail head)))) (for-tail (make-sequence src (list tail head))))
(('cdr ($ <application> src ($ <primitive-ref> _ 'cons) (head tail))) (('cdr ($ <application> src ($ <primitive-ref> _ 'cons) (head tail)))
(for-tail (make-sequence src (list head tail)))) (for-tail (make-sequence src (list head tail))))
(('car ($ <application> src ($ <primitive-ref> _ 'list) (head . tail))) (('car ($ <application> src ($ <primitive-ref> _ 'list) (head . tail)))
(for-tail (make-sequence src (append tail (list head))))) (for-tail (make-sequence src (append tail (list head)))))
(('cdr ($ <application> src ($ <primitive-ref> _ 'list) (head . tail))) (('cdr ($ <application> src ($ <primitive-ref> _ 'list) (head . tail)))
(for-tail (make-sequence (for-tail (make-sequence
src src
(list head (list head
(make-application (make-application
src (make-primitive-ref #f 'list) tail))))) src (make-primitive-ref #f 'list) tail)))))
(('car ($ <const> src (head . tail))) (('car ($ <const> src (head . tail)))
(for-tail (make-const src head))) (for-tail (make-const src head)))
(('cdr ($ <const> src (head . tail))) (('cdr ($ <const> src (head . tail)))
(for-tail (make-const src tail))) (for-tail (make-const src tail)))
((_ . args) ((_ . args)
(make-application src proc args)))))) (make-application src proc args))))))
(($ <primitive-ref> _ (? effect-free-primitive? name)) (($ <primitive-ref> _ (? effect-free-primitive? name))
(let ((args (map for-value orig-args))) (let ((args (map for-value orig-args)))
(if (every const? args) ; only simple constants (if (every const? args) ; only simple constants
(let-values (((success? values) (let-values (((success? values)
(apply-primitive name (apply-primitive name (map const-exp args))))
(map const-exp args))))
(log 'fold success? values exp) (log 'fold success? values exp)
(if success? (if success?
(case ctx (case ctx
@ -1017,13 +987,28 @@ top-level bindings from ENV and return the resulting expression."
(cond (cond
((or (< nargs nreq) (> nargs (+ nreq nopt))) ((or (< nargs nreq) (> nargs (+ nreq nopt)))
;; An error, or effecting arguments. ;; An error, or effecting arguments.
(make-application src (for-value orig-proc) (make-application src (for-call orig-proc)
(map for-value orig-args))) (map for-value orig-args)))
((or (and=> (find-counter key counter) counter-recursive?) ((or (and=> (find-counter key counter) counter-recursive?)
(lambda? orig-proc)) (lambda? orig-proc))
;; A recursive call, or a lambda in the operator ;; A recursive call, or a lambda in the operator
;; position of the source expression. Process again in ;; position of the source expression. Process again in
;; tail context. ;; tail context.
;;
;; In the recursive case, mark intervening counters as
;; recursive, so we can handle a toplevel counter that
;; recurses mutually with some other procedure.
;; Otherwise, the next time we see the other procedure,
;; the effort limit would be clamped to 100.
;;
(let ((found (find-counter key counter)))
(if (and found (counter-recursive? found))
(let lp ((counter counter))
(if (not (eq? counter found))
(begin
(set-counter-recursive?! counter #t)
(lp (counter-prev counter)))))))
(log 'inline-recurse key) (log 'inline-recurse key)
(loop (make-let src (append req (or opt '())) (loop (make-let src (append req (or opt '()))
gensyms gensyms
@ -1040,8 +1025,7 @@ top-level bindings from ENV and return the resulting expression."
(let/ec k (let/ec k
(define (abort) (define (abort)
(log 'inline-abort exp) (log 'inline-abort exp)
(k (make-application src (k (make-application src (for-call orig-proc)
(for-value orig-proc)
(map for-value orig-args)))) (map for-value orig-args))))
(define new-counter (define new-counter
(cond (cond
@ -1078,21 +1062,32 @@ top-level bindings from ENV and return the resulting expression."
(log 'inline-end result exp) (log 'inline-end result exp)
result))))) result)))))
(_ (_
(make-application src proc (make-application src (for-call orig-proc)
(map for-value orig-args)))))) (map for-value orig-args))))))
(($ <lambda> src meta body) (($ <lambda> src meta body)
(case ctx (case ctx
((effect) (make-void #f)) ((effect) (make-void #f))
((test) (make-const #f #t)) ((test) (make-const #f #t))
((operator) exp) ((operator) exp)
(else (else (record-source-expression!
(make-lambda src meta (for-value body))))) exp
(make-lambda src meta (for-tail 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 (let* ((vars (map lookup-var gensyms))
(map for-value inits) (new (fresh-gensyms vars))
gensyms (env (fold extend-env env gensyms
(for-tail body) (make-unbound-operands vars new)))
(and alt (for-tail alt)))) (new-sym (lambda (old)
(operand-sym (cdr (vhash-assq old env))))))
(make-lambda-case src req opt rest
(match kw
((aok? (kw name old) ...)
(cons aok? (map list kw name (map new-sym old))))
(_ #f))
(map (cut loop <> env counter 'value) inits)
new
(loop body env counter ctx)
(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
@ -1118,7 +1113,8 @@ top-level bindings from ENV and return the resulting expression."
;; Only fetch definitions with single uses. ;; Only fetch definitions with single uses.
(= (lexical-refcount (lexical-ref-gensym x)) 1) (= (lexical-refcount (lexical-ref-gensym x)) 1)
(lookup (lexical-ref-gensym x))) (lookup (lexical-ref-gensym x)))
=> singly-used-definition) => (lambda (x)
(singly-used-definition (visit-operand x counter 'value 10 10))))
(else x))) (else x)))
(match (singly-used-definition tag) (match (singly-used-definition tag)
(($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag) (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag)

156
test-suite/tests/tree-il.test
View file

@ -716,17 +716,16 @@
(if (zero? i) (if (zero? i)
r r
(loop (1- i) (cons (cons i i) r)))) (loop (1- i) (cons (cons i i) r))))
(letrec (loop) (_) (_) (let (r) (_)
(let (r) (_) ((apply (primitive list)
((apply (primitive list) (apply (primitive cons) (const 3) (const 3))))
(apply (primitive cons) (const 3) (const 3)))) (let (r) (_)
(let (r) (_) ((apply (primitive cons)
((apply (primitive cons) (apply (primitive cons) (const 2) (const 2))
(apply (primitive cons) (const 2) (const 2)) (lexical r _)))
(lexical r _))) (apply (primitive cons)
(apply (primitive cons) (apply (primitive cons) (const 1) (const 1))
(apply (primitive cons) (const 1) (const 1)) (lexical r _)))))
(lexical r _))))))
;; See above. ;; See above.
(pass-if-peval (pass-if-peval
@ -735,23 +734,22 @@
(if (<= i 0) (if (<= i 0)
(car r) (car r)
(loop (1- i) (cons i r)))) (loop (1- i) (cons i r))))
(letrec (loop) (_) (_) (let (r) (_)
(let (r) (_) ((apply (primitive list) (const 4)))
((apply (primitive list) (const 4))) (let (r) (_)
(let (r) (_) ((apply (primitive cons)
((apply (primitive cons) (const 3)
(const 3) (lexical r _)))
(lexical r _))) (let (r) (_)
(let (r) (_) ((apply (primitive cons)
((apply (primitive cons) (const 2)
(const 2) (lexical r _)))
(lexical r _))) (let (r) (_)
(let (r) (_) ((apply (primitive cons)
((apply (primitive cons) (const 1)
(const 1) (lexical r _)))
(lexical r _))) (apply (primitive car)
(apply (primitive car) (lexical r _)))))))
(lexical r _))))))))
;; Static sums. ;; Static sums.
(pass-if-peval (pass-if-peval
@ -1049,13 +1047,30 @@
(not (eq? gensym1 gensym2)))) (not (eq? gensym1 gensym2))))
(_ #f))) (_ #f)))
(pass-if-peval
;; Unused letrec bindings are pruned.
(letrec ((a (lambda () (b)))
(b (lambda () (a)))
(c (lambda (x) x)))
(c 10))
(const 10))
(pass-if-peval
;; Unused letrec bindings are pruned.
(letrec ((a (foo!))
(b (lambda () (a)))
(c (lambda (x) x)))
(c 10))
(begin (apply (toplevel foo!))
(const 10)))
(pass-if-peval (pass-if-peval
;; Higher order, mutually recursive procedures. ;; Higher order, mutually recursive procedures.
(letrec ((even? (lambda (x) (letrec ((even? (lambda (x)
(or (= 0 x) (or (= 0 x)
(odd? (- x 1))))) (odd? (- x 1)))))
(odd? (lambda (x) (odd? (lambda (x)
(not (even? (- x 1)))))) (not (even? x)))))
(and (even? 4) (odd? 7))) (and (even? 4) (odd? 7)))
(const #t)) (const #t))
@ -1203,8 +1218,7 @@
(loop x (1- y)) (loop x (1- y))
(foo x y)))) (foo x y))))
(let (x) (_) ((apply (toplevel top))) (let (x) (_) ((apply (toplevel top)))
(letrec (loop) (_) (_) (apply (toplevel foo) (lexical x _) (const 0))))
(apply (toplevel foo) (lexical x _) (const 0)))))
(pass-if-peval (pass-if-peval
;; Inlining aborted when residual code contains recursive calls. ;; Inlining aborted when residual code contains recursive calls.
@ -1241,6 +1255,86 @@
(letrec (loop) (_) ((lambda . _)) (letrec (loop) (_) ((lambda . _))
(apply (lexical loop _) (const 0)))) (apply (lexical loop _) (const 0))))
(pass-if-peval
;; This test checks that the `start' binding is indeed residualized.
;; See the `referenced?' procedure in peval's `prune-bindings'.
(let ((pos 0))
(set! pos 1) ;; Cause references to `pos' to residualize.
(let ((here (let ((start pos)) (lambda () start))))
(here)))
(let (pos) (_) ((const 0))
(begin
(set! (lexical pos _) (const 1))
(let (here) (_) (_)
(apply (lexical here _))))))
(pass-if-peval
;; FIXME: should this one residualize the binding?
(letrec ((a a))
1)
(const 1))
(pass-if-peval
;; This is a fun one for peval to handle.
(letrec ((a a))
a)
(letrec (a) (_) ((lexical a _))
(lexical a _)))
(pass-if-peval
;; Another interesting recursive case.
(letrec ((a b) (b a))
a)
(letrec (a) (_) ((lexical a _))
(lexical a _)))
(pass-if-peval
;; Another pruning case, that `a' is residualized.
(letrec ((a (lambda () (a)))
(b (lambda () (a)))
(c (lambda (x) x)))
(let ((d (foo b)))
(c d)))
;; "b c a" is the current order that we get with unordered letrec,
;; but it's not important to this test, so if it changes, just adapt
;; the test.
(letrec (b c a) (_ _ _)
((lambda _
(lambda-case
((() #f #f #f () ())
(apply (lexical a _)))))
(lambda _
(lambda-case
(((x) #f #f #f () (_))
(lexical x _))))
(lambda _
(lambda-case
((() #f #f #f () ())
(apply (lexical a _))))))
(let (d)
(_)
((apply (toplevel foo) (lexical b _)))
(apply (lexical c _)
(lexical d _)))))
(pass-if-peval
;; In this case, we can prune the bindings. `a' ends up being copied
;; because it is only referenced once in the source program. Oh
;; well.
(letrec* ((a (lambda (x) (top x)))
(b (lambda () a)))
(foo (b) (b)))
(apply (toplevel foo)
(lambda _
(lambda-case
(((x) #f #f #f () (_))
(apply (toplevel top) (lexical x _)))))
(lambda _
(lambda-case
(((x) #f #f #f () (_))
(apply (toplevel top) (lexical x _)))))))
(pass-if-peval (pass-if-peval
;; Constant folding: cons ;; Constant folding: cons
(begin (cons 1 2) #f) (begin (cons 1 2) #f)