From 22ec6a31eda1f06270fbba4b6aae45bb81de0631 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 2 Feb 2010 23:57:02 +0100 Subject: [PATCH] Add `(ice-9 vlist)'. * module/ice-9/vlist.scm, test-suite/tests/vlist.test, benchmark-suite/benchmarks/vlists.bm: New files. * module/Makefile.am (ICE_9_SOURCES): Add `vlist.scm'. * test-suite/Makefile.am (SCM_TESTS): Add `tests/vlist.test'. * benchmark-suite/Makefile.am (SCM_BENCHMARKS): Add `benchmarks/vlists.bm'. * doc/ref/api-compound.texi (VLists, VHashes): New nodes. --- benchmark-suite/Makefile.am | 3 +- benchmark-suite/benchmarks/vlists.bm | 103 ++++++ doc/ref/api-compound.texi | 280 +++++++++++++++ module/Makefile.am | 3 +- module/ice-9/vlist.scm | 492 +++++++++++++++++++++++++++ test-suite/Makefile.am | 1 + test-suite/tests/vlist.test | 303 +++++++++++++++++ 7 files changed, 1183 insertions(+), 2 deletions(-) create mode 100644 benchmark-suite/benchmarks/vlists.bm create mode 100644 module/ice-9/vlist.scm create mode 100644 test-suite/tests/vlist.test diff --git a/benchmark-suite/Makefile.am b/benchmark-suite/Makefile.am index a9da00e72..583519a38 100644 --- a/benchmark-suite/Makefile.am +++ b/benchmark-suite/Makefile.am @@ -7,7 +7,8 @@ SCM_BENCHMARKS = benchmarks/0-reference.bm \ benchmarks/structs.bm \ benchmarks/subr.bm \ benchmarks/uniform-vector-read.bm \ - benchmarks/vectors.bm + benchmarks/vectors.bm \ + benchmarks/vlists.bm EXTRA_DIST = guile-benchmark lib.scm $(SCM_BENCHMARKS) \ ChangeLog-2008 diff --git a/benchmark-suite/benchmarks/vlists.bm b/benchmark-suite/benchmarks/vlists.bm new file mode 100644 index 000000000..329c78623 --- /dev/null +++ b/benchmark-suite/benchmarks/vlists.bm @@ -0,0 +1,103 @@ +;;; -*- mode: scheme; coding: iso-8859-1; -*- +;;; VLists. +;;; +;;; Copyright 2009 Free Software Foundation, Inc. +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 3, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this software; see the file COPYING.LESSER. If +;;; not, write to the Free Software Foundation, Inc., 51 Franklin +;;; Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (benchmarks vlists) + :use-module (srfi srfi-1) + :use-module (ice-9 vlist) + :use-module (benchmark-suite lib)) + +;; Note: Use `--iteration-factor' to change this. +(define iterations 2000000) + +;; The size of large lists. +(define %list-size 700000) + +(define %big-list (make-list %list-size)) +(define %big-vlist (list->vlist %big-list)) + +(define-syntax comparative-benchmark + (syntax-rules () + ((_ benchmark-name iterations + ((api ((name value) ...))) + body ...) + (benchmark (format #f "~A (~A)" benchmark-name 'api) + iterations + (let ((name value) ...) + body ...))) + ((_ benchmark-name iterations + ((api bindings) apis ...) + body ...) + (begin + (comparative-benchmark benchmark-name iterations + ((api bindings)) + body ...) + (comparative-benchmark benchmark-name iterations + (apis ...) + body ...))))) + + +(with-benchmark-prefix "constructors" + + (comparative-benchmark "cons" 2 + ((srfi-1 ((cons cons) (null '()))) + (vlist ((cons vlist-cons) (null vlist-null)))) + (let loop ((i %list-size) + (r null)) + (and (> i 0) + (loop (1- i) (cons #t r))))) + + + (comparative-benchmark "acons" 2 + ((srfi-1 ((acons alist-cons) (null '()))) + (vlist ((acons vhash-cons) (null vlist-null)))) + (let loop ((i %list-size) + (r null)) + (if (zero? i) + r + (loop (1- i) (acons i i r)))))) + + +(define %big-alist + (let loop ((i %list-size) (res '())) + (if (zero? i) + res + (loop (1- i) (alist-cons i i res))))) +(define %big-vhash + (let loop ((i %list-size) (res vlist-null)) + (if (zero? i) + res + (loop (1- i) (vhash-cons i i res))))) + + +(with-benchmark-prefix "iteration" + + (comparative-benchmark "fold" 2 + ((srfi-1 ((fold fold) (lst %big-list))) + (vlist ((fold vlist-fold) (lst %big-vlist)))) + (fold (lambda (x y) y) #t lst)) + + (comparative-benchmark "assoc" 70 + ((srfi-1 ((assoc assoc) (alst %big-alist))) + (vhash ((assoc vhash-assoc) (alst %big-vhash)))) + (let loop ((i (quotient %list-size 3))) + (and (> i 0) + (begin + (assoc i alst) + (loop (- i 5000))))))) diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi index e3c45e843..1bedffdee 100644 --- a/doc/ref/api-compound.texi +++ b/doc/ref/api-compound.texi @@ -25,10 +25,12 @@ values can be looked up within them. * Bit Vectors:: Vectors of bits. * Generalized Vectors:: Treating all vector-like things uniformly. * Arrays:: Matrices, etc. +* VLists:: Vector-like lists. * Records:: * Structures:: * Dictionary Types:: About dictionary types in general. * Association Lists:: List-based dictionaries. +* VHashes:: VList-based dictionaries. * Hash Tables:: Table-based dictionaries. @end menu @@ -2086,6 +2088,172 @@ reading and writing. You must take care not to modify bits outside of the allowed index range of the array, even for contiguous arrays. @end deftypefn +@node VLists +@subsection VLists + +@cindex vlist + +The @code{(ice-9 vlist)} module provides an implementation of the @dfn{VList} +data structure designed by Phil Bagwell in 2002. VLists are immutable lists, +which can contain any Scheme object. They improve on standard Scheme linked +lists in several areas: + +@itemize +@item +Random access has typically constant-time complexity. + +@item +Computing the length of a VList has time complexity logarithmic in the number of +elements. + +@item +VLists use less storage space than standard lists. + +@item +VList elements are stored in contiguous regions, which improves memory locality +and leads to more efficient use of hardware caches. +@end itemize + +The idea behind VLists is to store vlist elements in increasingly large +contiguous blocks (implemented as vectors here). These blocks are linked to one +another using a pointer to the next block and an offset within that block. The +size of these blocks form a geometric series with ratio +@code{block-growth-factor} (2 by default). + +The VList structure also serves as the basis for the @dfn{VList-based hash +lists} or ``vhashes'', an immutable dictionary type (@pxref{VHashes}). + +However, the current implementation in @code{(ice-9 vlist)} has several +noteworthy shortcomings: + +@itemize + +@item +It is @emph{not} thread-safe. Although operations on vlists are all +@dfn{referentially transparent} (i.e., purely functional), adding elements to a +vlist with @code{vlist-cons} mutates part of its internal structure, which makes +it non-thread-safe. This could be fixed, but it would slow down +@code{vlist-cons}. + +@item +@code{vlist-cons} always allocates at least as much memory as @code{cons}. +Again, Phil Bagwell describes how to fix it, but that would require tuning the +garbage collector in a way that may not be generally beneficial. + +@item +@code{vlist-cons} is a Scheme procedure compiled to bytecode, and it does not +compete with the straightforward C implementation of @code{cons}, and with the +fact that the VM has a special @code{cons} instruction. + +@end itemize + +We hope to address these in the future. + +The programming interface exported by @code{(ice-9 vlist)} is defined below. +Most of it is the same as SRFI-1 with an added @code{vlist-} prefix to function +names. + +@deffn {Scheme Procedure} vlist? obj +Return true if @var{obj} is a VList. +@end deffn + +@defvr {Scheme Variable} vlist-null +The empty VList. Note that it's possible to create an empty VList not +@code{eq?} to @code{vlist-null}; thus, callers should always use +@code{vlist-null?} when testing whether a VList is empty. +@end defvr + +@deffn {Scheme Procedure} vlist-null? vlist +Return true if @var{vlist} is empty. +@end deffn + +@deffn {Scheme Procedure} vlist-cons item vlist +Return a new vlist with @var{item} as its head and @var{vlist} as its tail. +@end deffn + +@deffn {Scheme Procedure} vlist-head vlist +Return the head of @var{vlist}. +@end deffn + +@deffn {Scheme Procedure} vlist-tail vlist +Return the tail of @var{vlist}. +@end deffn + +@defvr {Scheme Variable} block-growth-factor +A fluid that defines the growth factor of VList blocks, 2 by default. +@end defvr + +The functions below provide the usual set of higher-level list operations. + +@deffn {Scheme Procedure} vlist-fold proc init vlist +@deffnx {Scheme Procedure} vlist-fold-right proc init vlist +Fold over @var{vlist}, calling @var{proc} for each element, as for SRFI-1 +@code{fold} and @code{fold-right} (@pxref{SRFI-1, @code{fold}}). +@end deffn + +@deffn {Scheme Procedure} vlist-ref vlist index +Return the element at index @var{index} in @var{vlist}. This is typically a +constant-time operation. +@end deffn + +@deffn {Scheme Procedure} vlist-length vlist +Return the length of @var{vlist}. This is typically logarithmic in the number +of elements in @var{vlist}. +@end deffn + +@deffn {Scheme Procedure} vlist-reverse vlist +Return a new @var{vlist} whose content are those of @var{vlist} in reverse +order. +@end deffn + +@deffn {Scheme Procedure} vlist-map proc vlist +Map @var{proc} over the elements of @var{vlist} and return a new vlist. +@end deffn + +@deffn {Scheme Procedure} vlist-for-each proc vlist +Call @var{proc} on each element of @var{vlist}. The result is unspecified. +@end deffn + +@deffn {Scheme Procedure} vlist-drop vlist count +Return a new vlist that does not contain the @var{count} first elements of +@var{vlist}. This is typically a constant-time operation. +@end deffn + +@deffn {Scheme Procedure} vlist-take vlist count +Return a new vlist that contains only the @var{count} first elements of +@var{vlist}. +@end deffn + +@deffn {Scheme Procedure} vlist-filter pred vlist +Return a new vlist containing all the elements from @var{vlist} that satisfy +@var{pred}. +@end deffn + +@deffn {Scheme Procedure} vlist-delete x vlist [equal?] +Return a new vlist corresponding to @var{vlist} without the elements +@var{equal?} to @var{x}. +@end deffn + +@deffn {Scheme Procedure} vlist-unfold p f g seed [tail-gen] +@deffnx {Scheme Procedure} vlist-unfold-right p f g seed [tail] +Return a new vlist, as for SRFI-1 @code{unfold} and @code{unfold-right} +(@pxref{SRFI-1, @code{unfold}}). +@end deffn + +@deffn {Scheme Procedure} vlist-append vlists ... +Append the given vlists and return the resulting vlist. +@end deffn + +@deffn {Scheme Procedure} list->vlist lst +Return a new vlist whose contents correspond to @var{lst}. +@end deffn + +@deffn {Scheme Procedure} vlist->list vlist +Return a new list whose contents match those of @var{vlist}. +@end deffn + + + @node Records @subsection Records @@ -3030,6 +3198,118 @@ capitals ("Florida" . "Tallahassee")) @end lisp +@node VHashes +@subsection VList-Based Hash Lists or ``VHashes'' + +@cindex VList-based hash lists +@cindex VHash + +The @code{(ice-9 vlist)} module provides an implementation of @dfn{VList-based +hash lists} (@pxref{VLists}). VList-based hash lists, or @dfn{vhashes}, are an +immutable dictionary type similar to association lists that maps @dfn{keys} to +@dfn{values}. However, unlike association lists, accessing a value given its +key is typically a constant-time operation. + +The VHash programming interface of @code{(ice-9 vlist)} is mostly the same as +that of association lists found in SRFI-1, with procedure names prefixed by +@code{vhash-} instead of @code{vlist-} (@pxref{SRFI-1 Association Lists}). + +In addition, vhashes can be manipulated using VList operations: + +@example +(vlist-head (vhash-consq 'a 1 vlist-null)) +@result{} (a . 1) + +(define vh1 (vhash-consq 'b 2 (vhash-consq 'a 1 vlist-null))) +(define vh2 (vhash-consq 'c 3 (vlist-tail vh1))) + +(vhash-assq 'a vh2) +@result{} (a . 1) +(vhash-assq 'b vh2) +@result{} #f +(vhash-assq 'c vh2) +@result{} (c . 3) +(vlist->list vh2) +@result{} ((c . 3) (a . 1)) +@end example + +However, keep in mind that procedures that construct new VLists +(@code{vlist-map}, @code{vlist-filter}, etc.) return raw VLists, not vhashes: + +@example +(define vh (alist->vhash '((a . 1) (b . 2) (c . 3)) hashq)) +(vhash-assq 'a vh) +@result{} (a . 1) + +(define vl + ;; This will create a raw vlist. + (vlist-filter (lambda (key+value) (odd? (cdr key+value))) vh)) +(vhash-assq 'a vl) +@result{} ERROR: Wrong type argument in position 2 + +(vlist->list vl) +@result{} ((a . 1) (c . 3)) +@end example + +@deffn {Scheme Procedure} vhash? obj +Return true if @var{obj} is a vhash. +@end deffn + +@deffn {Scheme Procedure} vhash-cons key value vhash [hash-proc] +@deffnx {Scheme Procedure} vhash-consq key value vhash +@deffnx {Scheme Procedure} vhash-consv key value vhash +Return a new hash list based on @var{vhash} where @var{key} is associated with +@var{value}, using @var{hash-proc} to compute the hash of @var{key}. +@var{vhash} must be either @code{vlist-null} or a vhash returned by a previous +call to @code{vhash-cons}. @var{hash-proc} defaults to @code{hash} (@pxref{Hash +Table Reference, @code{hash} procedure}). With @code{vhash-consq}, the +@code{hashq} hash function is used; with @code{vhash-consv} the @code{hashv} +hash function is used. + +All @code{vhash-cons} calls made to construct a vhash should use the same +@var{hash-proc}. Failing to do that, the result is undefined. +@end deffn + +@deffn {Scheme Procedure} vhash-assoc key vhash [equal? [hash-proc]] +@deffnx {Scheme Procedure} vhash-assq key vhash +@deffnx {Scheme Procedure} vhash-assv key vhash +Return the first key/value pair from @var{vhash} whose key is equal to @var{key} +according to the @var{equal?} equality predicate (which defaults to +@code{equal?}), and using @var{hash-proc} (which defaults to @code{hash}) to +compute the hash of @var{key}. The second form uses @code{eq?} as the equality +predicate and @code{hashq} as the hash function; the last form uses @code{eqv?} +and @code{hashv}. + +Note that it is important to consistently use the same hash function for +@var{hash-proc} as was passed to @code{vhash-cons}. Failing to do that, the +result is unpredictable. +@end deffn + +@deffn {Scheme Procedure} vhash-delete key vhash [equal? [hash-proc]] +@deffnx {Scheme Procedure} vhash-delq key vhash +@deffnx {Scheme Procedure} vhash-delv key vhash +Remove all associations from @var{vhash} with @var{key}, comparing keys with +@var{equal?} (which defaults to @code{equal?}), and computing the hash of +@var{key} using @var{hash-proc} (which defaults to @code{hash}). The second +form uses @code{eq?} as the equality predicate and @code{hashq} as the hash +function; the last one uses @code{eqv?} and @code{hashv}. + +Again the choice of @var{hash-proc} must be consistent with previous calls to +@code{vhash-cons}. +@end deffn + +@deffn {Scheme Procedure} vhash-fold proc vhash +Fold over the key/pair elements of @var{vhash}. For each pair call @var{proc} +as @code{(@var{proc} key value result)}. +@end deffn + +@deffn {Scheme Procedure} alist->vhash alist [hash-proc] +Return the vhash corresponding to @var{alist}, an association list, using +@var{hash-proc} to compute key hashes. When omitted, @var{hash-proc} defaults +to @code{hash}. +@end deffn + + @node Hash Tables @subsection Hash Tables @tpindex Hash Tables diff --git a/module/Makefile.am b/module/Makefile.am index fac005a3b..0ee2d1ce6 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -225,7 +225,8 @@ ICE_9_SOURCES = \ ice-9/deprecated.scm \ ice-9/list.scm \ ice-9/serialize.scm \ - ice-9/gds-server.scm + ice-9/gds-server.scm \ + ice-9/vlist.scm SRFI_SOURCES = \ srfi/srfi-1.scm \ diff --git a/module/ice-9/vlist.scm b/module/ice-9/vlist.scm new file mode 100644 index 000000000..dd62661af --- /dev/null +++ b/module/ice-9/vlist.scm @@ -0,0 +1,492 @@ +;;; -*- mode: scheme; coding: utf-8; -*- +;;; +;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. +;;; +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (ice-9 vlist) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + + #:export (vlist? vlist-cons vlist-head vlist-tail vlist-null? + vlist-null list->vlist vlist-ref vlist-drop vlist-take + vlist-length vlist-fold vlist-fold-right vlist-map + vlist-unfold vlist-unfold-right vlist-append + vlist-reverse vlist-filter vlist-delete vlist->list + vlist-for-each + block-growth-factor + + vhash? vhash-cons vhash-consq vhash-consv + vhash-assoc vhash-assq vhash-assv + vhash-delete vhash-fold alist->vhash)) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; This module provides an implementations of vlists, a functional list-like +;;; data structure described by Phil Bagwell in "Fast Functional Lists, +;;; Hash-Lists, Dequeues and Variable-Length Arrays", EPFL Technical Report, +;;; 2002. +;;; +;;; The idea is to store vlist elements in increasingly large contiguous blocks +;;; (implemented as vectors here). These blocks are linked to one another using +;;; a pointer to the next block (called `block-base' here) and an offset within +;;; that block (`block-offset' here). The size of these blocks form a geometric +;;; series with ratio `block-growth-factor'. +;;; +;;; In the best case (e.g., using a vlist returned by `list->vlist'), +;;; elements from the first half of an N-element vlist are accessed in O(1) +;;; (assuming `block-growth-factor' is 2), and `vlist-length' takes only +;;; O(ln(N)). Furthermore, the data structure improves data locality since +;;; vlist elements are adjacent, which plays well with caches. +;;; +;;; Code: + + +;;; +;;; VList Blocks and Block Descriptors. +;;; + +(define block-growth-factor + (let ((f (make-fluid))) + (fluid-set! f 2) + f)) + +(define-syntax define-inline + ;; Work around the lack of an inliner. + (syntax-rules () + ((_ (name formals ...) body ...) + (define-syntax name + (syntax-rules () + ((_ formals ...) + 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-syntax define-block-accessor + (syntax-rules () + ((_ name index) + (define-inline (name block) + (vector-ref block index))))) + +(define-block-accessor block-content 0) +(define-block-accessor block-base 1) +(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-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-inline (block-hash-table-set! block offset value) + (vector-set! (block-hash-table block) offset value)) + +(define block-null + ;; The null block. + (make-block #f 0 0 #f)) + + +;;; +;;; VLists. +;;; + +(define-record-type + ;; A vlist is just a base+offset pair pointing to a block. + + ;; XXX: Allocating a record in addition to the block at each + ;; `vlist-cons' call is inefficient. However, Bagwell's hack to avoid it + ;; (Section 2.2) would require GC_ALL_INTERIOR_POINTERS, which would be a + ;; performance hit for everyone. + (make-vlist base offset) + vlist? + (base vlist-base) + (offset vlist-offset)) + + +(define vlist-null + ;; 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))))) + +(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. + (block-cons item vlist #f)) + +(define (vlist-head vlist) + "Return the head of @var{vlist}." + (let ((base (vlist-base vlist)) + (offset (vlist-offset vlist))) + (block-ref* base offset))) + +(define (vlist-tail vlist) + "Return the tail of @var{vlist}." + (let ((base (vlist-base vlist)) + (offset (vlist-offset vlist))) + (if (> offset 0) + (make-vlist base (- offset 1)) + (make-vlist (block-base base) + (block-offset base))))) + +(define (vlist-null? vlist) + "Return true if @var{vlist} is empty." + (let ((base (vlist-base vlist))) + (and (not (block-base base)) + (= 0 (block-size base))))) + + +;;; +;;; VList Utilities. +;;; + +(define (list->vlist lst) + "Return a new vlist whose contents correspond to @var{lst}." + (vlist-reverse (fold vlist-cons vlist-null lst))) + +(define (vlist-fold proc init vlist) + "Fold over @var{vlist}, calling @var{proc} for each element." + ;; FIXME: Handle multiple lists. + (let loop ((base (vlist-base vlist)) + (offset (vlist-offset vlist)) + (result init)) + (if (eq? base block-null) + result + (let* ((next (- offset 1)) + (done? (< next 0))) + (loop (if done? (block-base base) base) + (if done? (block-offset base) next) + (proc (block-ref* 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." + (vlist-fold proc init (vlist-reverse vlist))) + +(define (vlist-reverse vlist) + "Return a new @var{vlist} whose content are those of @var{vlist} in reverse +order." + (vlist-fold vlist-cons vlist-null vlist)) + +(define (vlist-map proc vlist) + "Map @var{proc} over the elements of @var{vlist} and return a new vlist." + (vlist-fold (lambda (item result) + (vlist-cons (proc item) result)) + vlist-null + (vlist-reverse vlist))) + +(define (vlist->list vlist) + "Return a new list whose contents match those of @var{vlist}." + (vlist-fold-right cons '() vlist)) + +(define (vlist-ref vlist index) + "Return the element at index @var{index} in @var{vlist}." + (let loop ((index index) + (base (vlist-base vlist)) + (offset (vlist-offset vlist))) + (if (<= index offset) + (block-ref* 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}." + (let loop ((count count) + (base (vlist-base vlist)) + (offset (vlist-offset vlist))) + (if (<= count offset) + (make-vlist base (- offset count)) + (loop (- count offset 1) + (block-base base) + (block-offset base))))) + +(define (vlist-take vlist count) + "Return a new vlist that contains only the @var{count} first elements of +@var{vlist}." + (let loop ((count count) + (vlist vlist) + (result vlist-null)) + (if (= 0 count) + (vlist-reverse result) + (loop (- count 1) + (vlist-tail vlist) + (vlist-cons (vlist-head vlist) result))))) + +(define (vlist-filter pred vlist) + "Return a new vlist containing all the elements from @var{vlist} that +satisfy @var{pred}." + (vlist-fold-right (lambda (e v) + (if (pred e) + (vlist-cons e v) + v)) + vlist-null + vlist)) + +(define* (vlist-delete x vlist #:optional (equal? equal?)) + "Return a new vlist corresponding to @var{vlist} without the elements +@var{equal?} to @var{x}." + (vlist-filter (lambda (e) + (not (equal? e x))) + vlist)) + +(define (vlist-length vlist) + "Return the length of @var{vlist}." + (let loop ((base (vlist-base vlist)) + (len (vlist-offset vlist))) + (if (eq? base block-null) + len + (loop (block-base base) + (+ len 1 (block-offset base)))))) + +(define* (vlist-unfold p f g seed + #:optional (tail-gen (lambda (x) vlist-null))) + "Return a new vlist. See the description of SRFI-1 `unfold' for details." + (let uf ((seed seed)) + (if (p seed) + (tail-gen seed) + (vlist-cons (f seed) + (uf (g seed)))))) + +(define* (vlist-unfold-right p f g seed #:optional (tail vlist-null)) + "Return a new vlist. See the description of SRFI-1 `unfold-right' for +details." + (let uf ((seed seed) (lis tail)) + (if (p seed) + lis + (uf (g seed) (vlist-cons (f seed) lis))))) + +(define (vlist-append . vlists) + "Append the given lists." + (if (null? vlists) + vlist-null + (fold-right (lambda (vlist result) + (vlist-fold-right (lambda (e v) + (vlist-cons e v)) + result + vlist)) + vlist-null + vlists))) + +(define (vlist-for-each proc vlist) + "Call @var{proc} on each element of @var{vlist}. The result is unspecified." + (vlist-fold (lambda (item x) + (proc item)) + (if #f #f) + vlist)) + + +;;; +;;; Hash Lists, aka. `VHash'. +;;; + +;; Assume keys K1 and K2, H = hash(K1) = hash(K2), and two values V1 and V2 +;; associated with K1 and K2, respectively. The resulting layout is a +;; follows: +;; +;; ,--------------------. +;; | ,-> (K1 . V1) ---. | +;; | | | | +;; | | (K2 . V2) <--' | +;; | | | +;; +-|------------------+ +;; | | | +;; | | | +;; | `-- O <---------------H +;; | | +;; `--------------------' +;; +;; 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: +;; +;; - 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. + +(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)))))) + +(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)) + +(define vhash-consq (cut vhash-cons <> <> <> hashq)) +(define vhash-consv (cut vhash-cons <> <> <> hashv)) + +(define-syntax make-vhash-assoc + ;; This hack to make sure `vhash-assq' gets to use the `eq?' instruction + ;; instead of calling the `eq?' subr. + (syntax-rules () + ((_ key vhash equal? hash) + (begin + (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* (vhash-assoc key vhash #:optional (equal? equal?) (hash hash)) + "Return the first key/value pair from @var{vhash} whose key is equal to +@var{key} according to the @var{equal?} equality predicate." + (make-vhash-assoc key vhash equal? hash)) + +(define (vhash-assq key vhash) + "Return the first key/value pair from @var{vhash} whose key is @code{eq?} to +@var{key}." + (make-vhash-assoc key vhash eq? hashq)) + +(define (vhash-assv key vhash) + "Return the first key/value pair from @var{vhash} whose key is @code{eqv?} to +@var{key}." + (make-vhash-assoc key vhash eqv? hashv)) + +(define* (vhash-delete key vhash #:optional (equal? equal?) (hash hash)) + "Remove all associations from @var{vhash} with @var{key}, comparing keys +with @var{equal?}." + (vlist-fold (lambda (k+v result) + (let ((k (car k+v)) + (v (cdr k+v))) + (if (equal? k key) + result + (vhash-cons k v result)))) + vlist-null + vhash)) + +(define vhash-delq (cut vhash-delete <> <> eq? hashq)) +(define vhash-delv (cut vhash-delete <> <> eqv? hashv)) + +(define (vhash-fold proc seed vhash) + "Fold over the key/pair elements of @var{vhash}. For each pair call +@var{proc} as @code{(@var{proc} key value result)}." + (vlist-fold (lambda (key+value result) + (proc (car key+value) (cdr key+value) + result)) + seed + vhash)) + +(define* (alist->vhash alist #:optional (hash hash)) + "Return the vhash corresponding to @var{alist}, an association list." + (fold-right (lambda (pair result) + (vhash-cons (car pair) (cdr pair) result hash)) + vlist-null + alist)) + +;;; vlist.scm ends here diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index f29b1ca90..c65f4d353 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -112,6 +112,7 @@ SCM_TESTS = tests/alist.test \ tests/tree-il.test \ tests/unif.test \ tests/version.test \ + tests/vlist.test \ tests/weaks.test EXTRA_DIST = guile-test lib.scm $(SCM_TESTS) ChangeLog-2008 diff --git a/test-suite/tests/vlist.test b/test-suite/tests/vlist.test new file mode 100644 index 000000000..47e386e82 --- /dev/null +++ b/test-suite/tests/vlist.test @@ -0,0 +1,303 @@ +;;;; vlist.test --- VLists. -*- mode: scheme; coding: utf-8; -*- +;;;; +;;;; Ludovic Courtès +;;;; +;;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (test-vlist) + :use-module (test-suite lib) + :use-module (ice-9 vlist) + :use-module (srfi srfi-1)) + + +;;; +;;; VLists. +;;; + +(with-test-prefix "vlist" + + (pass-if "vlist?" + (and (vlist? vlist-null) + (vlist? (vlist-cons 'a vlist-null)))) + + (pass-if "vlist-null?" + (vlist-null? vlist-null)) + + (pass-if "vlist-cons" + (let* ((v1 (vlist-cons 1 vlist-null)) + (v2 (vlist-cons 2 v1)) + (v3 (vlist-cons 3 v2)) + (v4 (vlist-cons 4 v3))) + (every vlist? (list v1 v2 v3 v4)))) + + (pass-if "vlist-head" + (let* ((v1 (vlist-cons 1 vlist-null)) + (v2 (vlist-cons 2 v1)) + (v3 (vlist-cons 3 v2)) + (v4 (vlist-cons 4 v3))) + (equal? (map vlist-head (list v1 v2 v3 v4)) + '(1 2 3 4)))) + + (pass-if "vlist-tail" + (let* ((v1 (vlist-cons 1 vlist-null)) + (v2 (vlist-cons 2 v1)) + (v3 (vlist-cons 3 v2)) + (v4 (vlist-cons 4 v3))) + (equal? (map vlist-head + (map vlist-tail (list v2 v3 v4))) + '(1 2 3)))) + + (pass-if "vlist->list" + (let* ((v1 (vlist-cons 1 vlist-null)) + (v2 (vlist-cons 2 v1)) + (v3 (vlist-cons 3 v2)) + (v4 (vlist-cons 4 v3))) + (equal? '(4 3 2 1) + (vlist->list v4)))) + + (pass-if "list->vlist" + (equal? (vlist->list (list->vlist '(1 2 3 4 5))) + '(1 2 3 4 5))) + + (pass-if "vlist-drop" + (equal? (vlist->list (vlist-drop (list->vlist (iota 77)) 7)) + (drop (iota 77) 7))) + + (pass-if "vlist-cons2" + ;; Example from Bagwell's paper, Figure 2. + (let* ((top (list->vlist '(8 7 6 5 4 3))) + (part (vlist-tail (vlist-tail top))) + (test (vlist-cons 9 part))) + (equal? (vlist->list test) + '(9 6 5 4 3)))) + + (pass-if "vlist-cons3" + (let ((vlst (vlist-cons 'a + (vlist-cons 'b + (vlist-drop (list->vlist (iota 5)) + 3))))) + (equal? (vlist->list vlst) + '(a b 3 4)))) + + (pass-if "vlist-map" + (equal? (vlist->list (vlist-map 1+ (list->vlist '(1 2 3 4 5)))) + '(2 3 4 5 6))) + + (pass-if "vlist-length" + (= (vlist-length (list->vlist (iota 77))) + 77)) + + (pass-if "vlist-length complex" + (= (vlist-length (fold vlist-cons + (vlist-drop (list->vlist (iota 77)) 33) + (iota (- 33 7)))) + 70)) + + (pass-if "vlist-ref" + (let* ((indices (iota 111)) + (vlst (list->vlist indices))) + (equal? (map (lambda (i) + (vlist-ref vlst i)) + indices) + indices))) + + (pass-if "vlist-ref degenerate" + ;; Degenerate case where VLST contains only 1-element blocks. + (let* ((indices (iota 111)) + (vlst (fold (lambda (i vl) + (let ((vl (vlist-cons 'x vl))) + (vlist-cons i (vlist-tail vl)))) + vlist-null + indices))) + (equal? (map (lambda (i) + (vlist-ref vlst i)) + (reverse indices)) + indices))) + + (pass-if "vlist-filter" + (let* ((lst (iota 33)) + (vlst (fold-right vlist-cons vlist-null lst))) + (equal? (vlist->list (vlist-filter even? vlst)) + (filter even? lst)))) + + (pass-if "vlist-delete" + (let* ((lst '(a b c d e)) + (vlst (fold-right vlist-cons vlist-null lst))) + (equal? (vlist->list (vlist-delete 'c vlst)) + (delete 'c lst)))) + + (pass-if "vlist-take" + (let* ((lst (iota 77)) + (vlst (fold-right vlist-cons vlist-null lst))) + (equal? (vlist->list (vlist-take vlst 44)) + (take lst 44)))) + + (pass-if "vlist-unfold" + (let ((results (map (lambda (unfold) + (unfold (lambda (i) (> i 100)) + (lambda (i) i) + (lambda (i) (+ i 1)) + 0)) + (list unfold vlist-unfold)))) + (equal? (car results) + (vlist->list (cadr results))))) + + (pass-if "vlist-append" + (let* ((lists '((a) (b c) (d e f) (g))) + (vlst (apply vlist-append (map list->vlist lists))) + (lst (apply append lists))) + (equal? lst (vlist->list vlst))))) + + +;;; +;;; VHash. +;;; + +(with-test-prefix "vhash" + + (pass-if "vhash?" + (vhash? (vhash-cons "hello" "world" vlist-null))) + + (pass-if "vhash-assoc vlist-null" + (not (vhash-assq 'a vlist-null))) + + (pass-if "vhash-assoc simple" + (let ((vh (vhash-cons "hello" "world" vlist-null))) + (equal? (cons "hello" "world") + (vhash-assoc "hello" vh)))) + + (pass-if "vhash-assoc regular" + (let* ((keys '(a b c d e f g h i)) + (values '(1 2 3 4 5 6 7 8 9)) + (vh (fold vhash-cons vlist-null keys values))) + (fold (lambda (k v result) + (and result + (equal? (cons k v) + (vhash-assoc k vh eq?)))) + #t + keys + values))) + + (pass-if "vhash-assoc tail" + (let* ((keys '(a b c d e f g h i)) + (values '(1 2 3 4 5 6 7 8 9)) + (vh1 (fold vhash-consq vlist-null keys values)) + (vh2 (vhash-consq 'x 'x (vlist-tail vh1)))) + (and (fold (lambda (k v result) + (and result + (equal? (cons k v) + (vhash-assq k vh2)))) + #t + (cons 'x (delq 'i keys)) + (cons 'x (delv 9 values))) + (not (vhash-assq 'i vh2))))) + + (pass-if "vhash-assoc degenerate" + (let* ((keys '(a b c d e f g h i)) + (values '(1 2 3 4 5 6 7 8 9)) + (vh (fold (lambda (k v vh) + ;; Degenerate case where VH2 contains only + ;; 1-element blocks. + (let* ((vh1 (vhash-cons 'x 'x vh)) + (vh2 (vlist-tail vh1))) + (vhash-cons k v vh2))) + vlist-null keys values))) + (and (fold (lambda (k v result) + (and result + (equal? (cons k v) + (vhash-assq k vh)))) + #t + keys + values) + (not (vhash-assq 'x vh))))) + + (pass-if "vhash as vlist" + (let* ((keys '(a b c d e f g h i)) + (values '(1 2 3 4 5 6 7 8 9)) + (vh (fold vhash-cons vlist-null keys values)) + (alist (fold alist-cons '() keys values))) + (and (equal? (vlist->list vh) alist) + (= (length alist) (vlist-length vh)) + (fold (lambda (i result) + (and result + (equal? (list-ref alist i) + (vlist-ref vh i)))) + #t + (iota (vlist-length vh)))))) + + (pass-if "vhash entry shadowed" + (let* ((a (vhash-consq 'a 1 vlist-null)) + (b (vhash-consq 'a 2 a))) + (and (= 1 (cdr (vhash-assq 'a a))) + (= 2 (cdr (vhash-assq 'a b))) + (= 1 (cdr (vhash-assq 'a (vlist-tail b))))))) + + (pass-if "vlist-filter" + (let* ((keys '(a b c d e f g h i)) + (values '(1 2 3 4 5 6 7 8 9)) + (vh (fold vhash-cons vlist-null keys values)) + (alist (fold alist-cons '() keys values)) + (pred (lambda (k+v) + (case (car k+v) + ((c f) #f) + (else #t))))) + (let ((vh (vlist-filter pred vh)) + (alist (filter pred alist))) + (and (equal? (vlist->list vh) alist) + (= (length alist) (vlist-length vh)) + (fold (lambda (i result) + (and result + (equal? (list-ref alist i) + (vlist-ref vh i)))) + #t + (iota (vlist-length vh))))))) + + (pass-if "vhash-delete" + (let* ((keys '(a b c d e f g d h i)) + (values '(1 2 3 4 5 6 7 0 8 9)) + (vh (fold vhash-cons vlist-null keys values)) + (alist (fold alist-cons '() keys values))) + (let ((vh (vhash-delete 'd vh)) + (alist (alist-delete 'd alist))) + (and (= (length alist) (vlist-length vh)) + (fold (lambda (k result) + (and result + (equal? (assq k alist) + (vhash-assoc k vh eq?)))) + #t + keys))))) + + (pass-if "vhash-fold" + (let* ((keys '(a b c d e f g d h i)) + (values '(1 2 3 4 5 6 7 0 8 9)) + (vh (fold vhash-cons vlist-null keys values)) + (alist (fold alist-cons '() keys values))) + (equal? alist (reverse (vhash-fold alist-cons '() vh))))) + + (pass-if "alist->vhash" + (let* ((keys '(a b c d e f g d h i)) + (values '(1 2 3 4 5 6 7 0 8 9)) + (alist (fold alist-cons '() keys values)) + (vh (alist->vhash alist)) + (alist2 (vlist-fold cons '() vh))) + (and (equal? alist (reverse alist2)) + (fold (lambda (k result) + (and result + (equal? (assq k alist) + (vhash-assoc k vh eq?)))) + #t + keys)))))