diff options
author | Andy Wingo <wingo@pobox.com> | 2012-04-23 17:56:28 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2012-04-23 21:52:25 +0200 |
commit | 985702f7131e11c7c13aa75db19d10525c34fecd (patch) | |
tree | d98a87f5b2355cf5be7eb1541c2a60a9836339aa | |
parent | f6a554a6aa0832432cec9c9c18b99fad56008997 (diff) | |
download | guile-985702f7131e11c7c13aa75db19d10525c34fecd.tar.gz |
avoid emitting degenerate aliases in peval
* module/language/tree-il/peval.scm (<operand>, make-operand)
(make-bound-operands, peval): Avoid emitting needless aliases in
degenerate cases of let.
(visit-operand): If we visit an operand with a fresh counter and have
to abort, record that fact.
* test-suite/tests/peval.test ("partial evaluation"): Add a test.
-rw-r--r-- | module/language/tree-il/peval.scm | 66 | ||||
-rw-r--r-- | test-suite/tests/peval.test | 16 |
2 files changed, 71 insertions, 11 deletions
diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index f10f24ed2..3b22b68cb 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -289,7 +289,7 @@ ;; (define-record-type <operand> (%make-operand var sym visit source visit-count residualize? - copyable? residual-value constant-value) + copyable? residual-value constant-value alias-value) operand? (var operand-var) (sym operand-sym) @@ -299,19 +299,27 @@ (residualize? operand-residualize? set-operand-residualize?!) (copyable? operand-copyable? set-operand-copyable?!) (residual-value operand-residual-value %set-operand-residual-value!) - (constant-value operand-constant-value set-operand-constant-value!)) + (constant-value operand-constant-value set-operand-constant-value!) + (alias-value operand-alias-value set-operand-alias-value!)) -(define* (make-operand var sym #:optional source visit) +(define* (make-operand var sym #:optional source visit alias) ;; Bind SYM to VAR, with value SOURCE. Unassigned bound operands are ;; considered copyable until we prove otherwise. If we have a source ;; expression, truncate it to one value. Copy propagation does not ;; work on multiply-valued expressions. (let ((source (and=> source truncate-values))) (%make-operand var sym visit source 0 #f - (and source (not (var-set? var))) #f #f))) - -(define (make-bound-operands vars syms sources visit) - (map (lambda (x y z) (make-operand x y z visit)) vars syms sources)) + (and source (not (var-set? var))) #f #f + (and (not (var-set? var)) alias)))) + +(define* (make-bound-operands vars syms sources visit #:optional aliases) + (if aliases + (map (lambda (name sym source alias) + (make-operand name sym source visit alias)) + vars syms sources aliases) + (map (lambda (name sym source) + (make-operand name sym source visit #f)) + vars syms sources))) (define (make-unbound-operands vars syms) (map make-operand vars syms)) @@ -345,7 +353,12 @@ (if (or counter (and (not effort-limit) (not size-limit))) ((%operand-visit op) (operand-source op) counter ctx) (let/ec k - (define (abort) (k #f)) + (define (abort) + ;; If we abort when visiting the value in a + ;; fresh context, we won't succeed in any future + ;; attempt, so don't try to copy it again. + (set-operand-copyable?! op #f) + (k #f)) ((%operand-visit op) (operand-source op) (make-top-counter effort-limit size-limit abort op) @@ -712,6 +725,11 @@ top-level bindings from ENV and return the resulting expression." ((eq? ctx 'effect) (log 'lexical-for-effect gensym) (make-void #f)) + ((operand-alias-value op) + ;; This is an unassigned operand that simply aliases some + ;; other operand. Recurse to avoid residualizing the leaf + ;; binding. + => for-tail) ((eq? ctx 'call) ;; Don't propagate copies if we are residualizing a call. (log 'residualize-lexical-call gensym op) @@ -804,11 +822,37 @@ top-level bindings from ENV and return the resulting expression." (set-operand-residualize?! op #t) (make-lexical-set src name (operand-sym op) (for-value exp)))))) (($ <let> src names gensyms vals body) + (define (compute-alias exp) + ;; It's very common for macros to introduce something like: + ;; + ;; ((lambda (x y) ...) x-exp y-exp) + ;; + ;; In that case you might end up trying to inline something like: + ;; + ;; (let ((x x-exp) (y y-exp)) ...) + ;; + ;; But if x-exp is itself a lexical-ref that aliases some much + ;; larger expression, perhaps it will fail to inline due to + ;; size. However we don't want to introduce a useless alias + ;; (in this case, x). So if the RHS of a let expression is a + ;; lexical-ref, we record that expression. If we end up having + ;; to residualize X, then instead we residualize X-EXP, as long + ;; as it isn't assigned. + ;; + (match exp + (($ <lexical-ref> _ _ sym) + (let ((op (lookup sym))) + (and (not (var-set? (operand-var op))) + (or (operand-alias-value op) + exp)))) + (_ #f))) + (let* ((vars (map lookup-var gensyms)) (new (fresh-gensyms vars)) (ops (make-bound-operands vars new vals (lambda (exp counter ctx) - (loop exp env counter ctx)))) + (loop exp env counter ctx)) + (map compute-alias vals))) (env (fold extend-env env gensyms ops)) (body (loop body env counter ctx))) (cond @@ -834,7 +878,9 @@ top-level bindings from ENV and return the resulting expression." (($ <letrec> src in-order? names gensyms vals body) ;; Note the difference from the `let' case: here we use letrec* ;; so that the `visit' procedure for the new operands closes over - ;; an environment that includes the operands. + ;; an environment that includes the operands. Also we don't try + ;; to elide aliases, because we can't sensibly reduce something + ;; like (letrec ((a b) (b a)) a). (letrec* ((visit (lambda (exp counter ctx) (loop exp env* counter ctx))) (vars (map lookup-var gensyms)) diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test index 5305dea72..987b06cca 100644 --- a/test-suite/tests/peval.test +++ b/test-suite/tests/peval.test @@ -985,4 +985,18 @@ (pass-if-peval resolve-primitives (car '(1 2)) - (const 1))) + (const 1)) + + ;; If we bail out when inlining an identifier because it's too big, + ;; but the identifier simply aliases some other identifier, then avoid + ;; residualizing a reference to the leaf identifier. The bailout is + ;; driven by the recursive-effort-limit, which is currently 100. We + ;; make sure to trip it with this recursive sum thing. + (pass-if-peval resolve-primitives + (let ((x (let sum ((n 0) (out 0)) + (if (< n 10000) + (sum (1+ n) (+ out n)) + out)))) + ((lambda (y) (list y)) x)) + (let (x) (_) (_) + (apply (primitive list) (lexical x _))))) |