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

Merge remote-tracking branch 'origin/stable-2.0'

Browse source 
Conflicts:
	test-suite/tests/cse.test
This commit is contained in:
Andy Wingo 2012-04-26 23:40:57 +02:00
commit 9d8a10a94c
9 changed files with 321 additions and 215 deletions
Download patch file Download diff file Expand all files Collapse all files

365
module/ice-9/vlist.scm
View file

@ -69,26 +69,19 @@
(define block-growth-factor
(make-fluid 2))
(define-syntax-rule (define-inline (name formals ...) body ...)
;; Work around the lack of an inliner.
(define-syntax name
(syntax-rules ()
((_ formals ...)
(begin body ...)))))
(define-inline (make-block base offset size hash-tab?)
;; Return a block (and block descriptor) of SIZE elements pointing to BASE
;; at OFFSET. If HASH-TAB? is true, a "hash table" is also added.
;; Note: We use `next-free' instead of `last-used' as suggested by Bagwell.
;; XXX: We could improve locality here by having a single vector but currently
;; the extra arithmetic outweighs the benefits (!).
(vector (make-vector size)
base offset size 0
(and hash-tab? (make-vector size #f))))
(define-inlinable (make-block base offset size hash-tab?)
;; Return a block (and block descriptor) of SIZE elements pointing to
;; BASE at OFFSET. If HASH-TAB? is true, we also reserve space for a
;; "hash table". Note: We use `next-free' instead of `last-used' as
;; suggested by Bagwell.
(if hash-tab?
(vector (make-vector (* size 3) #f)
base offset size 0)
(vector (make-vector size)
base offset size 0)))
(define-syntax-rule (define-block-accessor name index)
(define-inline (name block)
(define-inlinable (name block)
(vector-ref block index)))
(define-block-accessor block-content 0)
@ -96,33 +89,51 @@
(define-block-accessor block-offset 2)
(define-block-accessor block-size 3)
(define-block-accessor block-next-free 4)
(define-block-accessor block-hash-table 5)
(define-inline (increment-block-next-free! block)
(vector-set! block 4
(+ (block-next-free block) 1)))
(define-inlinable (block-hash-table? block)
(< (block-size block) (vector-length (block-content block))))
(define-inline (block-append! block value)
(define-inlinable (set-block-next-free! block next-free)
(vector-set! block 4 next-free))
(define-inlinable (block-append! block value offset)
;; This is not thread-safe. To fix it, see Section 2.8 of the paper.
(let ((offset (block-next-free block)))
(increment-block-next-free! block)
(vector-set! (block-content block) offset value)
#t))
(and (< offset (block-size block))
(= offset (block-next-free block))
(begin
(set-block-next-free! block (1+ offset))
(vector-set! (block-content block) offset value)
#t)))
(define-inline (block-ref block offset)
(vector-ref (block-content block) offset))
;; Return the item at slot OFFSET.
(define-inlinable (block-ref content offset)
(vector-ref content offset))
(define-inline (block-ref* block offset)
(let ((v (block-ref block offset)))
(if (block-hash-table block)
(car v) ;; hide the vhash link
v)))
;; Return the offset of the next item in the hash bucket, after the one
;; at OFFSET.
(define-inlinable (block-hash-table-next-offset content size offset)
(vector-ref content (+ size size offset)))
(define-inline (block-hash-table-ref block offset)
(vector-ref (block-hash-table block) offset))
;; Save the offset of the next item in the hash bucket, after the one
;; at OFFSET.
(define-inlinable (block-hash-table-set-next-offset! content size offset
next-offset)
(vector-set! content (+ size size offset) next-offset))
(define-inline (block-hash-table-set! block offset value)
(vector-set! (block-hash-table block) offset value))
;; Returns the index of the last entry stored in CONTENT with
;; SIZE-modulo hash value KHASH.
(define-inlinable (block-hash-table-ref content size khash)
(vector-ref content (+ size khash)))
(define-inlinable (block-hash-table-set! content size khash offset)
(vector-set! content (+ size khash) offset))
;; Add hash table information for the item recently added at OFFSET,
;; with SIZE-modulo hash KHASH.
(define-inlinable (block-hash-table-add! content size khash offset)
(block-hash-table-set-next-offset! content size offset
(block-hash-table-ref content size khash))
(block-hash-table-set! content size khash offset))
(define block-null
;; The null block.
@ -149,13 +160,10 @@
(lambda (vl port)
(cond ((vlist-null? vl)
(format port "#<vlist ()>"))
((block-hash-table (vlist-base vl))
((vhash? vl)
(format port "#<vhash ~x ~a pairs>"
(object-address vl)
(vhash-fold (lambda (k v r)
(+ 1 r))
0
vl)))
(vlist-length vl)))
(else
(format port "#<vlist ~a>"
(vlist->list vl))))))
@ -165,42 +173,61 @@
;; The empty vlist.
(make-vlist block-null 0))
(define-inline (block-cons item vlist hash-tab?)
(let loop ((base (vlist-base vlist))
(offset (+ 1 (vlist-offset vlist))))
(if (and (< offset (block-size base))
(= offset (block-next-free base))
(block-append! base item))
(make-vlist base offset)
(let ((size (cond ((eq? base block-null) 1)
((< offset (block-size base))
;; new vlist head
1)
(else
(* (fluid-ref block-growth-factor)
(block-size base))))))
;; Prepend a new block pointing to BASE.
(loop (make-block base (- offset 1) size hash-tab?)
0)))))
;; Asserting that something is a vlist is actually a win if your next
;; step is to call record accessors, because that causes CSE to
;; eliminate the type checks in those accessors.
;;
(define-inlinable (assert-vlist val)
(unless (vlist? val)
(throw 'wrong-type-arg
#f
"Not a vlist: ~S"
(list val)
(list val))))
(define-inlinable (block-cons item vlist hash-tab?)
(let ((base (vlist-base vlist))
(offset (1+ (vlist-offset vlist))))
(cond
((block-append! base item offset)
;; Fast path: We added the item directly to the block.
(make-vlist base offset))
(else
;; Slow path: Allocate a new block.
(let* ((size (block-size base))
(base (make-block
base
(1- offset)
(cond
((zero? size) 1)
((< offset size) 1) ;; new vlist head
(else (* (fluid-ref block-growth-factor) size)))
hash-tab?)))
(set-block-next-free! base 1)
(vector-set! (block-content base) 0 item)
(make-vlist base 0))))))
(define (vlist-cons item vlist)
"Return a new vlist with @var{item} as its head and @var{vlist} as its
tail."
;; Note: Calling `vlist-cons' on a vhash will not do the right thing: it
;; doesn't box ITEM so that it can have the hidden "next" link used by
;; vhash items, and it passes `#f' as the HASH-TAB? argument to
;; `block-cons'. However, inserting all the checks here has an important
;; performance penalty, hence this choice.
;; Note: Although the result of `vlist-cons' on a vhash is a valid
;; vlist, it is not a valid vhash. The new item does not get a hash
;; table entry. If we allocate a new block, the new block will not
;; have a hash table. Perhaps we can do something more sensible here,
;; but this is a hot function, so there are performance impacts.
(assert-vlist vlist)
(block-cons item vlist #f))
(define (vlist-head vlist)
"Return the head of @var{vlist}."
(assert-vlist vlist)
(let ((base (vlist-base vlist))
(offset (vlist-offset vlist)))
(block-ref* base offset)))
(block-ref (block-content base) offset)))
(define (vlist-tail vlist)
"Return the tail of @var{vlist}."
(assert-vlist vlist)
(let ((base (vlist-base vlist))
(offset (vlist-offset vlist)))
(if (> offset 0)
@ -210,6 +237,7 @@ tail."
(define (vlist-null? vlist)
"Return true if @var{vlist} is empty."
(assert-vlist vlist)
(let ((base (vlist-base vlist)))
(and (not (block-base base))
(= 0 (block-size base)))))
@ -226,6 +254,7 @@ tail."
(define (vlist-fold proc init vlist)
"Fold over @var{vlist}, calling @var{proc} for each element."
;; FIXME: Handle multiple lists.
(assert-vlist vlist)
(let loop ((base (vlist-base vlist))
(offset (vlist-offset vlist))
(result init))
@ -235,19 +264,18 @@ tail."
(done? (< next 0)))
(loop (if done? (block-base base) base)
(if done? (block-offset base) next)
(proc (block-ref* base offset) result))))))
(proc (block-ref (block-content base) offset) result))))))
(define (vlist-fold-right proc init vlist)
"Fold over @var{vlist}, calling @var{proc} for each element, starting from
the last element."
(define len (vlist-length vlist))
(let loop ((index (1- len))
(assert-vlist vlist)
(let loop ((index (1- (vlist-length vlist)))
(result init))
(if (< index 0)
result
(loop (1- index)
(proc (vlist-ref vlist index) result)))))
(proc (vlist-ref vlist index) result)))))
(define (vlist-reverse vlist)
"Return a new @var{vlist} whose content are those of @var{vlist} in reverse
@ -267,11 +295,12 @@ order."
(define (vlist-ref vlist index)
"Return the element at index @var{index} in @var{vlist}."
(assert-vlist vlist)
(let loop ((index index)
(base (vlist-base vlist))
(offset (vlist-offset vlist)))
(if (<= index offset)
(block-ref* base (- offset index))
(block-ref (block-content base) (- offset index))
(loop (- index offset 1)
(block-base base)
(block-offset base)))))
@ -279,6 +308,7 @@ order."
(define (vlist-drop vlist count)
"Return a new vlist that does not contain the @var{count} first elements of
@var{vlist}."
(assert-vlist vlist)
(let loop ((count count)
(base (vlist-base vlist))
(offset (vlist-offset vlist)))
@ -319,6 +349,7 @@ satisfy @var{pred}."
(define (vlist-length vlist)
"Return the length of @var{vlist}."
(assert-vlist vlist)
(let loop ((base (vlist-base vlist))
(len (vlist-offset vlist)))
(if (eq? base block-null)
@ -371,98 +402,94 @@ details."
;; associated with K1 and K2, respectively. The resulting layout is a
;; follows:
;;
;; ,--------------------.
;; | ,-> (K1 . V1) ---. |
;; | | | |
;; | | (K2 . V2) <--' |
;; | | |
;; +-|------------------+
;; | | |
;; | | |
;; | `-- O <---------------H
;; | |
;; `--------------------'
;; ,--------------------.
;; 0| ,-> (K1 . V1) | Vlist array
;; 1| | |
;; 2| | (K2 . V2) |
;; 3| | |
;; size +-|------------------+
;; 0| | | Hash table
;; 1| | |
;; 2| +-- O <------------- H
;; 3| | |
;; size * 2 +-|------------------+
;; 0| `-> 2 | Chain links
;; 1| |
;; 2| #f |
;; 3| |
;; size * 3 `--------------------'
;;
;; The bottom part is the "hash table" part of the vhash, as returned by
;; `block-hash-table'; the other half is the data part. O is the offset of
;; the first value associated with a key that hashes to H in the data part.
;; The (K1 . V1) pair has a "hidden" link to the (K2 . V2) pair; hiding the
;; link is handled by `block-ref'.
;; This API potentially requires users to repeat which hash function and which
;; equality predicate to use. This can lead to unpredictable results if they
;; are used in consistenly, e.g., between `vhash-cons' and `vhash-assoc', which
;; is undesirable, as argued in http://savannah.gnu.org/bugs/?22159 . OTOH, two
;; arguments can be made in favor of this API:
;; The backing store for the vhash is partitioned into three areas: the
;; vlist part, the hash table part, and the chain links part. In this
;; example we have a hash H which, when indexed into the hash table
;; part, indicates that a value with this hash can be found at offset 0
;; in the vlist part. The corresponding index (in this case, 0) of the
;; chain links array holds the index of the next element in this block
;; with this hash value, or #f if we reached the end of the chain.
;;
;; This API potentially requires users to repeat which hash function and
;; which equality predicate to use. This can lead to unpredictable
;; results if they are used in consistenly, e.g., between `vhash-cons'
;; and `vhash-assoc', which is undesirable, as argued in
;; http://savannah.gnu.org/bugs/?22159 . OTOH, two arguments can be
;; made in favor of this API:
;;
;; - It's consistent with how alists are handled in SRFI-1.
;;
;; - In practice, users will probably consistenly use either the `q', the `v',
;; or the plain variant (`vlist-cons' and `vlist-assoc' without any optional
;; argument), i.e., they will rarely explicitly pass a hash function or
;; equality predicate.
;; - In practice, users will probably consistenly use either the `q',
;; the `v', or the plain variant (`vlist-cons' and `vlist-assoc'
;; without any optional argument), i.e., they will rarely explicitly
;; pass a hash function or equality predicate.
(define (vhash? obj)
"Return true if @var{obj} is a hash list."
(and (vlist? obj)
(let ((base (vlist-base obj)))
(and base
(vector? (block-hash-table base))))))
(block-hash-table? (vlist-base obj))))
(define* (vhash-cons key value vhash #:optional (hash hash))
"Return a new hash list based on @var{vhash} where @var{key} is associated
with @var{value}. Use @var{hash} to compute @var{key}'s hash."
(let* ((key+value (cons key value))
(entry (cons key+value #f))
(vlist (block-cons entry vhash #t))
(base (vlist-base vlist))
(khash (hash key (block-size base))))
(let ((o (block-hash-table-ref base khash)))
(if o (set-cdr! entry o)))
(block-hash-table-set! base khash
(vlist-offset vlist))
vlist))
(assert-vlist vhash)
;; We should also assert that it is a hash table. Need to check the
;; performance impacts of that. Also, vlist-null is a valid hash
;; table, which does not pass vhash?. A bug, perhaps.
(let* ((vhash (block-cons (cons key value) vhash #t))
(base (vlist-base vhash))
(offset (vlist-offset vhash))
(size (block-size base))
(khash (hash key size))
(content (block-content base)))
(block-hash-table-add! content size khash offset)
vhash))
(define vhash-consq (cut vhash-cons <> <> <> hashq))
(define vhash-consv (cut vhash-cons <> <> <> hashv))
(define-inline (%vhash-fold* proc init key vhash equal? hash)
(define-inlinable (%vhash-fold* proc init key vhash equal? hash)
;; Fold over all the values associated with KEY in VHASH.
(define khash
(let ((size (block-size (vlist-base vhash))))
(and (> size 0) (hash key size))))
(define (visit-block base max-offset result)
(let* ((size (block-size base))
(content (block-content base))
(khash (hash key size)))
(let loop ((offset (block-hash-table-ref content size khash))
(result result))
(if offset
(loop (block-hash-table-next-offset content size offset)
(if (and (<= offset max-offset)
(equal? key (car (block-ref content offset))))
(proc (cdr (block-ref content offset)) result)
result))
(let ((next-block (block-base base)))
(if (> (block-size next-block) 0)
(visit-block next-block (block-offset base) result)
result))))))
(let loop ((base (vlist-base vhash))
(khash khash)
(offset (and khash
(block-hash-table-ref (vlist-base vhash)
khash)))
(max-offset (vlist-offset vhash))
(result init))
(let ((answer (and offset (block-ref base offset))))
(cond ((and (pair? answer)
(<= offset max-offset)
(let ((answer-key (caar answer)))
(equal? key answer-key)))
(let ((result (proc (cdar answer) result))
(next-offset (cdr answer)))
(loop base khash next-offset max-offset result)))
((and (pair? answer) (cdr answer))
=>
(lambda (next-offset)
(loop base khash next-offset max-offset result)))
(else
(let ((next-base (block-base base)))
(if (and next-base (> (block-size next-base) 0))
(let* ((khash (hash key (block-size next-base)))
(offset (block-hash-table-ref next-base khash)))
(loop next-base khash offset (block-offset base)
result))
result)))))))
(assert-vlist vhash)
(if (> (block-size (vlist-base vhash)) 0)
(visit-block (vlist-base vhash)
(vlist-offset vhash)
init)
init))
(define* (vhash-fold* proc init key vhash
#:optional (equal? equal?) (hash hash))
@ -480,39 +507,29 @@ value of @var{result} for the first call to @var{proc}."
"Same as @code{vhash-fold*}, but using @code{hashv} and @code{eqv?}."
(%vhash-fold* proc init key vhash eqv? hashv))
(define-inline (%vhash-assoc key vhash equal? hash)
(define-inlinable (%vhash-assoc key vhash equal? hash)
;; A specialization of `vhash-fold*' that stops when the first value
;; associated with KEY is found or when the end-of-list is reached. Inline to
;; make sure `vhash-assq' gets to use the `eq?' instruction instead of calling
;; the `eq?' subr.
(define khash
(let ((size (block-size (vlist-base vhash))))
(and (> size 0) (hash key size))))
(define (visit-block base max-offset)
(let* ((size (block-size base))
(content (block-content base))
(khash (hash key size)))
(let loop ((offset (block-hash-table-ref content size khash)))
(if offset
(if (and (<= offset max-offset)
(equal? key (car (block-ref content offset))))
(block-ref content offset)
(loop (block-hash-table-next-offset content size offset)))
(let ((next-block (block-base base)))
(and (> (block-size next-block) 0)
(visit-block next-block (block-offset base))))))))
(let loop ((base (vlist-base vhash))
(khash khash)
(offset (and khash
(block-hash-table-ref (vlist-base vhash)
khash)))
(max-offset (vlist-offset vhash)))
(let ((answer (and offset (block-ref base offset))))
(cond ((and (pair? answer)
(<= offset max-offset)
(let ((answer-key (caar answer)))
(equal? key answer-key)))
(car answer))
((and (pair? answer) (cdr answer))
=>
(lambda (next-offset)
(loop base khash next-offset max-offset)))
(else
(let ((next-base (block-base base)))
(and next-base
(> (block-size next-base) 0)
(let* ((khash (hash key (block-size next-base)))
(offset (block-hash-table-ref next-base khash)))
(loop next-base khash offset
(block-offset base))))))))))
(assert-vlist vhash)
(and (> (block-size (vlist-base vhash)) 0)
(visit-block (vlist-base vhash)
(vlist-offset vhash))))
(define* (vhash-assoc key vhash #:optional (equal? equal?) (hash hash))
"Return the first key/value pair from @var{vhash} whose key is equal to

29
module/language/tree-il/cse.scm
View file

@ -188,7 +188,7 @@
(/ (string-length (symbol->string (struct-layout x))) 2))
(define hash-bits (logcount most-positive-fixnum))
(define hash-depth 3)
(define hash-depth 4)
(define hash-width 3)
(define (hash-expression exp)
(define (hash-exp exp depth)
@ -348,29 +348,30 @@
(expressions-equal? exp exp*))
(_ #f)))
(define (unroll db from to)
(or (<= from to)
(match (vlist-ref db (1- from))
(define (unroll db base n)
(or (zero? n)
(match (vlist-ref db base)
(('lambda . h*)
;; See note in find-dominating-expression.
(and (not (depends-on-effects? effects &all-effects))
(unroll db (1- from) to)))
(unroll db (1+ base) (1- n))))
((#(exp* effects* ctx*) . h*)
(and (effects-commute? effects effects*)
(unroll db (1- from) to))))))
(unroll db (1+ base) (1- n)))))))
(let ((h (hash-expression exp)))
(and (effect-free? (exclude-effects effects &type-check))
(vhash-assoc exp env entry-matches? (hasher h))
(let ((env-len (vlist-length env)))
(let lp ((n 0) (db-len (vlist-length db)))
(let ((env-len (vlist-length env))
(db-len (vlist-length db)))
(let lp ((n 0) (m 0))
(and (< n env-len)
(match (vlist-ref env n)
((#(exp* name sym db-len*) . h*)
(and (unroll db db-len db-len*)
(and (unroll db m (- db-len db-len*))
(if (and (= h h*) (expressions-equal? exp* exp))
(make-lexical-ref (tree-il-src exp) name sym)
(lp (1+ n) db-len*)))))))))))
(lp (1+ n) (- db-len db-len*))))))))))))
(define (intersection db+ db-)
(vhash-fold-right
@ -409,8 +410,12 @@
(logior &zero-values
&allocation)))
(has-dominating-effect? exp effects db)))
(log 'elide ctx (unparse-tree-il exp))
(values (make-void #f) db*))
(cond
((void? exp)
(values exp db*))
(else
(log 'elide ctx (unparse-tree-il exp))
(values (make-void #f) db*))))
((and (boolean-valued-expression? exp ctx)
(find-dominating-test exp effects db))
=> (lambda (exp)

23
module/language/tree-il/effects.scm
View file

@ -62,9 +62,9 @@
((_ all name ...)
(with-syntax (((n ...) (iota (length #'(name ...)))))
#'(begin
(define name (ash 1 (* n 2)))
(define-syntax name (identifier-syntax (ash 1 (* n 2))))
...
(define all (logior name ...))))))))
(define-syntax all (identifier-syntax (logior name ...)))))))))
;; Here we define the effects, indicating the meaning of the effect.
;;
@ -121,7 +121,7 @@
;; subexpression (+ x y).
&type-check)
(define &no-effects 0)
(define-syntax &no-effects (identifier-syntax 0))
;; Definite bailout is an oddball effect. Since it indicates that an
;; expression definitely causes bailout, it's not in the set of effects
@ -130,15 +130,16 @@
;; cause an outer expression to include &definite-bailout in its
;; effects. For that reason we have to treat it specially.
;;
(define &all-effects-but-bailout
(logand &all-effects (lognot &definite-bailout)))
(define-syntax &all-effects-but-bailout
(identifier-syntax
(logand &all-effects (lognot &definite-bailout))))
(define (cause effect)
(define-inlinable (cause effect)
(ash effect 1))
(define (&depends-on a)
(define-inlinable (&depends-on a)
(logand a &all-effects))
(define (&causes a)
(define-inlinable (&causes a)
(logand a (cause &all-effects)))
(define (exclude-effects effects exclude)
@ -148,12 +149,12 @@
(define (constant? effects)
(zero? effects))
(define (depends-on-effects? x effects)
(define-inlinable (depends-on-effects? x effects)
(not (zero? (logand (&depends-on x) effects))))
(define (causes-effects? x effects)
(define-inlinable (causes-effects? x effects)
(not (zero? (logand (&causes x) (cause effects)))))
(define (effects-commute? a b)
(define-inlinable (effects-commute? a b)
(and (not (causes-effects? a (&depends-on b)))
(not (causes-effects? b (&depends-on a)))))

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

@ -1,6 +1,6 @@
;;; Tree-il optimizer
;; Copyright (C) 2009, 2011 Free Software Foundation, Inc.
;; Copyright (C) 2009, 2011, 2012 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@ -22,6 +22,7 @@
#:use-module (language tree-il)
#:use-module (language tree-il primitives)
#:use-module (language tree-il peval)
#:use-module (language tree-il cse)
#:use-module (language tree-il fix-letrec)
#:use-module (language tree-il debug)
#:use-module (ice-9 match)
@ -32,8 +33,15 @@
((#:partial-eval? #f _ ...)
;; Disable partial evaluation.
(lambda (x e) x))
(_ peval))))
(_ peval)))
(cse (match (memq #:cse? opts)
((#:cse? #f _ ...)
;; Disable CSE.
(lambda (x) x))
(_ cse))))
(fix-letrec!
(verify-tree-il
(peval (expand-primitives! (resolve-primitives! x env))
env)))))
(cse
(verify-tree-il
(peval (expand-primitives! (resolve-primitives! x env))
env)))))))

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

@ -286,7 +286,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)
@ -296,19 +296,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)))
(and source (not (var-set? var))) #f #f
(and (not (var-set? var)) alias))))
(define (make-bound-operands vars syms sources visit)
(map (lambda (x y z) (make-operand x y z visit)) vars syms sources))
(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))
@ -342,7 +350,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)
@ -701,6 +714,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)
@ -793,11 +811,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
@ -823,7 +867,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))

15
module/language/tree-il/primitives.scm
View file

@ -47,7 +47,7 @@
memq memv
= < > <= >= zero?
+ * - / 1- 1+ quotient remainder modulo
ash logand logior logxor
ash logand logior logxor lognot
not
pair? null? list? symbol? vector? string? struct? number? char? nil?
@ -149,6 +149,7 @@
`(values
eq? eqv? equal?
= < > <= >= zero?
ash logand logior logxor lognot
+ * - / 1- 1+ quotient remainder modulo
not
pair? null? list? symbol? vector? struct? string? number? char? nil
@ -390,6 +391,18 @@
(x) (/ 1 x)
(x y z . rest) (/ x (* y z . rest)))
(define-primitive-expander logior
() 0
(x) (logior x 0)
(x y) (logior x y)
(x y z . rest) (logior x (logior y z . rest)))
(define-primitive-expander logand
() -1
(x) (logand x -1)
(x y) (logand x y)
(x y z . rest) (logand x (logand y z . rest)))
(define-primitive-expander caar (x) (car (car x)))
(define-primitive-expander cadr (x) (car (cdr x)))
(define-primitive-expander cdar (x) (cdr (car x)))

6
module/oop/goops/dispatch.scm
View file

@ -1,4 +1,4 @@
;;;; Copyright (C) 1999, 2000, 2001, 2003, 2006, 2009 Free Software Foundation, Inc.
;;;; Copyright (C) 1999, 2000, 2001, 2003, 2006, 2009, 2012 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@ -178,7 +178,9 @@
'())
(acons gf gf-sym '()))))
(define (comp exp vals)
(let ((p ((@ (system base compile) compile) exp #:env *dispatch-module*)))
(let ((p ((@ (system base compile) compile) exp
#:env *dispatch-module*
#:opts '(#:partial-eval? #f #:cse? #f))))
(apply p vals)))
;; kick it.

16
test-suite/tests/peval.test
View file

@ -998,4 +998,18 @@
(pass-if-peval
(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 _)))))

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

@ -148,7 +148,7 @@
(lexical #t #f ref 0) (call return 1)
(unbind)))
(assert-tree-il->glil without-partial-evaluation
(assert-tree-il->glil with-options (#:partial-eval? #f #:cse? #f)
(let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
(program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #f 0)) (lexical #t #f set 0)