1 ;;; -*- mode: scheme; coding: utf-8; -*-
3 ;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
5 ;;; This library is free software; you can redistribute it and/or
6 ;;; modify it under the terms of the GNU Lesser General Public
7 ;;; License as published by the Free Software Foundation; either
8 ;;; version 3 of the License, or (at your option) any later version.
10 ;;; This library is distributed in the hope that it will be useful,
11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;; Lesser General Public License for more details.
15 ;;; You should have received a copy of the GNU Lesser General Public
16 ;;; License along with this library; if not, write to the Free Software
17 ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
19 (define-module (ice-9 vlist)
20 #:use-module (srfi srfi-1)
21 #:use-module (srfi srfi-9)
22 #:use-module (srfi srfi-9 gnu)
23 #:use-module (srfi srfi-26)
24 #:use-module (ice-9 format)
26 #:export (vlist? vlist-cons vlist-head vlist-tail vlist-null?
27 vlist-null list->vlist vlist-ref vlist-drop vlist-take
28 vlist-length vlist-fold vlist-fold-right vlist-map
29 vlist-unfold vlist-unfold-right vlist-append
30 vlist-reverse vlist-filter vlist-delete vlist->list
34 vhash? vhash-cons vhash-consq vhash-consv
35 vhash-assoc vhash-assq vhash-assv
36 vhash-delete vhash-delq vhash-delv
37 vhash-fold vhash-fold-right
38 vhash-fold* vhash-foldq* vhash-foldv*
41 ;;; Author: Ludovic Courtès <ludo@gnu.org>
45 ;;; This module provides an implementations of vlists, a functional list-like
46 ;;; data structure described by Phil Bagwell in "Fast Functional Lists,
47 ;;; Hash-Lists, Dequeues and Variable-Length Arrays", EPFL Technical Report,
50 ;;; The idea is to store vlist elements in increasingly large contiguous blocks
51 ;;; (implemented as vectors here). These blocks are linked to one another using
52 ;;; a pointer to the next block (called `block-base' here) and an offset within
53 ;;; that block (`block-offset' here). The size of these blocks form a geometric
54 ;;; series with ratio `block-growth-factor'.
56 ;;; In the best case (e.g., using a vlist returned by `list->vlist'),
57 ;;; elements from the first half of an N-element vlist are accessed in O(1)
58 ;;; (assuming `block-growth-factor' is 2), and `vlist-length' takes only
59 ;;; O(ln(N)). Furthermore, the data structure improves data locality since
60 ;;; vlist elements are adjacent, which plays well with caches.
66 ;;; VList Blocks and Block Descriptors.
69 (define block-growth-factor
72 (define-inlinable (make-block base offset size hash-tab?)
73 ;; Return a block (and block descriptor) of SIZE elements pointing to
74 ;; BASE at OFFSET. If HASH-TAB? is true, we also reserve space for a
75 ;; "hash table". Note: We use `next-free' instead of `last-used' as
76 ;; suggested by Bagwell.
78 (vector (make-vector (* size 3) #f)
80 (vector (make-vector size)
83 (define-syntax-rule (define-block-accessor name index)
84 (define-inlinable (name block)
85 (vector-ref block index)))
87 (define-block-accessor block-content 0)
88 (define-block-accessor block-base 1)
89 (define-block-accessor block-offset 2)
90 (define-block-accessor block-size 3)
91 (define-block-accessor block-next-free 4)
93 (define-inlinable (block-hash-table? block)
94 (< (block-size block) (vector-length (block-content block))))
96 (define-inlinable (set-block-next-free! block next-free)
97 (vector-set! block 4 next-free))
99 (define-inlinable (block-append! block value offset)
100 ;; This is not thread-safe. To fix it, see Section 2.8 of the paper.
101 (and (< offset (block-size block))
102 (= offset (block-next-free block))
104 (set-block-next-free! block (1+ offset))
105 (vector-set! (block-content block) offset value)
108 ;; Return the item at slot OFFSET.
109 (define-inlinable (block-ref content offset)
110 (vector-ref content offset))
112 ;; Return the offset of the next item in the hash bucket, after the one
114 (define-inlinable (block-hash-table-next-offset content size offset)
115 (vector-ref content (+ size size offset)))
117 ;; Save the offset of the next item in the hash bucket, after the one
119 (define-inlinable (block-hash-table-set-next-offset! content size offset
121 (vector-set! content (+ size size offset) next-offset))
123 ;; Returns the index of the last entry stored in CONTENT with
124 ;; SIZE-modulo hash value KHASH.
125 (define-inlinable (block-hash-table-ref content size khash)
126 (vector-ref content (+ size khash)))
128 (define-inlinable (block-hash-table-set! content size khash offset)
129 (vector-set! content (+ size khash) offset))
131 ;; Add hash table information for the item recently added at OFFSET,
132 ;; with SIZE-modulo hash KHASH.
133 (define-inlinable (block-hash-table-add! content size khash offset)
134 (block-hash-table-set-next-offset! content size offset
135 (block-hash-table-ref content size khash))
136 (block-hash-table-set! content size khash offset))
140 (make-block #f 0 0 #f))
147 (define-record-type <vlist>
148 ;; A vlist is just a base+offset pair pointing to a block.
150 ;; XXX: Allocating a <vlist> record in addition to the block at each
151 ;; `vlist-cons' call is inefficient. However, Bagwell's hack to avoid it
152 ;; (Section 2.2) would require GC_ALL_INTERIOR_POINTERS, which would be a
153 ;; performance hit for everyone.
154 (make-vlist base offset)
157 (offset vlist-offset))
159 (set-record-type-printer! <vlist>
161 (cond ((vlist-null? vl)
162 (format port "#<vlist ()>"))
164 (format port "#<vhash ~x ~a pairs>"
168 (format port "#<vlist ~a>"
169 (vlist->list vl))))))
174 (make-vlist block-null 0))
176 ;; Asserting that something is a vlist is actually a win if your next
177 ;; step is to call record accessors, because that causes CSE to
178 ;; eliminate the type checks in those accessors.
180 (define-inlinable (assert-vlist val)
182 (throw 'wrong-type-arg
188 (define-inlinable (block-cons item vlist hash-tab?)
189 (let ((base (vlist-base vlist))
190 (offset (1+ (vlist-offset vlist))))
192 ((block-append! base item offset)
193 ;; Fast path: We added the item directly to the block.
194 (make-vlist base offset))
196 ;; Slow path: Allocate a new block.
197 (let* ((size (block-size base))
203 ((< offset size) 1) ;; new vlist head
204 (else (* (fluid-ref block-growth-factor) size)))
206 (set-block-next-free! base 1)
207 (vector-set! (block-content base) 0 item)
208 (make-vlist base 0))))))
210 (define (vlist-cons item vlist)
211 "Return a new vlist with ITEM as its head and VLIST as its
213 ;; Note: Although the result of `vlist-cons' on a vhash is a valid
214 ;; vlist, it is not a valid vhash. The new item does not get a hash
215 ;; table entry. If we allocate a new block, the new block will not
216 ;; have a hash table. Perhaps we can do something more sensible here,
217 ;; but this is a hot function, so there are performance impacts.
219 (block-cons item vlist #f))
221 (define (vlist-head vlist)
222 "Return the head of VLIST."
224 (let ((base (vlist-base vlist))
225 (offset (vlist-offset vlist)))
226 (block-ref (block-content base) offset)))
228 (define (vlist-tail vlist)
229 "Return the tail of VLIST."
231 (let ((base (vlist-base vlist))
232 (offset (vlist-offset vlist)))
234 (make-vlist base (- offset 1))
235 (make-vlist (block-base base)
236 (block-offset base)))))
238 (define (vlist-null? vlist)
239 "Return true if VLIST is empty."
241 (let ((base (vlist-base vlist)))
242 (and (not (block-base base))
243 (= 0 (block-size base)))))
250 (define (list->vlist lst)
251 "Return a new vlist whose contents correspond to LST."
252 (vlist-reverse (fold vlist-cons vlist-null lst)))
254 (define (vlist-fold proc init vlist)
255 "Fold over VLIST, calling PROC for each element."
256 ;; FIXME: Handle multiple lists.
258 (let loop ((base (vlist-base vlist))
259 (offset (vlist-offset vlist))
261 (if (eq? base block-null)
263 (let* ((next (- offset 1))
265 (loop (if done? (block-base base) base)
266 (if done? (block-offset base) next)
267 (proc (block-ref (block-content base) offset) result))))))
269 (define (vlist-fold-right proc init vlist)
270 "Fold over VLIST, calling PROC for each element, starting from
273 (let loop ((index (1- (vlist-length vlist)))
278 (proc (vlist-ref vlist index) result)))))
280 (define (vlist-reverse vlist)
281 "Return a new VLIST whose content are those of VLIST in reverse
283 (vlist-fold vlist-cons vlist-null vlist))
285 (define (vlist-map proc vlist)
286 "Map PROC over the elements of VLIST and return a new vlist."
287 (vlist-fold (lambda (item result)
288 (vlist-cons (proc item) result))
290 (vlist-reverse vlist)))
292 (define (vlist->list vlist)
293 "Return a new list whose contents match those of VLIST."
294 (vlist-fold-right cons '() vlist))
296 (define (vlist-ref vlist index)
297 "Return the element at index INDEX in VLIST."
299 (let loop ((index index)
300 (base (vlist-base vlist))
301 (offset (vlist-offset vlist)))
302 (if (<= index offset)
303 (block-ref (block-content base) (- offset index))
304 (loop (- index offset 1)
306 (block-offset base)))))
308 (define (vlist-drop vlist count)
309 "Return a new vlist that does not contain the COUNT first elements of
312 (let loop ((count count)
313 (base (vlist-base vlist))
314 (offset (vlist-offset vlist)))
315 (if (<= count offset)
316 (make-vlist base (- offset count))
317 (loop (- count offset 1)
319 (block-offset base)))))
321 (define (vlist-take vlist count)
322 "Return a new vlist that contains only the COUNT first elements of
324 (let loop ((count count)
328 (vlist-reverse result)
331 (vlist-cons (vlist-head vlist) result)))))
333 (define (vlist-filter pred vlist)
334 "Return a new vlist containing all the elements from VLIST that
336 (vlist-fold-right (lambda (e v)
343 (define* (vlist-delete x vlist #:optional (equal? equal?))
344 "Return a new vlist corresponding to VLIST without the elements
346 (vlist-filter (lambda (e)
350 (define (vlist-length vlist)
351 "Return the length of VLIST."
353 (let loop ((base (vlist-base vlist))
354 (len (vlist-offset vlist)))
355 (if (eq? base block-null)
357 (loop (block-base base)
358 (+ len 1 (block-offset base))))))
360 (define* (vlist-unfold p f g seed
361 #:optional (tail-gen (lambda (x) vlist-null)))
362 "Return a new vlist. See the description of SRFI-1 `unfold' for details."
363 (let uf ((seed seed))
369 (define* (vlist-unfold-right p f g seed #:optional (tail vlist-null))
370 "Return a new vlist. See the description of SRFI-1 `unfold-right' for
372 (let uf ((seed seed) (lis tail))
375 (uf (g seed) (vlist-cons (f seed) lis)))))
377 (define (vlist-append . vlists)
378 "Append the given lists."
381 (fold-right (lambda (vlist result)
382 (vlist-fold-right (lambda (e v)
389 (define (vlist-for-each proc vlist)
390 "Call PROC on each element of VLIST. The result is unspecified."
391 (vlist-fold (lambda (item x)
398 ;;; Hash Lists, aka. `VHash'.
401 ;; Assume keys K1 and K2, H = hash(K1) = hash(K2), and two values V1 and V2
402 ;; associated with K1 and K2, respectively. The resulting layout is a
405 ;; ,--------------------.
406 ;; 0| ,-> (K1 . V1) | Vlist array
410 ;; size +-|------------------+
413 ;; 2| +-- O <------------- H
415 ;; size * 2 +-|------------------+
416 ;; 0| `-> 2 | Chain links
420 ;; size * 3 `--------------------'
422 ;; The backing store for the vhash is partitioned into three areas: the
423 ;; vlist part, the hash table part, and the chain links part. In this
424 ;; example we have a hash H which, when indexed into the hash table
425 ;; part, indicates that a value with this hash can be found at offset 0
426 ;; in the vlist part. The corresponding index (in this case, 0) of the
427 ;; chain links array holds the index of the next element in this block
428 ;; with this hash value, or #f if we reached the end of the chain.
430 ;; This API potentially requires users to repeat which hash function and
431 ;; which equality predicate to use. This can lead to unpredictable
432 ;; results if they are used in consistenly, e.g., between `vhash-cons'
433 ;; and `vhash-assoc', which is undesirable, as argued in
434 ;; http://savannah.gnu.org/bugs/?22159 . OTOH, two arguments can be
435 ;; made in favor of this API:
437 ;; - It's consistent with how alists are handled in SRFI-1.
439 ;; - In practice, users will probably consistenly use either the `q',
440 ;; the `v', or the plain variant (`vlist-cons' and `vlist-assoc'
441 ;; without any optional argument), i.e., they will rarely explicitly
442 ;; pass a hash function or equality predicate.
445 "Return true if OBJ is a hash list."
447 (block-hash-table? (vlist-base obj))))
449 (define* (vhash-cons key value vhash #:optional (hash hash))
450 "Return a new hash list based on VHASH where KEY is associated
451 with VALUE. Use HASH to compute KEY's hash."
453 ;; We should also assert that it is a hash table. Need to check the
454 ;; performance impacts of that. Also, vlist-null is a valid hash
455 ;; table, which does not pass vhash?. A bug, perhaps.
456 (let* ((vhash (block-cons (cons key value) vhash #t))
457 (base (vlist-base vhash))
458 (offset (vlist-offset vhash))
459 (size (block-size base))
460 (khash (hash key size))
461 (content (block-content base)))
462 (block-hash-table-add! content size khash offset)
465 (define vhash-consq (cut vhash-cons <> <> <> hashq))
466 (define vhash-consv (cut vhash-cons <> <> <> hashv))
468 (define-inlinable (%vhash-fold* proc init key vhash equal? hash)
469 ;; Fold over all the values associated with KEY in VHASH.
470 (define (visit-block base max-offset result)
471 (let* ((size (block-size base))
472 (content (block-content base))
473 (khash (hash key size)))
474 (let loop ((offset (block-hash-table-ref content size khash))
477 (loop (block-hash-table-next-offset content size offset)
478 (if (and (<= offset max-offset)
479 (equal? key (car (block-ref content offset))))
480 (proc (cdr (block-ref content offset)) result)
482 (let ((next-block (block-base base)))
483 (if (> (block-size next-block) 0)
484 (visit-block next-block (block-offset base) result)
488 (if (> (block-size (vlist-base vhash)) 0)
489 (visit-block (vlist-base vhash)
494 (define* (vhash-fold* proc init key vhash
495 #:optional (equal? equal?) (hash hash))
496 "Fold over all the values associated with KEY in VHASH, with each
497 call to PROC having the form ‘(proc value result)’, where
498 RESULT is the result of the previous call to PROC and INIT the
499 value of RESULT for the first call to PROC."
500 (%vhash-fold* proc init key vhash equal? hash))
502 (define (vhash-foldq* proc init key vhash)
503 "Same as ‘vhash-fold*’, but using ‘hashq’ and ‘eq?’."
504 (%vhash-fold* proc init key vhash eq? hashq))
506 (define (vhash-foldv* proc init key vhash)
507 "Same as ‘vhash-fold*’, but using ‘hashv’ and ‘eqv?’."
508 (%vhash-fold* proc init key vhash eqv? hashv))
510 (define-inlinable (%vhash-assoc key vhash equal? hash)
511 ;; A specialization of `vhash-fold*' that stops when the first value
512 ;; associated with KEY is found or when the end-of-list is reached. Inline to
513 ;; make sure `vhash-assq' gets to use the `eq?' instruction instead of calling
515 (define (visit-block base max-offset)
516 (let* ((size (block-size base))
517 (content (block-content base))
518 (khash (hash key size)))
519 (let loop ((offset (block-hash-table-ref content size khash)))
521 (if (and (<= offset max-offset)
522 (equal? key (car (block-ref content offset))))
523 (block-ref content offset)
524 (loop (block-hash-table-next-offset content size offset)))
525 (let ((next-block (block-base base)))
526 (and (> (block-size next-block) 0)
527 (visit-block next-block (block-offset base))))))))
530 (and (> (block-size (vlist-base vhash)) 0)
531 (visit-block (vlist-base vhash)
532 (vlist-offset vhash))))
534 (define* (vhash-assoc key vhash #:optional (equal? equal?) (hash hash))
535 "Return the first key/value pair from VHASH whose key is equal to
536 KEY according to the EQUAL? equality predicate."
537 (%vhash-assoc key vhash equal? hash))
539 (define (vhash-assq key vhash)
540 "Return the first key/value pair from VHASH whose key is ‘eq?’ to
542 (%vhash-assoc key vhash eq? hashq))
544 (define (vhash-assv key vhash)
545 "Return the first key/value pair from VHASH whose key is ‘eqv?’ to
547 (%vhash-assoc key vhash eqv? hashv))
549 (define* (vhash-delete key vhash #:optional (equal? equal?) (hash hash))
550 "Remove all associations from VHASH with KEY, comparing keys
552 (if (vhash-assoc key vhash equal? hash)
553 (vlist-fold (lambda (k+v result)
558 (vhash-cons k v result hash))))
563 (define vhash-delq (cut vhash-delete <> <> eq? hashq))
564 (define vhash-delv (cut vhash-delete <> <> eqv? hashv))
566 (define (vhash-fold proc init vhash)
567 "Fold over the key/pair elements of VHASH from left to right, with
568 each call to PROC having the form ‘(PROC key value result)’,
569 where RESULT is the result of the previous call to PROC and
570 INIT the value of RESULT for the first call to PROC."
571 (vlist-fold (lambda (key+value result)
572 (proc (car key+value) (cdr key+value)
577 (define (vhash-fold-right proc init vhash)
578 "Fold over the key/pair elements of VHASH from right to left, with
579 each call to PROC having the form ‘(PROC key value result)’,
580 where RESULT is the result of the previous call to PROC and
581 INIT the value of RESULT for the first call to PROC."
582 (vlist-fold-right (lambda (key+value result)
583 (proc (car key+value) (cdr key+value)
588 (define* (alist->vhash alist #:optional (hash hash))
589 "Return the vhash corresponding to ALIST, an association list."
590 (fold-right (lambda (pair result)
591 (vhash-cons (car pair) (cdr pair) result hash))
595 ;;; vlist.scm ends here