mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 06:41:13 +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 (define block-growth-factor
(make-fluid 2)) (make-fluid 2))
(define-syntax-rule (define-inline (name formals ...) body ...) (define-inlinable (make-block base offset size hash-tab?)
;; Work around the lack of an inliner. ;; Return a block (and block descriptor) of SIZE elements pointing to
(define-syntax name ;; BASE at OFFSET. If HASH-TAB? is true, we also reserve space for a
(syntax-rules () ;; "hash table". Note: We use `next-free' instead of `last-used' as
((_ formals ...) ;; suggested by Bagwell.
(begin body ...))))) (if hash-tab?
(vector (make-vector (* size 3) #f)
(define-inline (make-block base offset size hash-tab?) base offset size 0)
;; Return a block (and block descriptor) of SIZE elements pointing to BASE (vector (make-vector size)
;; at OFFSET. If HASH-TAB? is true, a "hash table" is also added. base offset size 0)))
;; 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-syntax-rule (define-block-accessor name index) (define-syntax-rule (define-block-accessor name index)
(define-inline (name block) (define-inlinable (name block)
(vector-ref block index))) (vector-ref block index)))
(define-block-accessor block-content 0) (define-block-accessor block-content 0)
@ -96,33 +89,51 @@
(define-block-accessor block-offset 2) (define-block-accessor block-offset 2)
(define-block-accessor block-size 3) (define-block-accessor block-size 3)
(define-block-accessor block-next-free 4) (define-block-accessor block-next-free 4)
(define-block-accessor block-hash-table 5)
(define-inline (increment-block-next-free! block) (define-inlinable (block-hash-table? block)
(vector-set! block 4 (< (block-size block) (vector-length (block-content block))))
(+ (block-next-free block) 1)))
(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. ;; This is not thread-safe. To fix it, see Section 2.8 of the paper.
(let ((offset (block-next-free block))) (and (< offset (block-size block))
(increment-block-next-free! block) (= offset (block-next-free block))
(vector-set! (block-content block) offset value) (begin
#t)) (set-block-next-free! block (1+ offset))
(vector-set! (block-content block) offset value)
#t)))
(define-inline (block-ref block offset) ;; Return the item at slot OFFSET.
(vector-ref (block-content block) offset)) (define-inlinable (block-ref content offset)
(vector-ref content offset))
(define-inline (block-ref* block offset) ;; Return the offset of the next item in the hash bucket, after the one
(let ((v (block-ref block offset))) ;; at OFFSET.
(if (block-hash-table block) (define-inlinable (block-hash-table-next-offset content size offset)
(car v) ;; hide the vhash link (vector-ref content (+ size size offset)))
v)))
(define-inline (block-hash-table-ref block offset) ;; Save the offset of the next item in the hash bucket, after the one
(vector-ref (block-hash-table block) offset)) ;; 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) ;; Returns the index of the last entry stored in CONTENT with
(vector-set! (block-hash-table block) offset value)) ;; 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 (define block-null
;; The null block. ;; The null block.
@ -149,13 +160,10 @@
(lambda (vl port) (lambda (vl port)
(cond ((vlist-null? vl) (cond ((vlist-null? vl)
(format port "#<vlist ()>")) (format port "#<vlist ()>"))
((block-hash-table (vlist-base vl)) ((vhash? vl)
(format port "#<vhash ~x ~a pairs>" (format port "#<vhash ~x ~a pairs>"
(object-address vl) (object-address vl)
(vhash-fold (lambda (k v r) (vlist-length vl)))
(+ 1 r))
0
vl)))
(else (else
(format port "#<vlist ~a>" (format port "#<vlist ~a>"
(vlist->list vl)))))) (vlist->list vl))))))
@ -165,42 +173,61 @@
;; The empty vlist. ;; The empty vlist.
(make-vlist block-null 0)) (make-vlist block-null 0))
(define-inline (block-cons item vlist hash-tab?) ;; Asserting that something is a vlist is actually a win if your next
(let loop ((base (vlist-base vlist)) ;; step is to call record accessors, because that causes CSE to
(offset (+ 1 (vlist-offset vlist)))) ;; eliminate the type checks in those accessors.
(if (and (< offset (block-size base)) ;;
(= offset (block-next-free base)) (define-inlinable (assert-vlist val)
(block-append! base item)) (unless (vlist? val)
(make-vlist base offset) (throw 'wrong-type-arg
(let ((size (cond ((eq? base block-null) 1) #f
((< offset (block-size base)) "Not a vlist: ~S"
;; new vlist head (list val)
1) (list val))))
(else
(* (fluid-ref block-growth-factor) (define-inlinable (block-cons item vlist hash-tab?)
(block-size base)))))) (let ((base (vlist-base vlist))
;; Prepend a new block pointing to BASE. (offset (1+ (vlist-offset vlist))))
(loop (make-block base (- offset 1) size hash-tab?) (cond
0))))) ((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) (define (vlist-cons item vlist)
"Return a new vlist with @var{item} as its head and @var{vlist} as its "Return a new vlist with @var{item} as its head and @var{vlist} as its
tail." tail."
;; Note: Calling `vlist-cons' on a vhash will not do the right thing: it ;; Note: Although the result of `vlist-cons' on a vhash is a valid
;; doesn't box ITEM so that it can have the hidden "next" link used by ;; vlist, it is not a valid vhash. The new item does not get a hash
;; vhash items, and it passes `#f' as the HASH-TAB? argument to ;; table entry. If we allocate a new block, the new block will not
;; `block-cons'. However, inserting all the checks here has an important ;; have a hash table. Perhaps we can do something more sensible here,
;; performance penalty, hence this choice. ;; but this is a hot function, so there are performance impacts.
(assert-vlist vlist)
(block-cons item vlist #f)) (block-cons item vlist #f))
(define (vlist-head vlist) (define (vlist-head vlist)
"Return the head of @var{vlist}." "Return the head of @var{vlist}."
(assert-vlist vlist)
(let ((base (vlist-base vlist)) (let ((base (vlist-base vlist))
(offset (vlist-offset vlist))) (offset (vlist-offset vlist)))
(block-ref* base offset))) (block-ref (block-content base) offset)))
(define (vlist-tail vlist) (define (vlist-tail vlist)
"Return the tail of @var{vlist}." "Return the tail of @var{vlist}."
(assert-vlist vlist)
(let ((base (vlist-base vlist)) (let ((base (vlist-base vlist))
(offset (vlist-offset vlist))) (offset (vlist-offset vlist)))
(if (> offset 0) (if (> offset 0)
@ -210,6 +237,7 @@ tail."
(define (vlist-null? vlist) (define (vlist-null? vlist)
"Return true if @var{vlist} is empty." "Return true if @var{vlist} is empty."
(assert-vlist vlist)
(let ((base (vlist-base vlist))) (let ((base (vlist-base vlist)))
(and (not (block-base base)) (and (not (block-base base))
(= 0 (block-size base))))) (= 0 (block-size base)))))
@ -226,6 +254,7 @@ tail."
(define (vlist-fold proc init vlist) (define (vlist-fold proc init vlist)
"Fold over @var{vlist}, calling @var{proc} for each element." "Fold over @var{vlist}, calling @var{proc} for each element."
;; FIXME: Handle multiple lists. ;; FIXME: Handle multiple lists.
(assert-vlist vlist)
(let loop ((base (vlist-base vlist)) (let loop ((base (vlist-base vlist))
(offset (vlist-offset vlist)) (offset (vlist-offset vlist))
(result init)) (result init))
@ -235,19 +264,18 @@ tail."
(done? (< next 0))) (done? (< next 0)))
(loop (if done? (block-base base) base) (loop (if done? (block-base base) base)
(if done? (block-offset base) next) (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) (define (vlist-fold-right proc init vlist)
"Fold over @var{vlist}, calling @var{proc} for each element, starting from "Fold over @var{vlist}, calling @var{proc} for each element, starting from
the last element." the last element."
(define len (vlist-length vlist)) (assert-vlist vlist)
(let loop ((index (1- (vlist-length vlist)))
(let loop ((index (1- len))
(result init)) (result init))
(if (< index 0) (if (< index 0)
result result
(loop (1- index) (loop (1- index)
(proc (vlist-ref vlist index) result))))) (proc (vlist-ref vlist index) result)))))
(define (vlist-reverse vlist) (define (vlist-reverse vlist)
"Return a new @var{vlist} whose content are those of @var{vlist} in reverse "Return a new @var{vlist} whose content are those of @var{vlist} in reverse
@ -267,11 +295,12 @@ order."
(define (vlist-ref vlist index) (define (vlist-ref vlist index)
"Return the element at index @var{index} in @var{vlist}." "Return the element at index @var{index} in @var{vlist}."
(assert-vlist vlist)
(let loop ((index index) (let loop ((index index)
(base (vlist-base vlist)) (base (vlist-base vlist))
(offset (vlist-offset vlist))) (offset (vlist-offset vlist)))
(if (<= index offset) (if (<= index offset)
(block-ref* base (- offset index)) (block-ref (block-content base) (- offset index))
(loop (- index offset 1) (loop (- index offset 1)
(block-base base) (block-base base)
(block-offset base))))) (block-offset base)))))
@ -279,6 +308,7 @@ order."
(define (vlist-drop vlist count) (define (vlist-drop vlist count)
"Return a new vlist that does not contain the @var{count} first elements of "Return a new vlist that does not contain the @var{count} first elements of
@var{vlist}." @var{vlist}."
(assert-vlist vlist)
(let loop ((count count) (let loop ((count count)
(base (vlist-base vlist)) (base (vlist-base vlist))
(offset (vlist-offset vlist))) (offset (vlist-offset vlist)))
@ -319,6 +349,7 @@ satisfy @var{pred}."
(define (vlist-length vlist) (define (vlist-length vlist)
"Return the length of @var{vlist}." "Return the length of @var{vlist}."
(assert-vlist vlist)
(let loop ((base (vlist-base vlist)) (let loop ((base (vlist-base vlist))
(len (vlist-offset vlist))) (len (vlist-offset vlist)))
(if (eq? base block-null) (if (eq? base block-null)
@ -371,98 +402,94 @@ details."
;; associated with K1 and K2, respectively. The resulting layout is a ;; associated with K1 and K2, respectively. The resulting layout is a
;; follows: ;; follows:
;; ;;
;; ,--------------------. ;; ,--------------------.
;; | ,-> (K1 . V1) ---. | ;; 0| ,-> (K1 . V1) | Vlist array
;; | | | | ;; 1| | |
;; | | (K2 . V2) <--' | ;; 2| | (K2 . V2) |
;; | | | ;; 3| | |
;; +-|------------------+ ;; size +-|------------------+
;; | | | ;; 0| | | Hash table
;; | | | ;; 1| | |
;; | `-- O <---------------H ;; 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 ;; The backing store for the vhash is partitioned into three areas: the
;; `block-hash-table'; the other half is the data part. O is the offset of ;; vlist part, the hash table part, and the chain links part. In this
;; the first value associated with a key that hashes to H in the data part. ;; example we have a hash H which, when indexed into the hash table
;; The (K1 . V1) pair has a "hidden" link to the (K2 . V2) pair; hiding the ;; part, indicates that a value with this hash can be found at offset 0
;; link is handled by `block-ref'. ;; 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
;; This API potentially requires users to repeat which hash function and which ;; with this hash value, or #f if we reached the end of the chain.
;; 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 ;; This API potentially requires users to repeat which hash function and
;; is undesirable, as argued in http://savannah.gnu.org/bugs/?22159 . OTOH, two ;; which equality predicate to use. This can lead to unpredictable
;; arguments can be made in favor of this API: ;; 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. ;; - It's consistent with how alists are handled in SRFI-1.
;; ;;
;; - In practice, users will probably consistenly use either the `q', the `v', ;; - In practice, users will probably consistenly use either the `q',
;; or the plain variant (`vlist-cons' and `vlist-assoc' without any optional ;; the `v', or the plain variant (`vlist-cons' and `vlist-assoc'
;; argument), i.e., they will rarely explicitly pass a hash function or ;; without any optional argument), i.e., they will rarely explicitly
;; equality predicate. ;; pass a hash function or equality predicate.
(define (vhash? obj) (define (vhash? obj)
"Return true if @var{obj} is a hash list." "Return true if @var{obj} is a hash list."
(and (vlist? obj) (and (vlist? obj)
(let ((base (vlist-base obj))) (block-hash-table? (vlist-base obj))))
(and base
(vector? (block-hash-table base))))))
(define* (vhash-cons key value vhash #:optional (hash hash)) (define* (vhash-cons key value vhash #:optional (hash hash))
"Return a new hash list based on @var{vhash} where @var{key} is associated "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." with @var{value}. Use @var{hash} to compute @var{key}'s hash."
(let* ((key+value (cons key value)) (assert-vlist vhash)
(entry (cons key+value #f)) ;; We should also assert that it is a hash table. Need to check the
(vlist (block-cons entry vhash #t)) ;; performance impacts of that. Also, vlist-null is a valid hash
(base (vlist-base vlist)) ;; table, which does not pass vhash?. A bug, perhaps.
(khash (hash key (block-size base)))) (let* ((vhash (block-cons (cons key value) vhash #t))
(base (vlist-base vhash))
(let ((o (block-hash-table-ref base khash))) (offset (vlist-offset vhash))
(if o (set-cdr! entry o))) (size (block-size base))
(khash (hash key size))
(block-hash-table-set! base khash (content (block-content base)))
(vlist-offset vlist)) (block-hash-table-add! content size khash offset)
vhash))
vlist))
(define vhash-consq (cut vhash-cons <> <> <> hashq)) (define vhash-consq (cut vhash-cons <> <> <> hashq))
(define vhash-consv (cut vhash-cons <> <> <> hashv)) (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. ;; Fold over all the values associated with KEY in VHASH.
(define khash (define (visit-block base max-offset result)
(let ((size (block-size (vlist-base vhash)))) (let* ((size (block-size base))
(and (> size 0) (hash key size)))) (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)) (assert-vlist vhash)
(khash khash) (if (> (block-size (vlist-base vhash)) 0)
(offset (and khash (visit-block (vlist-base vhash)
(block-hash-table-ref (vlist-base vhash) (vlist-offset vhash)
khash))) init)
(max-offset (vlist-offset vhash)) init))
(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)))))))
(define* (vhash-fold* proc init key vhash (define* (vhash-fold* proc init key vhash
#:optional (equal? equal?) (hash hash)) #: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?}." "Same as @code{vhash-fold*}, but using @code{hashv} and @code{eqv?}."
(%vhash-fold* proc init key vhash eqv? hashv)) (%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 ;; 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 ;; 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 ;; make sure `vhash-assq' gets to use the `eq?' instruction instead of calling
;; the `eq?' subr. ;; the `eq?' subr.
(define khash (define (visit-block base max-offset)
(let ((size (block-size (vlist-base vhash)))) (let* ((size (block-size base))
(and (> size 0) (hash key size)))) (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)) (assert-vlist vhash)
(khash khash) (and (> (block-size (vlist-base vhash)) 0)
(offset (and khash (visit-block (vlist-base vhash)
(block-hash-table-ref (vlist-base vhash) (vlist-offset 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))))))))))
(define* (vhash-assoc key vhash #:optional (equal? equal?) (hash hash)) (define* (vhash-assoc key vhash #:optional (equal? equal?) (hash hash))
"Return the first key/value pair from @var{vhash} whose key is equal to "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)) (/ (string-length (symbol->string (struct-layout x))) 2))
(define hash-bits (logcount most-positive-fixnum)) (define hash-bits (logcount most-positive-fixnum))
(define hash-depth 3) (define hash-depth 4)
(define hash-width 3) (define hash-width 3)
(define (hash-expression exp) (define (hash-expression exp)
(define (hash-exp exp depth) (define (hash-exp exp depth)
@ -348,29 +348,30 @@
(expressions-equal? exp exp*)) (expressions-equal? exp exp*))
(_ #f))) (_ #f)))
(define (unroll db from to) (define (unroll db base n)
(or (<= from to) (or (zero? n)
(match (vlist-ref db (1- from)) (match (vlist-ref db base)
(('lambda . h*) (('lambda . h*)
;; See note in find-dominating-expression. ;; See note in find-dominating-expression.
(and (not (depends-on-effects? effects &all-effects)) (and (not (depends-on-effects? effects &all-effects))
(unroll db (1- from) to))) (unroll db (1+ base) (1- n))))
((#(exp* effects* ctx*) . h*) ((#(exp* effects* ctx*) . h*)
(and (effects-commute? effects effects*) (and (effects-commute? effects effects*)
(unroll db (1- from) to)))))) (unroll db (1+ base) (1- n)))))))
(let ((h (hash-expression exp))) (let ((h (hash-expression exp)))
(and (effect-free? (exclude-effects effects &type-check)) (and (effect-free? (exclude-effects effects &type-check))
(vhash-assoc exp env entry-matches? (hasher h)) (vhash-assoc exp env entry-matches? (hasher h))
(let ((env-len (vlist-length env))) (let ((env-len (vlist-length env))
(let lp ((n 0) (db-len (vlist-length db))) (db-len (vlist-length db)))
(let lp ((n 0) (m 0))
(and (< n env-len) (and (< n env-len)
(match (vlist-ref env n) (match (vlist-ref env n)
((#(exp* name sym db-len*) . h*) ((#(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)) (if (and (= h h*) (expressions-equal? exp* exp))
(make-lexical-ref (tree-il-src exp) name sym) (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-) (define (intersection db+ db-)
(vhash-fold-right (vhash-fold-right
@ -409,8 +410,12 @@
(logior &zero-values (logior &zero-values
&allocation))) &allocation)))
(has-dominating-effect? exp effects db))) (has-dominating-effect? exp effects db)))
(log 'elide ctx (unparse-tree-il exp)) (cond
(values (make-void #f) db*)) ((void? exp)
(values exp db*))
(else
(log 'elide ctx (unparse-tree-il exp))
(values (make-void #f) db*))))
((and (boolean-valued-expression? exp ctx) ((and (boolean-valued-expression? exp ctx)
(find-dominating-test exp effects db)) (find-dominating-test exp effects db))
=> (lambda (exp) => (lambda (exp)

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

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

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

@ -1,6 +1,6 @@
;;; Tree-il optimizer ;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; 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)
#:use-module (language tree-il primitives) #:use-module (language tree-il primitives)
#:use-module (language tree-il peval) #:use-module (language tree-il peval)
#:use-module (language tree-il cse)
#:use-module (language tree-il fix-letrec) #:use-module (language tree-il fix-letrec)
#:use-module (language tree-il debug) #:use-module (language tree-il debug)
#:use-module (ice-9 match) #:use-module (ice-9 match)
@ -32,8 +33,15 @@
((#:partial-eval? #f _ ...) ((#:partial-eval? #f _ ...)
;; Disable partial evaluation. ;; Disable partial evaluation.
(lambda (x e) x)) (lambda (x e) x))
(_ peval)))) (_ peval)))
(cse (match (memq #:cse? opts)
((#:cse? #f _ ...)
;; Disable CSE.
(lambda (x) x))
(_ cse))))
(fix-letrec! (fix-letrec!
(verify-tree-il (verify-tree-il
(peval (expand-primitives! (resolve-primitives! x env)) (cse
env))))) (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> (define-record-type <operand>
(%make-operand var sym visit source visit-count residualize? (%make-operand var sym visit source visit-count residualize?
copyable? residual-value constant-value) copyable? residual-value constant-value alias-value)
operand? operand?
(var operand-var) (var operand-var)
(sym operand-sym) (sym operand-sym)
@ -296,19 +296,27 @@
(residualize? operand-residualize? set-operand-residualize?!) (residualize? operand-residualize? set-operand-residualize?!)
(copyable? operand-copyable? set-operand-copyable?!) (copyable? operand-copyable? set-operand-copyable?!)
(residual-value operand-residual-value %set-operand-residual-value!) (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 ;; Bind SYM to VAR, with value SOURCE. Unassigned bound operands are
;; considered copyable until we prove otherwise. If we have a source ;; considered copyable until we prove otherwise. If we have a source
;; expression, truncate it to one value. Copy propagation does not ;; expression, truncate it to one value. Copy propagation does not
;; work on multiply-valued expressions. ;; work on multiply-valued expressions.
(let ((source (and=> source truncate-values))) (let ((source (and=> source truncate-values)))
(%make-operand var sym visit source 0 #f (%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) (define* (make-bound-operands vars syms sources visit #:optional aliases)
(map (lambda (x y z) (make-operand x y z visit)) vars syms sources)) (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) (define (make-unbound-operands vars syms)
(map make-operand vars syms)) (map make-operand vars syms))
@ -342,7 +350,12 @@
(if (or counter (and (not effort-limit) (not size-limit))) (if (or counter (and (not effort-limit) (not size-limit)))
((%operand-visit op) (operand-source op) counter ctx) ((%operand-visit op) (operand-source op) counter ctx)
(let/ec k (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-visit op)
(operand-source op) (operand-source op)
(make-top-counter effort-limit size-limit abort 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) ((eq? ctx 'effect)
(log 'lexical-for-effect gensym) (log 'lexical-for-effect gensym)
(make-void #f)) (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) ((eq? ctx 'call)
;; Don't propagate copies if we are residualizing a call. ;; Don't propagate copies if we are residualizing a call.
(log 'residualize-lexical-call gensym op) (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) (set-operand-residualize?! op #t)
(make-lexical-set src name (operand-sym op) (for-value exp)))))) (make-lexical-set src name (operand-sym op) (for-value exp))))))
(($ <let> src names gensyms vals body) (($ <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)) (let* ((vars (map lookup-var gensyms))
(new (fresh-gensyms vars)) (new (fresh-gensyms vars))
(ops (make-bound-operands vars new vals (ops (make-bound-operands vars new vals
(lambda (exp counter ctx) (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)) (env (fold extend-env env gensyms ops))
(body (loop body env counter ctx))) (body (loop body env counter ctx)))
(cond (cond
@ -823,7 +867,9 @@ top-level bindings from ENV and return the resulting expression."
(($ <letrec> src in-order? names gensyms vals body) (($ <letrec> src in-order? names gensyms vals body)
;; Note the difference from the `let' case: here we use letrec* ;; Note the difference from the `let' case: here we use letrec*
;; so that the `visit' procedure for the new operands closes over ;; 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) (letrec* ((visit (lambda (exp counter ctx)
(loop exp env* counter ctx))) (loop exp env* counter ctx)))
(vars (map lookup-var gensyms)) (vars (map lookup-var gensyms))

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

@ -47,7 +47,7 @@
memq memv memq memv
= < > <= >= zero? = < > <= >= zero?
+ * - / 1- 1+ quotient remainder modulo + * - / 1- 1+ quotient remainder modulo
ash logand logior logxor ash logand logior logxor lognot
not not
pair? null? list? symbol? vector? string? struct? number? char? nil? pair? null? list? symbol? vector? string? struct? number? char? nil?
@ -149,6 +149,7 @@
`(values `(values
eq? eqv? equal? eq? eqv? equal?
= < > <= >= zero? = < > <= >= zero?
ash logand logior logxor lognot
+ * - / 1- 1+ quotient remainder modulo + * - / 1- 1+ quotient remainder modulo
not not
pair? null? list? symbol? vector? struct? string? number? char? nil pair? null? list? symbol? vector? struct? string? number? char? nil
@ -390,6 +391,18 @@
(x) (/ 1 x) (x) (/ 1 x)
(x y z . rest) (/ x (* y z . rest))) (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 caar (x) (car (car x)))
(define-primitive-expander cadr (x) (car (cdr x))) (define-primitive-expander cadr (x) (car (cdr x)))
(define-primitive-expander cdar (x) (cdr (car 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -178,7 +178,9 @@
'()) '())
(acons gf gf-sym '())))) (acons gf gf-sym '()))))
(define (comp exp vals) (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))) (apply p vals)))
;; kick it. ;; kick it.

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

@ -998,4 +998,18 @@
(pass-if-peval (pass-if-peval
(car '(1 2)) (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) (lexical #t #f ref 0) (call return 1)
(unbind))) (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))) (let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
(program () (std-prelude 0 1 #f) (label _) (program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #f 0)) (lexical #t #f set 0) (const 1) (bind (x #f 0)) (lexical #t #f set 0)