module/ice-9/vlist.scm

   1 ;;; -*- mode: scheme; coding: utf-8; -*-
   2 ;;;
   3 ;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
   4 ;;;
   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.
   9 ;;;
  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.
  14 ;;;
  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
  18
  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
  25   #:export (vlist? vlist-cons vlist-head vlist-tail vlist-null?
  26             vlist-null list->vlist vlist-ref vlist-drop vlist-take
  27             vlist-length vlist-fold vlist-fold-right vlist-map
  28             vlist-unfold vlist-unfold-right vlist-append
  29             vlist-reverse vlist-filter vlist-delete vlist->list
  30             vlist-for-each
  31             block-growth-factor
  32
  33             vhash? vhash-cons vhash-consq vhash-consv
  34             vhash-assoc vhash-assq vhash-assv
  35             vhash-delete vhash-delq vhash-delv
  36             vhash-fold vhash-fold-right
  37             vhash-fold* vhash-foldq* vhash-foldv*
  38             alist->vhash))
  39
  40 ;;; Author: Ludovic Courtès <ludo@gnu.org>
  41 ;;;
  42 ;;; Commentary:
  43 ;;;
  44 ;;; This module provides an implementations of vlists, a functional list-like
  45 ;;; data structure described by Phil Bagwell in "Fast Functional Lists,
  46 ;;; Hash-Lists, Dequeues and Variable-Length Arrays", EPFL Technical Report,
  47 ;;; 2002.
  48 ;;;
  49 ;;; The idea is to store vlist elements in increasingly large contiguous blocks
  50 ;;; (implemented as vectors here).  These blocks are linked to one another using
  51 ;;; a pointer to the next block (called `block-base' here) and an offset within
  52 ;;; that block (`block-offset' here).  The size of these blocks form a geometric
  53 ;;; series with ratio `block-growth-factor'.
  54 ;;;
  55 ;;; In the best case (e.g., using a vlist returned by `list->vlist'),
  56 ;;; elements from the first half of an N-element vlist are accessed in O(1)
  57 ;;; (assuming `block-growth-factor' is 2), and `vlist-length' takes only
  58 ;;; O(ln(N)).  Furthermore, the data structure improves data locality since
  59 ;;; vlist elements are adjacent, which plays well with caches.
  60 ;;;
  61 ;;; Code:
  62
  63 \f
  64 ;;;
  65 ;;; VList Blocks and Block Descriptors.
  66 ;;;
  67
  68 (define block-growth-factor
  69   (let ((f (make-fluid)))
  70     (fluid-set! f 2)
  71     f))
  72
  73 (define-syntax-rule (define-inline (name formals ...) body ...)
  74   ;; Work around the lack of an inliner.
  75   (define-syntax name
  76     (syntax-rules ()
  77       ((_ formals ...)
  78        (begin body ...)))))
  79
  80 (define-inline (make-block base offset size hash-tab?)
  81   ;; Return a block (and block descriptor) of SIZE elements pointing to BASE
  82   ;; at OFFSET.  If HASH-TAB? is true, a "hash table" is also added.
  83   ;; Note: We use `next-free' instead of `last-used' as suggested by Bagwell.
  84
  85   ;; XXX: We could improve locality here by having a single vector but currently
  86   ;; the extra arithmetic outweighs the benefits (!).
  87   (vector (make-vector size)
  88           base offset size 0
  89           (and hash-tab? (make-vector size #f))))
  90
  91 (define-syntax-rule (define-block-accessor name index)
  92   (define-inline (name block)
  93     (vector-ref block index)))
  94
  95 (define-block-accessor block-content 0)
  96 (define-block-accessor block-base 1)
  97 (define-block-accessor block-offset 2)
  98 (define-block-accessor block-size 3)
  99 (define-block-accessor block-next-free 4)
 100 (define-block-accessor block-hash-table 5)
 101
 102 (define-inline (increment-block-next-free! block)
 103   (vector-set! block 4
 104                (+ (block-next-free block) 1)))
 105
 106 (define-inline (block-append! block value)
 107   ;; This is not thread-safe.  To fix it, see Section 2.8 of the paper.
 108   (let ((offset (block-next-free block)))
 109     (increment-block-next-free! block)
 110     (vector-set! (block-content block) offset value)
 111     #t))
 112
 113 (define-inline (block-ref block offset)
 114   (vector-ref (block-content block) offset))
 115
 116 (define-inline (block-ref* block offset)
 117   (let ((v (block-ref block offset)))
 118     (if (block-hash-table block)
 119         (car v) ;; hide the vhash link
 120         v)))
 121
 122 (define-inline (block-hash-table-ref block offset)
 123   (vector-ref (block-hash-table block) offset))
 124
 125 (define-inline (block-hash-table-set! block offset value)
 126   (vector-set! (block-hash-table block) offset value))
 127
 128 (define block-null
 129   ;; The null block.
 130   (make-block #f 0 0 #f))
 131
 132 \f
 133 ;;;
 134 ;;; VLists.
 135 ;;;
 136
 137 (define-record-type <vlist>
 138   ;; A vlist is just a base+offset pair pointing to a block.
 139
 140   ;; XXX: Allocating a <vlist> record in addition to the block at each
 141   ;; `vlist-cons' call is inefficient.  However, Bagwell's hack to avoid it
 142   ;; (Section 2.2) would require GC_ALL_INTERIOR_POINTERS, which would be a
 143   ;; performance hit for everyone.
 144   (make-vlist base offset)
 145   vlist?
 146   (base    vlist-base)
 147   (offset  vlist-offset))
 148
 149 (set-record-type-printer! <vlist>
 150                           (lambda (vl port)
 151                             (cond ((vlist-null? vl)
 152                                    (format port "#<vlist ()>"))
 153                                   ((block-hash-table (vlist-base vl))
 154                                    (format port "#<vhash ~x ~a pairs>"
 155                                            (object-address vl)
 156                                            (vhash-fold (lambda (k v r)
 157                                                          (+ 1 r))
 158                                                        0
 159                                                        vl)))
 160                                   (else
 161                                    (format port "#<vlist ~a>"
 162                                            (vlist->list vl))))))
 163
 164
 165 (define vlist-null
 166   ;; The empty vlist.
 167   (make-vlist block-null 0))
 168
 169 (define-inline (block-cons item vlist hash-tab?)
 170   (let loop ((base   (vlist-base vlist))
 171              (offset (+ 1 (vlist-offset vlist))))
 172     (if (and (< offset (block-size base))
 173              (= offset (block-next-free base))
 174              (block-append! base item))
 175         (make-vlist base offset)
 176         (let ((size (cond ((eq? base block-null) 1)
 177                           ((< offset (block-size base))
 178                            ;; new vlist head
 179                            1)
 180                           (else
 181                            (* (fluid-ref block-growth-factor)
 182                               (block-size base))))))
 183           ;; Prepend a new block pointing to BASE.
 184           (loop (make-block base (- offset 1) size hash-tab?)
 185                 0)))))
 186
 187 (define (vlist-cons item vlist)
 188   "Return a new vlist with @var{item} as its head and @var{vlist} as its
 189 tail."
 190   ;; Note: Calling `vlist-cons' on a vhash will not do the right thing: it
 191   ;; doesn't box ITEM so that it can have the hidden "next" link used by
 192   ;; vhash items, and it passes `#f' as the HASH-TAB? argument to
 193   ;; `block-cons'.  However, inserting all the checks here has an important
 194   ;; performance penalty, hence this choice.
 195   (block-cons item vlist #f))
 196
 197 (define (vlist-head vlist)
 198   "Return the head of @var{vlist}."
 199   (let ((base   (vlist-base vlist))
 200         (offset (vlist-offset vlist)))
 201     (block-ref* base offset)))
 202
 203 (define (vlist-tail vlist)
 204   "Return the tail of @var{vlist}."
 205   (let ((base   (vlist-base vlist))
 206         (offset (vlist-offset vlist)))
 207     (if (> offset 0)
 208         (make-vlist base (- offset 1))
 209         (make-vlist (block-base base)
 210                     (block-offset base)))))
 211
 212 (define (vlist-null? vlist)
 213   "Return true if @var{vlist} is empty."
 214   (let ((base (vlist-base vlist)))
 215     (and (not (block-base base))
 216          (= 0 (block-size base)))))
 217
 218 \f
 219 ;;;
 220 ;;; VList Utilities.
 221 ;;;
 222
 223 (define (list->vlist lst)
 224   "Return a new vlist whose contents correspond to @var{lst}."
 225   (vlist-reverse (fold vlist-cons vlist-null lst)))
 226
 227 (define (vlist-fold proc init vlist)
 228   "Fold over @var{vlist}, calling @var{proc} for each element."
 229   ;; FIXME: Handle multiple lists.
 230   (let loop ((base   (vlist-base vlist))
 231              (offset (vlist-offset vlist))
 232              (result init))
 233     (if (eq? base block-null)
 234         result
 235         (let* ((next  (- offset 1))
 236                (done? (< next 0)))
 237           (loop (if done? (block-base base) base)
 238                 (if done? (block-offset base) next)
 239                 (proc (block-ref* base offset) result))))))
 240
 241 (define (vlist-fold-right proc init vlist)
 242   "Fold over @var{vlist}, calling @var{proc} for each element, starting from
 243 the last element."
 244   (define len (vlist-length vlist))
 245
 246   (let loop ((index  (1- len))
 247              (result init))
 248     (if (< index 0)
 249         result
 250         (loop (1- index)
 251               (proc (vlist-ref vlist index) result)))))
 252
 253 (define (vlist-reverse vlist)
 254   "Return a new @var{vlist} whose content are those of @var{vlist} in reverse
 255 order."
 256   (vlist-fold vlist-cons vlist-null vlist))
 257
 258 (define (vlist-map proc vlist)
 259   "Map @var{proc} over the elements of @var{vlist} and return a new vlist."
 260   (vlist-fold (lambda (item result)
 261                 (vlist-cons (proc item) result))
 262               vlist-null
 263               (vlist-reverse vlist)))
 264
 265 (define (vlist->list vlist)
 266   "Return a new list whose contents match those of @var{vlist}."
 267   (vlist-fold-right cons '() vlist))
 268
 269 (define (vlist-ref vlist index)
 270   "Return the element at index @var{index} in @var{vlist}."
 271   (let loop ((index   index)
 272              (base    (vlist-base vlist))
 273              (offset  (vlist-offset vlist)))
 274     (if (<= index offset)
 275         (block-ref* base (- offset index))
 276         (loop (- index offset 1)
 277               (block-base base)
 278               (block-offset base)))))
 279
 280 (define (vlist-drop vlist count)
 281   "Return a new vlist that does not contain the @var{count} first elements of
 282 @var{vlist}."
 283   (let loop ((count  count)
 284              (base   (vlist-base vlist))
 285              (offset (vlist-offset vlist)))
 286     (if (<= count offset)
 287         (make-vlist base (- offset count))
 288         (loop (- count offset 1)
 289               (block-base base)
 290               (block-offset base)))))
 291
 292 (define (vlist-take vlist count)
 293   "Return a new vlist that contains only the @var{count} first elements of
 294 @var{vlist}."
 295   (let loop ((count  count)
 296              (vlist  vlist)
 297              (result vlist-null))
 298     (if (= 0 count)
 299         (vlist-reverse result)
 300         (loop (- count 1)
 301               (vlist-tail vlist)
 302               (vlist-cons (vlist-head vlist) result)))))
 303
 304 (define (vlist-filter pred vlist)
 305   "Return a new vlist containing all the elements from @var{vlist} that
 306 satisfy @var{pred}."
 307   (vlist-fold-right (lambda (e v)
 308                       (if (pred e)
 309                           (vlist-cons e v)
 310                           v))
 311                     vlist-null
 312                     vlist))
 313
 314 (define* (vlist-delete x vlist #:optional (equal? equal?))
 315   "Return a new vlist corresponding to @var{vlist} without the elements
 316 @var{equal?} to @var{x}."
 317   (vlist-filter (lambda (e)
 318                   (not (equal? e x)))
 319                 vlist))
 320
 321 (define (vlist-length vlist)
 322   "Return the length of @var{vlist}."
 323   (let loop ((base (vlist-base vlist))
 324              (len  (vlist-offset vlist)))
 325     (if (eq? base block-null)
 326         len
 327         (loop (block-base base)
 328               (+ len 1 (block-offset base))))))
 329
 330 (define* (vlist-unfold p f g seed
 331                        #:optional (tail-gen (lambda (x) vlist-null)))
 332   "Return a new vlist.  See the description of SRFI-1 `unfold' for details."
 333   (let uf ((seed seed))
 334     (if (p seed)
 335         (tail-gen seed)
 336         (vlist-cons (f seed)
 337                     (uf (g seed))))))
 338
 339 (define* (vlist-unfold-right p f g seed #:optional (tail vlist-null))
 340   "Return a new vlist.  See the description of SRFI-1 `unfold-right' for
 341 details."
 342   (let uf ((seed seed) (lis tail))
 343     (if (p seed)
 344         lis
 345         (uf (g seed) (vlist-cons (f seed) lis)))))
 346
 347 (define (vlist-append . vlists)
 348   "Append the given lists."
 349   (if (null? vlists)
 350       vlist-null
 351       (fold-right (lambda (vlist result)
 352                     (vlist-fold-right (lambda (e v)
 353                                         (vlist-cons e v))
 354                                       result
 355                                       vlist))
 356                   vlist-null
 357                   vlists)))
 358
 359 (define (vlist-for-each proc vlist)
 360   "Call @var{proc} on each element of @var{vlist}.  The result is unspecified."
 361   (vlist-fold (lambda (item x)
 362                 (proc item))
 363               (if #f #f)
 364               vlist))
 365
 366 \f
 367 ;;;
 368 ;;; Hash Lists, aka. `VHash'.
 369 ;;;
 370
 371 ;; Assume keys K1 and K2, H = hash(K1) = hash(K2), and two values V1 and V2
 372 ;; associated with K1 and K2, respectively.  The resulting layout is a
 373 ;; follows:
 374 ;;
 375 ;;     ,--------------------.
 376 ;;     | ,-> (K1 . V1) ---. |
 377 ;;     | |                | |
 378 ;;     | |   (K2 . V2) <--' |
 379 ;;     | |                  |
 380 ;;     +-|------------------+
 381 ;;     | |                  |
 382 ;;     | |                  |
 383 ;;     | `-- O <---------------H
 384 ;;     |                    |
 385 ;;     `--------------------'
 386 ;;
 387 ;; The bottom part is the "hash table" part of the vhash, as returned by
 388 ;; `block-hash-table'; the other half is the data part.  O is the offset of
 389 ;; the first value associated with a key that hashes to H in the data part.
 390 ;; The (K1 . V1) pair has a "hidden" link to the (K2 . V2) pair; hiding the
 391 ;; link is handled by `block-ref'.
 392
 393 ;; This API potentially requires users to repeat which hash function and which
 394 ;; equality predicate to use.  This can lead to unpredictable results if they
 395 ;; are used in consistenly, e.g., between `vhash-cons' and `vhash-assoc', which
 396 ;; is undesirable, as argued in http://savannah.gnu.org/bugs/?22159 .  OTOH, two
 397 ;; arguments can be made in favor of this API:
 398 ;;
 399 ;;  - It's consistent with how alists are handled in SRFI-1.
 400 ;;
 401 ;;  - In practice, users will probably consistenly use either the `q', the `v',
 402 ;;    or the plain variant (`vlist-cons' and `vlist-assoc' without any optional
 403 ;;    argument), i.e., they will rarely explicitly pass a hash function or
 404 ;;    equality predicate.
 405
 406 (define (vhash? obj)
 407   "Return true if @var{obj} is a hash list."
 408   (and (vlist? obj)
 409        (let ((base (vlist-base obj)))
 410          (and base
 411               (vector? (block-hash-table base))))))
 412
 413 (define* (vhash-cons key value vhash #:optional (hash hash))
 414   "Return a new hash list based on @var{vhash} where @var{key} is associated
 415 with @var{value}.  Use @var{hash} to compute @var{key}'s hash."
 416   (let* ((key+value (cons key value))
 417          (entry     (cons key+value #f))
 418          (vlist     (block-cons entry vhash #t))
 419          (base      (vlist-base vlist))
 420          (khash     (hash key (block-size base))))
 421
 422     (let ((o (block-hash-table-ref base khash)))
 423       (if o (set-cdr! entry o)))
 424
 425     (block-hash-table-set! base khash
 426                            (vlist-offset vlist))
 427
 428     vlist))
 429
 430 (define vhash-consq (cut vhash-cons <> <> <> hashq))
 431 (define vhash-consv (cut vhash-cons <> <> <> hashv))
 432
 433 (define-inline (%vhash-fold* proc init key vhash equal? hash)
 434   ;; Fold over all the values associated with KEY in VHASH.
 435   (define khash
 436     (let ((size (block-size (vlist-base vhash))))
 437       (and (> size 0) (hash key size))))
 438
 439   (let loop ((base       (vlist-base vhash))
 440              (khash      khash)
 441              (offset     (and khash
 442                               (block-hash-table-ref (vlist-base vhash)
 443                                                     khash)))
 444              (max-offset (vlist-offset vhash))
 445              (result     init))
 446
 447     (let ((answer (and offset (block-ref base offset))))
 448       (cond ((and (pair? answer)
 449                   (<= offset max-offset)
 450                   (let ((answer-key (caar answer)))
 451                     (equal? key answer-key)))
 452              (let ((result      (proc (cdar answer) result))
 453                    (next-offset (cdr answer)))
 454                (loop base khash next-offset max-offset result)))
 455             ((and (pair? answer) (cdr answer))
 456              =>
 457              (lambda (next-offset)
 458                (loop base khash next-offset max-offset result)))
 459             (else
 460              (let ((next-base (block-base base)))
 461                (if (and next-base (> (block-size next-base) 0))
 462                    (let* ((khash  (hash key (block-size next-base)))
 463                           (offset (block-hash-table-ref next-base khash)))
 464                      (loop next-base khash offset (block-offset base)
 465                            result))
 466                    result)))))))
 467
 468 (define* (vhash-fold* proc init key vhash
 469                       #:optional (equal? equal?) (hash hash))
 470   "Fold over all the values associated with @var{key} in @var{vhash}, with each
 471 call to @var{proc} having the form @code{(proc value result)}, where
 472 @var{result} is the result of the previous call to @var{proc} and @var{init} the
 473 value of @var{result} for the first call to @var{proc}."
 474   (%vhash-fold* proc init key vhash equal? hash))
 475
 476 (define (vhash-foldq* proc init key vhash)
 477   "Same as @code{vhash-fold*}, but using @code{hashq} and @code{eq?}."
 478   (%vhash-fold* proc init key vhash eq? hashq))
 479
 480 (define (vhash-foldv* proc init key vhash)
 481   "Same as @code{vhash-fold*}, but using @code{hashv} and @code{eqv?}."
 482   (%vhash-fold* proc init key vhash eqv? hashv))
 483
 484 (define-inline (%vhash-assoc key vhash equal? hash)
 485   ;; A specialization of `vhash-fold*' that stops when the first value
 486   ;; associated with KEY is found or when the end-of-list is reached.  Inline to
 487   ;; make sure `vhash-assq' gets to use the `eq?' instruction instead of calling
 488   ;; the `eq?'  subr.
 489   (define khash
 490     (let ((size (block-size (vlist-base vhash))))
 491       (and (> size 0) (hash key size))))
 492
 493   (let loop ((base       (vlist-base vhash))
 494              (khash      khash)
 495              (offset     (and khash
 496                               (block-hash-table-ref (vlist-base vhash)
 497                                                     khash)))
 498              (max-offset (vlist-offset vhash)))
 499     (let ((answer (and offset (block-ref base offset))))
 500       (cond ((and (pair? answer)
 501                   (<= offset max-offset)
 502                   (let ((answer-key (caar answer)))
 503                     (equal? key answer-key)))
 504              (car answer))
 505             ((and (pair? answer) (cdr answer))
 506              =>
 507              (lambda (next-offset)
 508                (loop base khash next-offset max-offset)))
 509             (else
 510              (let ((next-base (block-base base)))
 511                (and next-base
 512                     (> (block-size next-base) 0)
 513                     (let* ((khash  (hash key (block-size next-base)))
 514                            (offset (block-hash-table-ref next-base khash)))
 515                       (loop next-base khash offset
 516                             (block-offset base))))))))))
 517
 518 (define* (vhash-assoc key vhash #:optional (equal? equal?) (hash hash))
 519   "Return the first key/value pair from @var{vhash} whose key is equal to
 520 @var{key} according to the @var{equal?} equality predicate."
 521   (%vhash-assoc key vhash equal? hash))
 522
 523 (define (vhash-assq key vhash)
 524   "Return the first key/value pair from @var{vhash} whose key is @code{eq?} to
 525 @var{key}."
 526   (%vhash-assoc key vhash eq? hashq))
 527
 528 (define (vhash-assv key vhash)
 529   "Return the first key/value pair from @var{vhash} whose key is @code{eqv?} to
 530 @var{key}."
 531   (%vhash-assoc key vhash eqv? hashv))
 532
 533 (define* (vhash-delete key vhash #:optional (equal? equal?) (hash hash))
 534   "Remove all associations from @var{vhash} with @var{key}, comparing keys
 535 with @var{equal?}."
 536   (if (vhash-assoc key vhash equal? hash)
 537       (vlist-fold (lambda (k+v result)
 538                     (let ((k (car k+v))
 539                           (v (cdr k+v)))
 540                       (if (equal? k key)
 541                           result
 542                           (vhash-cons k v result hash))))
 543                   vlist-null
 544                   vhash)
 545       vhash))
 546
 547 (define vhash-delq (cut vhash-delete <> <> eq? hashq))
 548 (define vhash-delv (cut vhash-delete <> <> eqv? hashv))
 549
 550 (define (vhash-fold proc seed vhash)
 551   "Fold over the key/pair elements of @var{vhash}.  For each pair call
 552 @var{proc} as @code{(@var{proc} key value result)}."
 553   (vlist-fold (lambda (key+value result)
 554                 (proc (car key+value) (cdr key+value)
 555                       result))
 556               seed
 557               vhash))
 558
 559 (define (vhash-fold-right proc seed vhash)
 560   "Fold over the key/pair elements of @var{vhash}, starting from the 0th
 561 element.  For each pair call @var{proc} as @code{(@var{proc} key value
 562 result)}."
 563   (vlist-fold-right (lambda (key+value result)
 564                       (proc (car key+value) (cdr key+value)
 565                             result))
 566                     seed
 567                     vhash))
 568
 569 (define* (alist->vhash alist #:optional (hash hash))
 570   "Return the vhash corresponding to @var{alist}, an association list."
 571   (fold-right (lambda (pair result)
 572                 (vhash-cons (car pair) (cdr pair) result hash))
 573               vlist-null
 574               alist))
 575
 576 ;;; vlist.scm ends here