summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2012-04-23 17:56:28 +0200
committerAndy Wingo <wingo@pobox.com>2012-04-23 21:52:25 +0200
commit985702f7131e11c7c13aa75db19d10525c34fecd (patch)
treed98a87f5b2355cf5be7eb1541c2a60a9836339aa
parentf6a554a6aa0832432cec9c9c18b99fad56008997 (diff)
downloadguile-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.scm66
-rw-r--r--test-suite/tests/peval.test16
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 _)))))