[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.2-121-g02ebe
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.2-121-g02ebea5 |
|
Date: |
Mon, 26 Sep 2011 08:46:09 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=02ebea537fa805c615df44c4228db6a44d74c4b3
The branch, stable-2.0 has been updated
via 02ebea537fa805c615df44c4228db6a44d74c4b3 (commit)
via cf82943f9f075248d803b31e19ddb8e933ad35ba (commit)
via b839233282686301a5ba762b2dda890b3659ce4d (commit)
via fab137869e67d2f1d76764aa8b2855c88ae95379 (commit)
via 062bf3aa443c33a2f07fe929aba03fcd44d959b1 (commit)
via 8018dfdc023fe3136e96550c9d0dcd1712759917 (commit)
via ded8ad84a781ec792c0796e82568854c5d63ea65 (commit)
via f6123e4fda470a634b6cf0510d0312d162973e75 (commit)
via e43921a982fe207c99695c6eb01abffb0c9a559b (commit)
via b8a2b628e9c663ff58d442a895c4d20541d54b1f (commit)
from 1eb4886ffa9c4c81c946af7fed8fb39020fcde12 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 02ebea537fa805c615df44c4228db6a44d74c4b3
Author: Andy Wingo <address@hidden>
Date: Fri Sep 23 12:43:04 2011 +0200
peval: simpler and more precise treatment of mutability
* module/language/tree-il/optimize.scm (peval): The old approach of
optimistically producing constants and then de-constifying them at
their uses was not only cumbersome but incorrect: it both failed to
preserve identity in some cases and failed to retain immutable
constant values. Instead, now we only produce constants if they
really are constant and immutable. The constant folder has to have a
few more algebraic cases to be as effective as it was, to destructure
(car (cons _ _)) appropriately. On the plus side, now constructors
and deconstructors can handle impure cases more generally.
* test-suite/tests/tree-il.test ("partial evaluation"): Add constructor
and destructuring tests. Adapt other tests to new expectations.
commit cf82943f9f075248d803b31e19ddb8e933ad35ba
Author: Andy Wingo <address@hidden>
Date: Sun Sep 25 02:54:34 2011 +0200
peval: add a bunch of missing maybe-unconst calls
* module/language/tree-il/optimize.scm (peval): Add missing
maybe-unconst calls. Things are getting ugly. They will get better
in the next commit though.
commit b839233282686301a5ba762b2dda890b3659ce4d
Author: Andy Wingo <address@hidden>
Date: Fri Sep 23 00:29:14 2011 +0200
peval uses effort counters, propagates lambdas more effectively
* module/language/tree-il/optimize.scm (code-contains-calls?): Remove
this helper, we will deal with recursion when it happens, not after
the fact.
(peval): Add keyword args for various size and effort limits. Instead
of keeping a call stack, keep a chain of <counter> records, each with
an abort continuation. If ever an inlining attempt is taking too
long, measured in terms of number of trips through the main loop, the
counter will abort. Add new contexts, `operator' and `operand'. They
have different default size limits. In the future we should actually
use the size counter, instead of these heuristics.
The <lexical-ref> case is smarter now, and tries to avoid propagating
too much data. Perhaps it should be dumber though, and use a
counter. That would require changes to the environment structure.
Inline <lambda> applications to <let>, so that we allow residual
lexical references to have bindings. Add a `for-operand' helper, and
use it for the RHS of `let' expressions. A `let' is an inlined
`lambda'.
`Let' and company no longer elide bindings if the result is a
constant, as the arguments could have effects. Peval will still do as
much as it can, though.
* test-suite/tests/tree-il.test ("partial evaluation"): Update the tests
for the new expectations. They are uniformly awesomer, with the
exception of two cases in which pure but not constant data is not
propagated.
commit fab137869e67d2f1d76764aa8b2855c88ae95379
Author: Andy Wingo <address@hidden>
Date: Fri Sep 23 00:21:46 2011 +0200
prune unused letrec bindings
* module/language/tree-il/optimize.scm (peval): Prune unused `letrec'
bindings.
commit 062bf3aa443c33a2f07fe929aba03fcd44d959b1
Author: Andy Wingo <address@hidden>
Date: Fri Sep 23 00:18:13 2011 +0200
more peval refactoring
* module/language/tree-il/optimize.scm (peval): Rename `var-table' to
`store', as we're going to put some more things in it. Rename
`record-lexical-bindings' to `record-source-expression', which also
takes the original, pre-renaming expression. Keep a mapping from new
expressions to original expressions, available using the
`source-expression' helper.
commit 8018dfdc023fe3136e96550c9d0dcd1712759917
Author: Andy Wingo <address@hidden>
Date: Fri Sep 23 00:12:21 2011 +0200
add helpers for effort counters
* module/language/tree-il/optimize.scm (<counter>, abort-counter)
(record-effort!, record-size!, find-counter, make-top-counter)
(make-nested-counter, make-recursive-counter): New helpers, as yet
unused, but which will implement fixed effort bounds on the inlining
algorithm.
commit ded8ad84a781ec792c0796e82568854c5d63ea65
Author: Andy Wingo <address@hidden>
Date: Fri Sep 23 00:05:27 2011 +0200
peval refactor
* module/language/tree-il/optimize.scm (peval): Add for-value, for-test,
for-effect, and for-tail helpers. Use them.
commit f6123e4fda470a634b6cf0510d0312d162973e75
Author: Andy Wingo <address@hidden>
Date: Thu Sep 22 15:56:22 2011 +0200
attempt to prune unreferenced bindings
* module/language/tree-il/optimize.scm (peval): Rename `record-lexicals'
to `record-lexical-bindings'. Record residualized lexical
references. Record lexical references in maybe-unlambda.
Unfortunately this has the disadvantage that the speculative mapping
of lambda expressions to lexical references records that reference,
even if we are not going to residualize it. After processing a `let',
prune pure unreferenced bindings. (We can do better than this in the
future: we can simply process them for effect.)
* test-suite/tests/tree-il.test (pass-if-peval): More debugging.
("partial evaluation"): Update to reflect the fact that the `y'
binding won't be emitted.
commit e43921a982fe207c99695c6eb01abffb0c9a559b
Author: Andy Wingo <address@hidden>
Date: Thu Sep 22 13:16:36 2011 +0200
peval handles lexical-set
* module/language/tree-il/optimize.scm (alpha-rename, peval): Add
support for lexical-set, while avoiding copy propagation and pruning
of assigned variables.
commit b8a2b628e9c663ff58d442a895c4d20541d54b1f
Author: Andy Wingo <address@hidden>
Date: Wed Sep 21 23:59:02 2011 +0200
peval: pre-analyze mutated or reffed-once lexicals
* module/language/tree-il/optimize.scm (<var>, build-var-table, peval):
Before going into peval, build a table indicating refcounts and a set?
flag for all lexicals. Add to the table when introducing new bindings
(via alpha-renaming).
-----------------------------------------------------------------------
Summary of changes:
module/language/tree-il/optimize.scm | 681 +++++++++++++++++++++++-----------
test-suite/tests/tree-il.test | 416 +++++++++++++--------
2 files changed, 727 insertions(+), 370 deletions(-)
diff --git a/module/language/tree-il/optimize.scm
b/module/language/tree-il/optimize.scm
index b96e801..1af55a1 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -26,6 +26,7 @@
#:use-module (ice-9 vlist)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:export (optimize!))
@@ -87,6 +88,10 @@ references to the new symbols."
(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)
@@ -171,22 +176,6 @@ references to the new symbols."
(lambda (exp res) #f)
#f exp)))
-(define (code-contains-calls? body proc lookup)
- "Return true if BODY contains calls to PROC. Use LOOKUP to look up
-lexical references."
- (tree-il-any
- (lambda (exp)
- (match exp
- (($ <application> _
- (and ref ($ <lexical-ref> _ _ gensym)) _)
- (or (equal? ref proc)
- (equal? (lookup gensym) proc)))
- (($ <application>
- (and proc* ($ <lambda>)))
- (equal? proc* proc))
- (_ #f)))
- body))
-
(define (vlist-any proc vlist)
(let ((len (vlist-length vlist)))
(let lp ((i 0))
@@ -194,7 +183,101 @@ lexical references."
(or (proc (vlist-ref vlist i))
(lp (1+ i)))))))
-(define* (peval exp #:optional (cenv (current-module)) (env vlist-null))
+(define-record-type <var>
+ (make-var name gensym refcount set?)
+ var?
+ (name var-name)
+ (gensym var-gensym)
+ (refcount var-refcount set-var-refcount!)
+ (set? var-set? set-var-set?!))
+
+(define* (build-var-table exp #:optional (table vlist-null))
+ (tree-il-fold
+ (lambda (exp res)
+ (match exp
+ (($ <lexical-ref> src name gensym)
+ (let ((var (vhash-assq gensym res)))
+ (if var
+ (begin
+ (set-var-refcount! (cdr var) (1+ (var-refcount (cdr var))))
+ res)
+ (vhash-consq gensym (make-var name gensym 1 #f) res))))
+ (_ res)))
+ (lambda (exp res)
+ (match exp
+ (($ <lexical-set> src name gensym exp)
+ (let ((var (vhash-assq gensym res)))
+ (if var
+ (begin
+ (set-var-set?! (cdr var) #t)
+ res)
+ (vhash-consq gensym (make-var name gensym 0 #t) res))))
+ (_ res)))
+ (lambda (exp res) res)
+ table exp))
+
+(define-record-type <counter>
+ (%make-counter effort size continuation recursive? data prev)
+ counter?
+ (effort effort-counter)
+ (size size-counter)
+ (continuation counter-continuation)
+ (recursive? counter-recursive?)
+ (data counter-data)
+ (prev counter-prev))
+
+(define (abort-counter c)
+ ((counter-continuation c)))
+
+(define (record-effort! c)
+ (let ((e (effort-counter c)))
+ (if (zero? (variable-ref e))
+ (abort-counter c)
+ (variable-set! e (1- (variable-ref e))))))
+
+(define (record-size! c)
+ (let ((s (size-counter c)))
+ (if (zero? (variable-ref s))
+ (abort-counter c)
+ (variable-set! s (1- (variable-ref s))))))
+
+(define (find-counter data counter)
+ (and counter
+ (if (eq? data (counter-data counter))
+ counter
+ (find-counter data (counter-prev counter)))))
+
+(define (make-top-counter effort-limit size-limit continuation data)
+ (%make-counter (make-variable effort-limit)
+ (make-variable size-limit)
+ continuation
+ #t
+ data
+ #f))
+
+(define (make-nested-counter continuation data current)
+ (%make-counter (effort-counter current)
+ (size-counter current)
+ continuation
+ #f
+ data
+ current))
+
+(define (make-recursive-counter effort-limit size-limit orig current)
+ (%make-counter (make-variable effort-limit)
+ (make-variable size-limit)
+ (counter-continuation orig)
+ #t
+ (counter-data orig)
+ current))
+
+(define* (peval exp #:optional (cenv (current-module)) (env vlist-null)
+ #:key
+ (operator-size-limit 40)
+ (operand-size-limit 20)
+ (value-size-limit 10)
+ (effort-limit 500)
+ (recursive-effort-limit 100))
"Partially evaluate EXP in compilation environment CENV, with
top-level bindings from ENV and return the resulting expression. Since
it does not handle <fix> and <let-values>, it should be called before
@@ -207,8 +290,7 @@ it does not handle <fix> and <let-values>, it should be
called before
;;
;; Unlike a full-blown partial evaluator, it does not emit definitions
;; of specialized versions of lambdas encountered on its way. Also,
- ;; it's very conservative: it bails out if `set!', `prompt', etc. are
- ;; met.
+ ;; it's not yet complete: it bails out for `prompt', etc.
(define local-toplevel-env
;; The top-level environment of the module being compiled.
@@ -228,6 +310,31 @@ it does not handle <fix> and <let-values>, it should be
called before
(define (local-toplevel? name)
(vhash-assq name local-toplevel-env))
+ (define store (build-var-table exp))
+
+ (define (assigned-lexical? sym)
+ (let ((v (vhash-assq sym store)))
+ (and v (var-set? (cdr v)))))
+
+ (define (lexical-refcount sym)
+ (let ((v (vhash-assq sym store)))
+ (if v (var-refcount (cdr v)) 0)))
+
+ (define (record-source-expression! orig new)
+ (set! store (vhash-consq new
+ (source-expression orig)
+ (build-var-table new store)))
+ new)
+
+ (define (source-expression new)
+ (let ((x (vhash-assq new store)))
+ (if x (cdr x) new)))
+
+ (define residual-lexical-references (make-hash-table))
+
+ (define (record-residual-lexical-reference! sym)
+ (hashq-set! residual-lexical-references sym #t))
+
(define (apply-primitive name args)
;; todo: further optimize commutative primitives
(catch #t
@@ -252,9 +359,10 @@ it does not handle <fix> and <let-values>, it should be
called before
($ <module-ref>)
($ <primitive-ref>)
($ <dynref>)
- ($ <toplevel-set>) ; FIXME: these set! expressions
- ($ <toplevel-define>) ; could return zero values in
- ($ <module-set>)) ; the future
+ ($ <lexical-set>) ; FIXME: these set! expressions
+ ($ <toplevel-set>) ; could return zero values in
+ ($ <toplevel-define>) ; the future
+ ($ <module-set>)) ;
(and (= (length names) 1)
(make-let src names gensyms (list exp) body)))
(($ <application> src
@@ -329,7 +437,8 @@ it does not handle <fix> and <let-values>, it should be
called before
(($ <lambda>) #t)
(($ <lambda-case> _ req opt rest kw inits _ body alternate)
(and (every loop inits) (loop body) (loop alternate)))
- (($ <lexical-ref>) #t)
+ (($ <lexical-ref> _ _ gensym)
+ (not (assigned-lexical? gensym)))
(($ <primitive-ref>) #t)
(($ <conditional> _ condition subsequent alternate)
(and (loop condition) (loop subsequent) (loop alternate)))
@@ -351,6 +460,20 @@ it does not handle <fix> and <let-values>, it should be
called before
(and (loop exp) (loop body)))
(_ #f))))
+ (define (small-expression? x limit)
+ (let/ec k
+ (tree-il-fold
+ (lambda (x res) ; leaf
+ (1+ res))
+ (lambda (x res) ; down
+ (1+ res))
+ (lambda (x res) ; up
+ (if (< res limit)
+ res
+ (k #f)))
+ 0 x)
+ #t))
+
(define (mutable? exp)
;; Return #t if EXP is a mutable object.
;; todo: add an option to assume pairs are immutable
@@ -386,49 +509,29 @@ it does not handle <fix> and <let-values>, it should be
called before
;((? bytevector?) (make-const src exp))
(_ #f))))
- (define (maybe-unconst orig new)
- ;; If NEW is a constant, change it to a non-constant if need be.
- ;; Expressions that build a mutable object, such as `(list 1 2)',
- ;; must not be replaced by a constant; this procedure "undoes" the
- ;; change from `(list 1 2)' to `'(1 2)'.
- (match new
- (($ <const> src (? mutable? value))
- (if (equal? new orig)
- new
- (or (make-value-construction src value) orig)))
- (_ new)))
-
- (define (maybe-unlambda orig new env)
- ;; If NEW is a named lambda and ORIG is what it looked like before
- ;; partial evaluation, then attempt to replace NEW with a lexical
- ;; ref, to avoid code duplication.
- (match new
- (($ <lambda> src (= (cut assq-ref <> 'name) (? symbol? name))
- ($ <lambda-case> _ req opt rest kw inits gensyms body))
- ;; Look for NEW in the current environment, starting from the
- ;; outermost frame.
- (or (vlist-any (lambda (x)
- (and (equal? (cdr x) new)
- (make-lexical-ref src name (car x))))
- env)
- new))
- (($ <lambda> src ()
- (and lc ($ <lambda-case>)))
- ;; This is an anonymous lambda that we're going to inline.
- ;; Inlining creates new variable bindings, so we need to provide
- ;; the new code with fresh names.
- (make-lambda src '() (alpha-rename lc)))
- (_ new)))
-
(catch 'match-error
(lambda ()
(let loop ((exp exp)
(env vlist-null) ; static environment
- (calls '()) ; inlined call stack
- (ctx 'value)) ; effect, value, test, or call
+ (counter #f) ; inlined call stack
+ (ctx 'value)) ; effect, value, test, operator, or
operand
(define (lookup var)
(and=> (vhash-assq var env) cdr))
+ (define (for-value exp)
+ (loop exp env counter 'value))
+ (define (for-operand exp)
+ (loop exp env counter 'operand))
+ (define (for-test exp)
+ (loop exp env counter 'test))
+ (define (for-effect exp)
+ (loop exp env counter 'effect))
+ (define (for-tail exp)
+ (loop exp env counter ctx))
+
+ (if counter
+ (record-effort! counter))
+
(match exp
(($ <const>)
(case ctx
@@ -439,90 +542,168 @@ it does not handle <fix> and <let-values>, it should be
called before
((test) (make-const #f #t))
(else exp)))
(($ <lexical-ref> _ _ gensym)
- ;; Propagate only pure expressions that are not assigned to.
(case ctx
((effect) (make-void #f))
(else
(let ((val (lookup gensym)))
- (if (constant-expression? val)
- (case ctx
- ;; fixme: cache this? it is a divergence from
- ;; O(n).
- ((test) (loop val env calls 'test))
- (else val))
- exp)))))
- ;; Lexical set! causes a bailout.
+ (cond
+ ((or (not val)
+ (assigned-lexical? gensym)
+ (not (constant-expression? val)))
+ ;; Don't copy-propagate through assigned variables,
+ ;; and don't reorder effects.
+ (record-residual-lexical-reference! gensym)
+ exp)
+ ((lexical-ref? val)
+ (for-tail val))
+ ((or (const? val)
+ (void? val)
+ (primitive-ref? val))
+ ;; Always propagate simple values that cannot lead to
+ ;; code bloat.
+ (for-tail val))
+ ((= 1 (lexical-refcount gensym))
+ ;; Always propagate values referenced only once.
+ ;; There is no need to rename the bindings, as they
+ ;; are only being moved, not copied. However in
+ ;; operator context we do rename it, as that
+ ;; effectively clears out the residualized-lexical
+ ;; flags that may have been set when this value was
+ ;; visited previously as an operand.
+ (case ctx
+ ((test) (for-test val))
+ ((operator) (record-source-expression! val (alpha-rename
val)))
+ (else val)))
+ ;; FIXME: do demand-driven size accounting rather than
+ ;; these heuristics.
+ ((eq? ctx 'operator)
+ ;; A pure expression in the operator position. Inline
+ ;; if it's a lambda that's small enough.
+ (if (and (lambda? val)
+ (small-expression? val operator-size-limit))
+ (record-source-expression! val (alpha-rename val))
+ (begin
+ (record-residual-lexical-reference! gensym)
+ exp)))
+ ((eq? ctx 'operand)
+ ;; A pure expression in the operand position. Inline
+ ;; if it's small enough.
+ (if (small-expression? val operand-size-limit)
+ (record-source-expression! val (alpha-rename val))
+ (begin
+ (record-residual-lexical-reference! gensym)
+ exp)))
+ (else
+ ;; A pure expression, processed for value. Don't
+ ;; inline lambdas, because they will probably won't
+ ;; fold because we don't know the operator.
+ (if (and (small-expression? val value-size-limit)
+ (not (tree-il-any lambda? val)))
+ (record-source-expression! val (alpha-rename val))
+ (begin
+ (record-residual-lexical-reference! gensym)
+ exp))))))))
+ (($ <lexical-set> src name gensym exp)
+ (if (zero? (lexical-refcount gensym))
+ (let ((exp (for-effect exp)))
+ (if (void? exp)
+ exp
+ (make-sequence src (list exp (make-void #f)))))
+ (begin
+ (record-residual-lexical-reference! gensym)
+ (make-lexical-set src name gensym (for-value exp)))))
(($ <let> src names gensyms vals body)
- (let* ((vals* (map (cut loop <> env calls 'value) vals))
- (vals (map maybe-unconst vals vals*))
- (body* (loop body
- (fold vhash-consq env gensyms vals)
- calls
- ctx))
- (body (maybe-unconst body body*)))
- (if (const? body*)
- body
- ;; Constants have already been propagated, so there is
- ;; no need to bind them to lexicals.
- (let*-values (((stripped) (remove (compose const? car)
- (zip vals gensyms names)))
- ((vals gensyms names) (unzip3 stripped)))
- (if (null? stripped)
- body
- (make-let src names gensyms vals body))))))
+ (let* ((vals (map for-operand vals))
+ (body (loop body
+ (fold vhash-consq env gensyms vals)
+ counter
+ ctx)))
+ (cond
+ ((const? body)
+ (for-tail (make-sequence src (append vals (list body)))))
+ ((and (lexical-ref? body)
+ (memq (lexical-ref-gensym body) gensyms))
+ (let ((sym (lexical-ref-gensym body))
+ (pairs (map cons gensyms vals)))
+ ;; (let ((x foo) (y bar) ...) x) => (begin bar ... foo)
+ (for-tail
+ (make-sequence
+ src
+ (append (map cdr (alist-delete sym pairs eq?))
+ (list (assq-ref pairs sym)))))))
+ (else
+ ;; Only include bindings for which lexical references
+ ;; have been residualized.
+ (let*-values
+ (((stripped) (remove
+ (lambda (x)
+ (and (not (hashq-ref
+ residual-lexical-references
+ (cadr x)))
+ ;; FIXME: Here we can probably
+ ;; strip pure expressions in
+ ;; addition to constant
+ ;; expressions.
+ (constant-expression? (car x))))
+ (zip vals gensyms names)))
+ ((vals gensyms names) (unzip3 stripped)))
+ (if (null? stripped)
+ body
+ (make-let src names gensyms vals body)))))))
(($ <letrec> src in-order? names gensyms vals body)
;; Things could be done more precisely when IN-ORDER? but
;; it's OK not to do it---at worst we lost an optimization
;; opportunity.
- (let* ((vals* (map (cut loop <> env calls 'value) vals))
- (vals (map maybe-unconst vals vals*))
- (body* (loop body
- (fold vhash-consq env gensyms vals)
- calls
- ctx))
- (body (maybe-unconst body body*)))
- (if (const? body*)
+ (let* ((vals (map for-operand vals))
+ (body (loop body
+ (fold vhash-consq env gensyms vals)
+ counter
+ ctx)))
+ (if (and (const? body)
+ (every constant-expression? vals))
body
- (make-letrec src in-order? names gensyms vals body))))
+ (let*-values
+ (((stripped) (remove
+ (lambda (x)
+ (and (constant-expression? (car x))
+ (not (hashq-ref
+ residual-lexical-references
+ (cadr x)))))
+ (zip vals gensyms names)))
+ ((vals gensyms names) (unzip3 stripped)))
+ (if (null? stripped)
+ body
+ (make-letrec src in-order? names gensyms vals body))))))
(($ <fix> src names gensyms vals body)
- (let* ((vals (map (cut loop <> env calls 'value) vals))
- (body* (loop body
- (fold vhash-consq env gensyms vals)
- calls
- ctx))
- (body (maybe-unconst body body*)))
- (if (const? body*)
+ (let* ((vals (map for-operand vals))
+ (body (loop body
+ (fold vhash-consq env gensyms vals)
+ counter
+ ctx)))
+ (if (const? body)
body
(make-fix src names gensyms vals body))))
(($ <let-values> lv-src producer consumer)
;; Peval the producer, then try to inline the consumer into
;; the producer. If that succeeds, peval again. Otherwise
;; reconstruct the let-values, pevaling the consumer.
- (let ((producer (maybe-unconst producer
- (loop producer env calls 'value))))
+ (let ((producer (for-value producer)))
(or (match consumer
(($ <lambda-case> src req #f #f #f () gensyms body #f)
(cond
((inline-values producer src req gensyms body)
- => (cut loop <> env calls ctx))
+ => for-tail)
(else #f)))
(_ #f))
- (make-let-values lv-src producer
- (loop consumer env calls ctx)))))
+ (make-let-values lv-src producer (for-tail consumer)))))
(($ <dynwind> src winder body unwinder)
- (make-dynwind src (loop winder env calls 'value)
- (loop body env calls ctx)
- (loop unwinder env calls 'value)))
+ (make-dynwind src (for-value winder) (for-tail body)
+ (for-value unwinder)))
(($ <dynlet> src fluids vals body)
- (make-dynlet src
- (map maybe-unconst fluids
- (map (cut loop <> env calls 'value) fluids))
- (map maybe-unconst vals
- (map (cut loop <> env calls 'value) vals))
- (maybe-unconst body (loop body env calls ctx))))
+ (make-dynlet src (map for-value fluids) (map for-value vals)
+ (for-tail body)))
(($ <dynref> src fluid)
- (make-dynref src
- (maybe-unconst fluid (loop fluid env calls 'value))))
+ (make-dynref src (for-value fluid)))
(($ <toplevel-ref> src (? effect-free-primitive? name))
(if (local-toplevel? name)
exp
@@ -533,28 +714,25 @@ it does not handle <fix> and <let-values>, it should be
called before
(($ <module-ref>)
exp)
(($ <module-set> src mod name public? exp)
- (make-module-set src mod name public?
- (maybe-unconst exp (loop exp env '() 'value))))
+ (make-module-set src mod name public? (for-value exp)))
(($ <toplevel-define> src name exp)
- (make-toplevel-define src name
- (maybe-unconst exp (loop exp env '()
'value))))
+ (make-toplevel-define src name (for-value exp)))
(($ <toplevel-set> src name exp)
- (make-toplevel-set src name
- (maybe-unconst exp (loop exp env '() 'value))))
+ (make-toplevel-set src name (for-value exp)))
(($ <primitive-ref>)
(case ctx
((effect) (make-void #f))
((test) (make-const #f #t))
(else exp)))
(($ <conditional> src condition subsequent alternate)
- (let ((condition (loop condition env calls 'test)))
+ (let ((condition (for-test condition)))
(if (const? condition)
(if (const-exp condition)
- (loop subsequent env calls ctx)
- (loop alternate env calls ctx))
+ (for-tail subsequent)
+ (for-tail alternate))
(make-conditional src condition
- (loop subsequent env calls ctx)
- (loop alternate env calls ctx)))))
+ (for-tail subsequent)
+ (for-tail alternate)))))
(($ <application> src
($ <primitive-ref> _ '@call-with-values)
(producer
@@ -563,111 +741,178 @@ it does not handle <fix> and <let-values>, it should be
called before
;; No optional or kwargs.
($ <lambda-case>
_ req #f rest #f () gensyms body #f)))))
- (loop (make-let-values src (make-application src producer '())
- consumer)
- env calls ctx))
+ (for-tail (make-let-values src (make-application src producer '())
+ consumer)))
(($ <application> src orig-proc orig-args)
;; todo: augment the global env with specialized functions
- (let* ((proc (loop orig-proc env calls 'call))
- (proc* (maybe-unlambda orig-proc proc env))
- (args (map (cut loop <> env calls 'value) orig-args))
- (args* (map (cut maybe-unlambda <> <> env)
- orig-args
- (map maybe-unconst orig-args args)))
- (app (make-application src proc* args*)))
- ;; If at least one of ARGS is static (to avoid infinite
- ;; inlining) and this call hasn't already been expanded
- ;; before (to avoid infinite recursion), then expand it
- ;; (todo: emit an infinite recursion warning.)
- (if (and (or (null? args) (any const*? args))
- (not (member (cons proc args) calls)))
- (match proc
- (($ <primitive-ref> _ (? effect-free-primitive? name))
- (if (every const? args) ; only simple constants
- (let-values (((success? values)
- (apply-primitive name
- (map const-exp args))))
- (if success?
- (case ctx
- ((effect) (make-void #f))
- ((test)
- ;; Values truncation: only take the first
- ;; value.
- (if (pair? values)
- (make-const #f (car values))
- (make-values src '())))
- (else
- (make-values src (map (cut make-const src <>)
- values))))
- app))
- app))
- (($ <primitive-ref>)
- ;; An effectful primitive.
- app)
- (($ <lambda> _ _
- ($ <lambda-case> _ req opt #f #f inits gensyms body))
- ;; Simple case: no rest, no keyword arguments.
- ;; todo: handle the more complex cases
- (let ((nargs (length args))
- (nreq (length req))
- (nopt (if opt (length opt) 0)))
- (if (and (>= nargs nreq) (<= nargs (+ nreq nopt))
- (every constant-expression? args))
- (let* ((params
- (append args
- (drop inits
- (max 0
- (- nargs
- (+ nreq nopt))))))
- (body
- (loop body
- (fold vhash-consq env gensyms params)
- (cons (cons proc args) calls)
- ctx)))
- ;; If the residual code contains recursive
- ;; calls, give up inlining.
- (if (code-contains-calls? body proc lookup)
- app
- body))
- app)))
- (($ <lambda>)
- app)
- (($ <toplevel-ref>)
- app)
-
- ;; In practice, this is the clause that stops peval:
- ;; module-ref applications (produced by macros,
- ;; typically) don't match, and so this throws,
- ;; aborting peval for an entire expression.
- )
-
- app)))
+ (let ((proc (loop orig-proc env counter 'operator)))
+ (match proc
+ (($ <primitive-ref> _ (? constructor-primitive? name))
+ (case ctx
+ ((effect test)
+ (let ((exp (for-value exp))
+ (res (if (eq? ctx 'effect)
+ (make-void #f)
+ (make-const #f #t))))
+ (match (for-value exp)
+ (($ <application> _ ($ <primitive-ref> _ 'cons) (x xs))
+ (for-tail
+ (make-sequence src (list x xs res))))
+ (($ <application> _ ($ <primitive-ref> _ 'list) elts)
+ (for-tail
+ (make-sequence src (append elts (list res)))))
+ (($ <application> _ ($ <primitive-ref> _ 'vector) elts)
+ (for-tail
+ (make-sequence src (append elts (list res)))))
+ (_ exp))))
+ (else
+ (match (cons name (map for-value orig-args))
+ (('cons head tail)
+ (let ((tail (for-value tail)))
+ (match tail
+ (($ <const> src ())
+ (make-application src (make-primitive-ref #f 'list)
+ (list head)))
+ (($ <application> src ($ <primitive-ref> _ 'list)
elts)
+ (make-application src (make-primitive-ref #f 'list)
+ (cons head elts)))
+ (_ (make-application src proc
+ (list head tail))))))
+
+ (('car ($ <application> src ($ <primitive-ref> _ 'cons)
(head tail)))
+ (for-tail (make-sequence src (list tail head))))
+ (('cdr ($ <application> src ($ <primitive-ref> _ 'cons)
(head tail)))
+ (for-tail (make-sequence src (list head tail))))
+
+ (('car ($ <application> src ($ <primitive-ref> _ 'list)
(head . tail)))
+ (for-tail (make-sequence src (append tail (list head)))))
+ (('cdr ($ <application> src ($ <primitive-ref> _ 'list)
(head . tail)))
+ (for-tail (make-sequence
+ src
+ (list head
+ (make-application
+ src (make-primitive-ref #f 'list)
tail)))))
+
+ (('car ($ <const> src (head . tail)))
+ (for-tail (make-const src head)))
+ (('cdr ($ <const> src (head . tail)))
+ (for-tail (make-const src tail)))
+
+ ((_ . args)
+ (make-application src proc args))))))
+ (($ <primitive-ref> _ (? effect-free-primitive? name))
+ (let ((args (map for-value orig-args)))
+ (if (every const? args) ; only simple constants
+ (let-values (((success? values)
+ (apply-primitive name
+ (map const-exp args))))
+ (if success?
+ (case ctx
+ ((effect) (make-void #f))
+ ((test)
+ ;; Values truncation: only take the first
+ ;; value.
+ (if (pair? values)
+ (make-const #f (car values))
+ (make-values src '())))
+ (else
+ (make-values src (map (cut make-const src <>)
+ values))))
+ (make-application src proc args)))
+ (make-application src proc args))))
+ (($ <lambda> _ _
+ ($ <lambda-case> _ req opt #f #f inits gensyms body #f))
+ ;; Simple case: no rest, no keyword arguments.
+ ;; todo: handle the more complex cases
+ (let* ((nargs (length orig-args))
+ (nreq (length req))
+ (nopt (if opt (length opt) 0))
+ (key (source-expression proc)))
+ (cond
+ ((or (< nargs nreq) (> nargs (+ nreq nopt)))
+ ;; An error, or effecting arguments.
+ (make-application src (for-value orig-proc)
+ (map for-value orig-args)))
+ ((and=> (find-counter key counter) counter-recursive?)
+ ;; A recursive call. Process again in tail context.
+ (loop (make-let src (append req (or opt '()))
+ gensyms
+ (append orig-args
+ (drop inits
+ (max 0
+ (- nargs
+ (+ nreq nopt)))))
+ body)
+ env counter ctx))
+ (else
+ ;; An integration at the top-level, the first
+ ;; recursion of a recursive procedure, or a nested
+ ;; integration of a procedure that hasn't been seen
+ ;; yet.
+ (let/ec k
+ (let ((abort (lambda ()
+ (k (make-application
+ src
+ (for-value orig-proc)
+ (map for-value orig-args))))))
+ (loop (make-let src (append req (or opt '()))
+ gensyms
+ (append orig-args
+ (drop inits
+ (max 0
+ (- nargs
+ (+ nreq nopt)))))
+ body)
+ env
+ (cond
+ ((find-counter key counter)
+ => (lambda (prev)
+ (make-recursive-counter recursive-effort-limit
+ operand-size-limit
+ prev counter)))
+ (counter
+ (make-nested-counter abort key counter))
+ (else
+ (make-top-counter effort-limit operand-size-limit
+ abort key)))
+ ctx)))))))
+ ((or ($ <primitive-ref>)
+ ($ <lambda>)
+ ($ <toplevel-ref>)
+ ($ <lexical-ref>))
+ (make-application src proc
+ (map for-value orig-args)))
+
+ ;; In practice, this is the clause that stops peval:
+ ;; module-ref applications (produced by macros,
+ ;; typically) don't match, and so this throws,
+ ;; aborting peval for an entire expression.
+ )))
(($ <lambda> src meta body)
(case ctx
((effect) (make-void #f))
((test) (make-const #f #t))
+ ((operator) exp)
(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)
(make-lambda-case src req opt rest kw
- (map maybe-unconst inits
- (map (cut loop <> env calls 'value) inits))
+ (map for-value inits)
gensyms
- (maybe-unconst body (loop body env calls ctx))
- alt))
+ (for-tail body)
+ (and alt (for-tail alt))))
(($ <sequence> src exps)
(let lp ((exps exps) (effects '()))
(match exps
((last)
(if (null? effects)
- (loop last env calls ctx)
- (make-sequence src (append (reverse effects)
- (list
- (maybe-unconst last
- (loop last env
calls ctx)))))))
+ (for-tail last)
+ (make-sequence
+ src
+ (reverse (cons (for-tail last) effects)))))
((head . rest)
- (let ((head (loop head env calls 'effect)))
+ (let ((head (for-effect head)))
(cond
((sequence? head)
(lp (append (sequence-exps head) rest) effects))
@@ -676,6 +921,6 @@ it does not handle <fix> and <let-values>, it should be
called before
(else
(lp rest (cons head effects))))))))))))
(lambda _
- ;; We encountered something we don't handle, like `<lexical-set>',
- ;; <abort>, or some other effecting construct, so bail out.
+ ;; We encountered something we don't handle, like <abort> or
+ ;; <prompt>, so bail out.
exp)))
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 3040d74..6299f14 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -89,7 +89,17 @@
(let ((evaled (unparse-tree-il (peval code))))
(pmatch evaled
(pat #t)
- (_ (pk 'peval-mismatch evaled) #f)))))))
+ (_ (pk 'peval-mismatch)
+ ((@ (ice-9 pretty-print) pretty-print)
+ 'in)
+ (newline)
+ ((@ (ice-9 pretty-print) pretty-print)
+ evaled)
+ (newline)
+ ((@ (ice-9 pretty-print) pretty-print)
+ 'pat)
+ (newline)
+ #f)))))))
(with-test-prefix "tree-il->scheme"
@@ -640,38 +650,121 @@
(const 3))
(pass-if-peval
- ;; First order, coalesced.
+ ;; First order, coalesced, mutability preserved.
(cons 0 (cons 1 (cons 2 (list 3 4 5))))
- (const (0 1 2 3 4 5)))
+ (apply (primitive list)
+ (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
(pass-if-peval
- ;; First order, coalesced, mutability preserved.
- (define mutable
- (cons 0 (cons 1 (cons 2 (list 3 4 5)))))
- (define mutable
- ;; This must not be a constant.
- (apply (primitive list)
- (const 0) (const 1) (const 2) (const 3) (const 4) (const 5))))
+ ;; First order, coalesced, mutability preserved.
+ (cons 0 (cons 1 (cons 2 (list 3 4 5))))
+ ;; This must not be a constant.
+ (apply (primitive list)
+ (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
(pass-if-peval
- ;; First order, mutability preserved.
- (define mutable
- (let loop ((i 3) (r '()))
- (if (zero? i)
- r
- (loop (1- i) (cons (cons i i) r)))))
- (define mutable
- (apply (primitive list)
- (apply (primitive cons) (const 1) (const 1))
- (apply (primitive cons) (const 2) (const 2))
- (apply (primitive cons) (const 3) (const 3)))))
+ ;; First order, coalesced, immutability preserved.
+ (cons 0 (cons 1 (cons 2 '(3 4 5))))
+ (apply (primitive cons) (const 0)
+ (apply (primitive cons) (const 1)
+ (apply (primitive cons) (const 2)
+ (const (3 4 5))))))
+
+ ;; These two tests doesn't work any more because we changed the way we
+ ;; deal with constants -- now the algorithm will see a construction as
+ ;; being bound to the lexical, so it won't propagate it. It can't
+ ;; even propagate it in the case that it is only referenced once,
+ ;; because:
+ ;;
+ ;; (let ((x (cons 1 2))) (lambda () x))
+ ;;
+ ;; is not the same as
+ ;;
+ ;; (lambda () (cons 1 2))
+ ;;
+ ;; Perhaps if we determined that not only was it only referenced once,
+ ;; it was not closed over by a lambda, then we could propagate it, and
+ ;; re-enable these two tests.
+ ;;
+ #;
+ (pass-if-peval
+ ;; First order, mutability preserved.
+ (let loop ((i 3) (r '()))
+ (if (zero? i)
+ r
+ (loop (1- i) (cons (cons i i) r))))
+ (apply (primitive list)
+ (apply (primitive cons) (const 1) (const 1))
+ (apply (primitive cons) (const 2) (const 2))
+ (apply (primitive cons) (const 3) (const 3))))
+ ;;
+ ;; See above.
+ #;
+ (pass-if-peval
+ ;; First order, evaluated.
+ (let loop ((i 7)
+ (r '()))
+ (if (<= i 0)
+ (car r)
+ (loop (1- i) (cons i r))))
+ (const 1))
+
+ ;; Instead here are tests for what happens for the above cases: they
+ ;; unroll but they don't fold.
+ (pass-if-peval
+ (let loop ((i 3) (r '()))
+ (if (zero? i)
+ r
+ (loop (1- i) (cons (cons i i) r))))
+ (letrec (loop) (_) (_)
+ (let (r) (_)
+ ((apply (primitive list)
+ (apply (primitive cons) (const 3) (const 3))))
+ (let (r) (_)
+ ((apply (primitive cons)
+ (apply (primitive cons) (const 2) (const 2))
+ (lexical r _)))
+ (apply (primitive cons)
+ (apply (primitive cons) (const 1) (const 1))
+ (lexical r _))))))
+
+ ;; See above.
+ (pass-if-peval
+ (let loop ((i 4)
+ (r '()))
+ (if (<= i 0)
+ (car r)
+ (loop (1- i) (cons i r))))
+ (letrec (loop) (_) (_)
+ (let (r) (_)
+ ((apply (primitive list) (const 4)))
+ (let (r) (_)
+ ((apply (primitive cons)
+ (const 3)
+ (lexical r _)))
+ (let (r) (_)
+ ((apply (primitive cons)
+ (const 2)
+ (lexical r _)))
+ (let (r) (_)
+ ((apply (primitive cons)
+ (const 1)
+ (lexical r _)))
+ (apply (primitive car)
+ (lexical r _))))))))
+
+ ;; Static sums.
+ (pass-if-peval
+ (let loop ((l '(1 2 3 4)) (sum 0))
+ (if (null? l)
+ sum
+ (loop (cdr l) (+ sum (car l)))))
+ (const 10))
(pass-if-peval
- ;; Mutability preserved.
- (define mutable
- ((lambda (x y z) (list x y z)) 1 2 3))
- (define mutable
- (apply (primitive list) (const 1) (const 2) (const 3))))
+ ;; Mutability preserved.
+ ((lambda (x y z) (list x y z)) 1 2 3)
+ (apply (primitive list) (const 1) (const 2) (const 3)))
(pass-if-peval
;; Don't propagate effect-free expressions that operate on mutable
@@ -698,14 +791,14 @@
(lexical y _))))
(pass-if-peval
- ;; First order, evaluated.
- (define one
- (let loop ((i 7)
- (r '()))
- (if (<= i 0)
- (car r)
- (loop (1- i) (cons i r)))))
- (define one (const 1)))
+ ;; Infinite recursion
+ ((lambda (x) (x x)) (lambda (x) (x x)))
+ (let (x) (_)
+ ((lambda _
+ (lambda-case
+ (((x) _ _ _ _ _)
+ (apply (lexical x _) (lexical x _))))))
+ (apply (lexical x _) (lexical x _))))
(pass-if-peval
;; First order, aliased primitive.
@@ -749,8 +842,7 @@
(lambda (_)
(lambda-case
(((x) #f #f #f () (_))
- (letrec* (bar) (_) ((lambda (_) . _))
- (apply (primitive +) (lexical x _) (const 9))))))))
+ (apply (primitive +) (lexical x _) (const 9)))))))
(pass-if-peval
;; First order, with lambda inlined & specialized twice.
@@ -760,55 +852,40 @@
(y 3))
(+ (* x (f x y))
(f something x)))
- (let (f) (_) ((lambda (_)
- (lambda-case
- (((x y) #f #f #f () (_ _))
- (apply (primitive +)
- (apply (primitive *)
- (lexical x _)
- (toplevel top))
- (lexical y _))))))
- (apply (primitive +)
- (apply (primitive *)
- (const 2)
- (apply (primitive +) ; (f 2 3)
- (apply (primitive *)
- (const 2)
- (toplevel top))
- (const 3)))
- (apply (lexical f _) ; (f something 2)
- ;; This arg is not const, so the lambda does not
- ;; fold. We will fix this in the future when we
- ;; inline lambda to `let'. That will offer the
- ;; possibility of creating a lexical binding for
- ;; `something', to preserve the order of effects.
- (toplevel something)
+ (apply (primitive +)
+ (apply (primitive *)
+ (const 2)
+ (apply (primitive +) ; (f 2 3)
+ (apply (primitive *)
+ (const 2)
+ (toplevel top))
+ (const 3)))
+ (let (x) (_) ((toplevel something)) ; (f
something 2)
+ ;; `something' is not const, so preserve order of
+ ;; effects with a lexical binding.
+ (apply (primitive +)
+ (apply (primitive *)
+ (lexical x _)
+ (toplevel top))
(const 2)))))
-
+
(pass-if-peval
- ;; First order, with lambda inlined & specialized 3 times.
- (let ((f (lambda (x y) (if (> x 0) y x))))
- (+ (f -1 0)
- (f 1 0)
- (f -1 y)
- (f 2 y)
- (f z y)))
- (let (f) (_)
- ((lambda (_)
- (lambda-case
- (((x y) #f #f #f () (_ _))
- (if (apply (primitive >) (lexical x _) (const 0))
- (lexical y _)
- (lexical x _))))))
- (apply (primitive +)
- (const -1) ; (f -1 0)
- (const 0) ; (f 1 0)
- (apply (lexical f _) ; (f -1 y)
- (const -1) (toplevel y))
- (apply (lexical f _) ; (f 2 y)
- (const 2) (toplevel y))
- (apply (lexical f _) ; (f z y)
- (toplevel z) (toplevel y)))))
+ ;; First order, with lambda inlined & specialized 3 times.
+ (let ((f (lambda (x y) (if (> x 0) y x))))
+ (+ (f -1 0)
+ (f 1 0)
+ (f -1 y)
+ (f 2 y)
+ (f z y)))
+ (apply (primitive +)
+ (const -1) ; (f -1 0)
+ (const 0) ; (f 1 0)
+ (begin (toplevel y) (const -1)) ; (f -1 y)
+ (toplevel y) ; (f 2 y)
+ (let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y)
+ (if (apply (primitive >) (lexical x _) (const 0))
+ (lexical y _)
+ (lexical x _)))))
(pass-if-peval
;; First order, conditional.
@@ -829,8 +906,8 @@
n
(+ (fibo (- n 1))
(fibo (- n 2)))))))
- (fibo 7))
- (const 13))
+ (fibo 4))
+ (const 3))
(pass-if-peval
;; Don't propagate toplevel references, as intervening expressions
@@ -874,25 +951,15 @@
(pass-if-peval
;; Higher order.
((lambda (f) (f x)) (lambda (x) x))
- (apply (lambda ()
- (lambda-case
- (((x) #f #f #f () (_))
- (lexical x _))))
- (toplevel x)))
+ (toplevel x))
(pass-if-peval
;; Bug reported at
;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
(let ((fold (lambda (f g) (f (g top)))))
(fold 1+ (lambda (x) x)))
- (let (fold) (_) (_)
- (apply (primitive 1+)
- (apply (lambda ()
- (lambda-case
- (((x) #f #f #f () (_))
- (lexical x _))))
- (toplevel top)))))
-
+ (apply (primitive 1+) (toplevel top)))
+
(pass-if-peval
;; Procedure not inlined when residual code contains recursive calls.
;; <http://debbugs.gnu.org/9542>
@@ -930,20 +997,19 @@
(lambda (x) (lambda (y) (+ x y)))))
(cons (make-adder 1) (make-adder 2)))
#:to 'tree-il)))
- ((let (make-adder) (_) (_)
- (apply (primitive cons)
- (lambda ()
- (lambda-case
- (((y) #f #f #f () (,gensym1))
- (apply (primitive +)
- (const 1)
- (lexical y ,ref1)))))
- (lambda ()
- (lambda-case
- (((y) #f #f #f () (,gensym2))
- (apply (primitive +)
- (const 2)
- (lexical y ,ref2)))))))
+ ((apply (primitive cons)
+ (lambda ()
+ (lambda-case
+ (((y) #f #f #f () (,gensym1))
+ (apply (primitive +)
+ (const 1)
+ (lexical y ,ref1)))))
+ (lambda ()
+ (lambda-case
+ (((y) #f #f #f () (,gensym2))
+ (apply (primitive +)
+ (const 2)
+ (lexical y ,ref2))))))
(and (eq? gensym1 ref1)
(eq? gensym2 ref2)
(not (eq? gensym1 gensym2))))
@@ -996,9 +1062,8 @@
(let (x) (_) ((if (apply (primitive >) (toplevel p) (toplevel q))
(apply (toplevel frob!))
(apply (toplevel display) (const chbouib))))
- (let (y) (_) ((apply (primitive *) (lexical x _) (const 2)))
- (apply (primitive +) (lexical x _) (lexical x _)
- (apply (primitive *) (lexical x _) (const 2))))))
+ (apply (primitive +) (lexical x _) (lexical x _)
+ (apply (primitive *) (lexical x _) (const 2)))))
(pass-if-peval
;; Non-constant arguments not propagated to lambdas.
@@ -1009,50 +1074,37 @@
(vector 1 2 3)
(make-list 10)
(list 1 2 3))
- (apply (lambda ()
- (lambda-case
- (((x y z) #f #f #f () (_ _ _))
- (begin
- (apply (toplevel vector-set!)
- (lexical x _) (const 0) (const 0))
- (apply (toplevel set-car!)
- (lexical y _) (const 0))
- (apply (toplevel set-cdr!)
- (lexical z _) (const ()))))))
- (apply (primitive vector) (const 1) (const 2) (const 3))
- (apply (toplevel make-list) (const 10))
- (apply (primitive list) (const 1) (const 2) (const 3))))
+ (let (x y z) (_ _ _)
+ ((apply (primitive vector) (const 1) (const 2) (const 3))
+ (apply (toplevel make-list) (const 10))
+ (apply (primitive list) (const 1) (const 2) (const 3)))
+ (begin
+ (apply (toplevel vector-set!)
+ (lexical x _) (const 0) (const 0))
+ (apply (toplevel set-car!)
+ (lexical y _) (const 0))
+ (apply (toplevel set-cdr!)
+ (lexical z _) (const ())))))
(pass-if-peval
- ;; Procedure only called with dynamic args is not inlined.
(let ((foo top-foo) (bar top-bar))
(let* ((g (lambda (x y) (+ x y)))
(f (lambda (g x) (g x x))))
(+ (f g foo) (f g bar))))
(let (foo bar) (_ _) ((toplevel top-foo) (toplevel top-bar))
- (let (g) (_)
- ((lambda _ ; g
- (lambda-case
- (((x y) #f #f #f () (_ _))
- (apply (primitive +) (lexical x _) (lexical y _))))))
- (let (f) (_)
- ((lambda _ ; f
- (lambda-case
- (((g x) #f #f #f () (_ _))
- (apply (lexical g _) (lexical x _) (lexical x _))))))
- (apply (primitive +)
- (apply (lexical g _) (lexical foo _) (lexical foo _))
- (apply (lexical g _) (lexical bar _) (lexical bar
_)))))))
+ (apply (primitive +)
+ (apply (primitive +) (lexical foo _) (lexical foo _))
+ (apply (primitive +) (lexical bar _) (lexical bar _)))))
(pass-if-peval
- ;; Fresh objects are not turned into constants.
+ ;; Fresh objects are not turned into constants, nor are constants
+ ;; turned into fresh objects.
(let* ((c '(2 3))
(x (cons 1 c))
(y (cons 0 x)))
y)
- (let (x) (_) ((apply (primitive list) (const 1) (const 2) (const 3)))
- (let (y) (_) ((apply (primitive cons) (const 0) (lexical x _)))
- (lexical y _))))
+ (let (x) (_) ((apply (primitive cons) (const 1) (const (2 3))))
+ (apply (primitive cons) (const 0) (lexical x _))))
(pass-if-peval
;; Bindings mutated.
@@ -1072,10 +1124,10 @@
x)))
(frob f) ; may mutate `x'
x)
- (letrec (x f) (_ _) ((const 0) _)
+ (letrec (x) (_) ((const 0))
(begin
- (apply (toplevel frob) (lexical f _))
- (lexical x _))))
+ (apply (toplevel frob) (lambda _ _))
+ (lexical x _))))
(pass-if-peval
;; Bindings mutated.
@@ -1121,11 +1173,14 @@
(pass-if-peval
;; Inlining aborted when residual code contains recursive calls.
+ ;;
;; <http://debbugs.gnu.org/9542>
(let loop ((x x) (y 0))
(if (> y 0)
- (loop (1+ x) (1+ y))
- (if (< x 0) x (loop (1- x)))))
+ (loop (1- x) (1- y))
+ (if (< x 0)
+ x
+ (loop (1+ x) (1+ y)))))
(letrec (loop) (_) ((lambda (_)
(lambda-case
(((x y) #f #f #f () (_ _))
@@ -1140,7 +1195,64 @@
(g (lambda (x) (h (1+ x))))
(h (lambda (x) (f x))))
(f 0))
- (letrec _ . _)))
+ (letrec _ . _))
+
+ (pass-if-peval
+ ;; Constant folding: cons
+ (begin (cons 1 2) #f)
+ (const #f))
+
+ (pass-if-peval
+ ;; Constant folding: cons
+ (begin (cons (foo) 2) #f)
+ (begin (apply (toplevel foo)) (const #f)))
+
+ (pass-if-peval
+ ;; Constant folding: cons
+ (if (cons 0 0) 1 2)
+ (const 1))
+
+ (pass-if-peval
+ ;; Constant folding: car+cons
+ (car (cons 1 0))
+ (const 1))
+
+ (pass-if-peval
+ ;; Constant folding: cdr+cons
+ (cdr (cons 1 0))
+ (const 0))
+
+ (pass-if-peval
+ ;; Constant folding: car+cons, impure
+ (car (cons 1 (bar)))
+ (begin (apply (toplevel bar)) (const 1)))
+
+ (pass-if-peval
+ ;; Constant folding: cdr+cons, impure
+ (cdr (cons (bar) 0))
+ (begin (apply (toplevel bar)) (const 0)))
+
+ (pass-if-peval
+ ;; Constant folding: car+list
+ (car (list 1 0))
+ (const 1))
+
+ (pass-if-peval
+ ;; Constant folding: cdr+list
+ (cdr (list 1 0))
+ (apply (primitive list) (const 0)))
+
+ (pass-if-peval
+ ;; Constant folding: car+list, impure
+ (car (list 1 (bar)))
+ (begin (apply (toplevel bar)) (const 1)))
+
+ (pass-if-peval
+ ;; Constant folding: cdr+list, impure
+ (cdr (list (bar) 0))
+ (begin (apply (toplevel bar)) (apply (primitive list) (const 0))))
+
+ )
(with-test-prefix "tree-il-fold"
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.2-121-g02ebea5,
Andy Wingo <=