(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)
(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)
- ;; 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))
-
-(define-inline (block-ref block offset)
- (vector-ref (block-content block) 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)))
-
-(define-inline (block-hash-table-ref block offset)
- (vector-ref (block-hash-table block) offset))
+(define-inlinable (set-block-next-free! block next-free)
+ (vector-set! block 4 next-free))
-(define-inline (block-hash-table-set! block offset value)
- (vector-set! (block-hash-table block) offset value))
+(define-inlinable (block-append! block value offset)
+ ;; This is not thread-safe. To fix it, see Section 2.8 of the paper.
+ (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)))
+
+;; Return the item at slot OFFSET.
+(define-inlinable (block-ref content offset)
+ (vector-ref content offset))
+
+;; 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)))
+
+;; 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))
+
+;; 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.
(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))))))
;; 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)
(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)))))
(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))
(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
(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)))))
(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)))
(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)
;; 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 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.
;;
-;; 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:
+;; 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))))
-
- (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)))))))
+ (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))))))
+
+ (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))
"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))))
-
- (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))))))))))
+ (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))))))))
+
+ (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
;;
(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)
(residualize? operand-residualize? set-operand-residualize?!)
(copyable? operand-copyable? set-operand-copyable?!)
(residual-value operand-residual-value %set-operand-residual-value!)
- (constant-value operand-constant-value set-operand-constant-value!))
+ (constant-value operand-constant-value set-operand-constant-value!)
+ (alias-value operand-alias-value set-operand-alias-value!))
-(define* (make-operand var sym #:optional source visit)
+(define* (make-operand var sym #:optional source visit alias)
;; Bind SYM to VAR, with value SOURCE. Unassigned bound operands are
;; considered copyable until we prove otherwise. If we have a source
;; expression, truncate it to one value. Copy propagation does not
;; work on multiply-valued expressions.
(let ((source (and=> source truncate-values)))
(%make-operand var sym visit source 0 #f
- (and source (not (var-set? var))) #f #f)))
-
-(define (make-bound-operands vars syms sources visit)
- (map (lambda (x y z) (make-operand x y z visit)) vars syms sources))
+ (and source (not (var-set? var))) #f #f
+ (and (not (var-set? var)) alias))))
+
+(define* (make-bound-operands vars syms sources visit #:optional aliases)
+ (if aliases
+ (map (lambda (name sym source alias)
+ (make-operand name sym source visit alias))
+ vars syms sources aliases)
+ (map (lambda (name sym source)
+ (make-operand name sym source visit #f))
+ vars syms sources)))
(define (make-unbound-operands vars syms)
(map make-operand vars syms))
(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)
((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)
(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
(($ <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))
HCoop / bpt / guile.git / commitdiff