[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-7-46-ga67
|
From: |
Ludovic Courtès |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-7-46-ga670e67 |
|
Date: |
Tue, 02 Feb 2010 23:54:44 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=a670e672119ac2fb2f6a5b09e0908c07fd7864eb
The branch, master has been updated
via a670e672119ac2fb2f6a5b09e0908c07fd7864eb (commit)
via df685ee46b672c9fe1c3fa813e9406a8dcde9b81 (commit)
via 04ea6fb504b7339f0432b88b8137e5ac455d2309 (commit)
via 5cbf2e1d7b3d744d92e279801f07aa05d1799da3 (commit)
via 22ec6a31eda1f06270fbba4b6aae45bb81de0631 (commit)
via 30a700c8c12aeaefe3cd5fb85ea3c1b7059705bf (commit)
via 61cbfff50979136f03ab161711edc5eb21145609 (commit)
from 9b2a2a391a96070af3e69335f069302f3a08d44a (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit a670e672119ac2fb2f6a5b09e0908c07fd7864eb
Author: Ludovic Courtès <address@hidden>
Date: Tue Feb 2 23:58:03 2010 +0100
Use vhashes in `unused-variable-analysis'.
* module/language/tree-il/analyze.scm (unused-variable-analysis): Use
vhashes instead of alists/lists.
commit df685ee46b672c9fe1c3fa813e9406a8dcde9b81
Author: Ludovic Courtès <address@hidden>
Date: Wed Feb 3 00:00:05 2010 +0100
Use vhashes in `arity-analysis'.
* module/language/tree-il/analyze.scm (arity-analysis): Use vhashes
instead of alists.
commit 04ea6fb504b7339f0432b88b8137e5ac455d2309
Author: Ludovic Courtès <address@hidden>
Date: Tue Feb 2 23:59:34 2010 +0100
Use vhashes in `unbound-variable-analysis'.
* module/language/tree-il/analyze.scm (unbound-variable-analysis): Use
vhashes instead of alists/lists.
commit 5cbf2e1d7b3d744d92e279801f07aa05d1799da3
Author: Ludovic Courtès <address@hidden>
Date: Tue Feb 2 23:59:03 2010 +0100
Use vhashes in `unused-toplevel-analysis'.
* module/language/tree-il/analyze.scm (graph-reachable-nodes): Add
REACHABLE argument. Update to use vhash instead of alists or lists.
(graph-reachable-nodes*): Adjust accordingly.
(partition*): New function.
(unused-toplevel-analysis): Adjust to use vhash instead of alists or
lists.
commit 22ec6a31eda1f06270fbba4b6aae45bb81de0631
Author: Ludovic Courtès <address@hidden>
Date: Tue Feb 2 23:57:02 2010 +0100
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.
-----------------------------------------------------------------------
Summary of changes:
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 ++++++++++++++++++++++++++++++++++
module/language/tree-il/analyze.scm | 265 ++++++++++---------
module/srfi/srfi-9.scm | 5 +-
test-suite/Makefile.am | 1 +
test-suite/lib.scm | 3 +
test-suite/tests/srfi-9.test | 18 +-
test-suite/tests/vlist.test | 303 +++++++++++++++++++++
testsuite/t-records.scm | 3 +-
12 files changed, 1345 insertions(+), 134 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 a9da00e..583519a 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 0000000..329c786
--- /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 e3c45e8..1bedffd 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
address@hidden VLists
address@hidden VLists
+
address@hidden 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:
+
address@hidden
address@hidden
+Random access has typically constant-time complexity.
+
address@hidden
+Computing the length of a VList has time complexity logarithmic in the number
of
+elements.
+
address@hidden
+VLists use less storage space than standard lists.
+
address@hidden
+VList elements are stored in contiguous regions, which improves memory locality
+and leads to more efficient use of hardware caches.
address@hidden 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
address@hidden (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:
+
address@hidden
+
address@hidden
+It is @emph{not} thread-safe. Although operations on vlists are all
address@hidden 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
address@hidden
+
address@hidden
address@hidden 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.
+
address@hidden
address@hidden 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.
+
address@hidden 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.
+
address@hidden {Scheme Procedure} vlist? obj
+Return true if @var{obj} is a VList.
address@hidden deffn
+
address@hidden {Scheme Variable} vlist-null
+The empty VList. Note that it's possible to create an empty VList not
address@hidden to @code{vlist-null}; thus, callers should always use
address@hidden when testing whether a VList is empty.
address@hidden defvr
+
address@hidden {Scheme Procedure} vlist-null? vlist
+Return true if @var{vlist} is empty.
address@hidden deffn
+
address@hidden {Scheme Procedure} vlist-cons item vlist
+Return a new vlist with @var{item} as its head and @var{vlist} as its tail.
address@hidden deffn
+
address@hidden {Scheme Procedure} vlist-head vlist
+Return the head of @var{vlist}.
address@hidden deffn
+
address@hidden {Scheme Procedure} vlist-tail vlist
+Return the tail of @var{vlist}.
address@hidden deffn
+
address@hidden {Scheme Variable} block-growth-factor
+A fluid that defines the growth factor of VList blocks, 2 by default.
address@hidden defvr
+
+The functions below provide the usual set of higher-level list operations.
+
address@hidden {Scheme Procedure} vlist-fold proc init vlist
address@hidden {Scheme Procedure} vlist-fold-right proc init vlist
+Fold over @var{vlist}, calling @var{proc} for each element, as for SRFI-1
address@hidden and @code{fold-right} (@pxref{SRFI-1, @code{fold}}).
address@hidden deffn
+
address@hidden {Scheme Procedure} vlist-ref vlist index
+Return the element at index @var{index} in @var{vlist}. This is typically a
+constant-time operation.
address@hidden deffn
+
address@hidden {Scheme Procedure} vlist-length vlist
+Return the length of @var{vlist}. This is typically logarithmic in the number
+of elements in @var{vlist}.
address@hidden deffn
+
address@hidden {Scheme Procedure} vlist-reverse vlist
+Return a new @var{vlist} whose content are those of @var{vlist} in reverse
+order.
address@hidden deffn
+
address@hidden {Scheme Procedure} vlist-map proc vlist
+Map @var{proc} over the elements of @var{vlist} and return a new vlist.
address@hidden deffn
+
address@hidden {Scheme Procedure} vlist-for-each proc vlist
+Call @var{proc} on each element of @var{vlist}. The result is unspecified.
address@hidden deffn
+
address@hidden {Scheme Procedure} vlist-drop vlist count
+Return a new vlist that does not contain the @var{count} first elements of
address@hidden This is typically a constant-time operation.
address@hidden deffn
+
address@hidden {Scheme Procedure} vlist-take vlist count
+Return a new vlist that contains only the @var{count} first elements of
address@hidden
address@hidden deffn
+
address@hidden {Scheme Procedure} vlist-filter pred vlist
+Return a new vlist containing all the elements from @var{vlist} that satisfy
address@hidden
address@hidden deffn
+
address@hidden {Scheme Procedure} vlist-delete x vlist [equal?]
+Return a new vlist corresponding to @var{vlist} without the elements
address@hidden to @var{x}.
address@hidden deffn
+
address@hidden {Scheme Procedure} vlist-unfold p f g seed [tail-gen]
address@hidden {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}}).
address@hidden deffn
+
address@hidden {Scheme Procedure} vlist-append vlists ...
+Append the given vlists and return the resulting vlist.
address@hidden deffn
+
address@hidden {Scheme Procedure} list->vlist lst
+Return a new vlist whose contents correspond to @var{lst}.
address@hidden deffn
+
address@hidden {Scheme Procedure} vlist->list vlist
+Return a new list whose contents match those of @var{vlist}.
address@hidden deffn
+
+
+
@node Records
@subsection Records
@@ -3030,6 +3198,118 @@ capitals
("Florida" . "Tallahassee"))
@end lisp
address@hidden VHashes
address@hidden VList-Based Hash Lists or ``VHashes''
+
address@hidden VList-based hash lists
address@hidden 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
address@hidden 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
address@hidden instead of @code{vlist-} (@pxref{SRFI-1 Association Lists}).
+
+In addition, vhashes can be manipulated using VList operations:
+
address@hidden
+(vlist-head (vhash-consq 'a 1 vlist-null))
address@hidden (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)
address@hidden (a . 1)
+(vhash-assq 'b vh2)
address@hidden #f
+(vhash-assq 'c vh2)
address@hidden (c . 3)
+(vlist->list vh2)
address@hidden ((c . 3) (a . 1))
address@hidden example
+
+However, keep in mind that procedures that construct new VLists
+(@code{vlist-map}, @code{vlist-filter}, etc.) return raw VLists, not vhashes:
+
address@hidden
+(define vh (alist->vhash '((a . 1) (b . 2) (c . 3)) hashq))
+(vhash-assq 'a vh)
address@hidden (a . 1)
+
+(define vl
+ ;; This will create a raw vlist.
+ (vlist-filter (lambda (key+value) (odd? (cdr key+value))) vh))
+(vhash-assq 'a vl)
address@hidden ERROR: Wrong type argument in position 2
+
+(vlist->list vl)
address@hidden ((a . 1) (c . 3))
address@hidden example
+
address@hidden {Scheme Procedure} vhash? obj
+Return true if @var{obj} is a vhash.
address@hidden deffn
+
address@hidden {Scheme Procedure} vhash-cons key value vhash [hash-proc]
address@hidden {Scheme Procedure} vhash-consq key value vhash
address@hidden {Scheme Procedure} vhash-consv key value vhash
+Return a new hash list based on @var{vhash} where @var{key} is associated with
address@hidden, using @var{hash-proc} to compute the hash of @var{key}.
address@hidden 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
address@hidden 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
address@hidden Failing to do that, the result is undefined.
address@hidden deffn
+
address@hidden {Scheme Procedure} vhash-assoc key vhash [equal? [hash-proc]]
address@hidden {Scheme Procedure} vhash-assq key vhash
address@hidden {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
address@hidden), 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
address@hidden as was passed to @code{vhash-cons}. Failing to do that, the
+result is unpredictable.
address@hidden deffn
+
address@hidden {Scheme Procedure} vhash-delete key vhash [equal? [hash-proc]]
address@hidden {Scheme Procedure} vhash-delq key vhash
address@hidden {Scheme Procedure} vhash-delv key vhash
+Remove all associations from @var{vhash} with @var{key}, comparing keys with
address@hidden (which defaults to @code{equal?}), and computing the hash of
address@hidden 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
address@hidden
address@hidden deffn
+
address@hidden {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)}.
address@hidden deffn
+
address@hidden {Scheme Procedure} alist->vhash alist [hash-proc]
+Return the vhash corresponding to @var{alist}, an association list, using
address@hidden to compute key hashes. When omitted, @var{hash-proc} defaults
+to @code{hash}.
address@hidden deffn
+
+
@node Hash Tables
@subsection Hash Tables
@tpindex Hash Tables
diff --git a/module/Makefile.am b/module/Makefile.am
index fac005a..0ee2d1c 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 0000000..dd62661
--- /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 <address@hidden>
+;;;
+;;; 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 <vlist>
+ ;; A vlist is just a base+offset pair pointing to a block.
+
+ ;; XXX: Allocating a <vlist> 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
address@hidden"
+ (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
address@hidden"
+ (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
address@hidden 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
address@hidden 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
address@hidden"
+ (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
address@hidden"
+ (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
address@hidden 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/module/language/tree-il/analyze.scm
b/module/language/tree-il/analyze.scm
index b80dd89..1143dab 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -22,6 +22,7 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
+ #:use-module (ice-9 vlist)
#:use-module (system base syntax)
#:use-module (system base message)
#:use-module (system vm program)
@@ -593,7 +594,7 @@ accurate information is missing from a given `tree-il'
element."
(vars (binding-info-vars info)))
(record-case x
((<lexical-ref> gensym)
- (make-binding-info vars (cons gensym refs)))
+ (make-binding-info vars (vhash-consq gensym #t refs)))
(else info))))
(lambda (x info env locs)
@@ -603,14 +604,15 @@ accurate information is missing from a given `tree-il'
element."
(vars (binding-info-vars info))
(src (tree-il-src x)))
(define (extend inner-vars inner-names)
- (append (map (lambda (var name)
- (list var name src))
- inner-vars
- inner-names)
- vars))
+ (fold (lambda (var name vars)
+ (vhash-consq var (list name src) vars))
+ vars
+ inner-vars
+ inner-names))
+
(record-case x
((<lexical-set> gensym)
- (make-binding-info vars (cons gensym refs)))
+ (make-binding-info vars (vhash-consq gensym #t refs)))
((<lambda-case> req opt inits rest kw vars)
(let ((names `(,@req
,@(or opt '())
@@ -631,25 +633,21 @@ accurate information is missing from a given `tree-il'
element."
(let ((refs (binding-info-refs info))
(vars (binding-info-vars info)))
(define (shrink inner-vars refs)
- (for-each (lambda (var)
- (let ((gensym (car var)))
- ;; Don't report lambda parameters as
- ;; unused.
- (if (and (not (memq gensym refs))
- (not (and (lambda-case? x)
- (memq gensym
- inner-vars))))
- (let ((name (cadr var))
- ;; We can get approximate
- ;; source location by going up
- ;; the LOCS location stack.
- (loc (or (caddr var)
- (find pair? locs))))
- (warning 'unused-variable loc name)))))
- (filter (lambda (var)
- (memq (car var) inner-vars))
- vars))
- (fold alist-delete vars inner-vars))
+ (vlist-for-each
+ (lambda (var)
+ (let ((gensym (car var)))
+ ;; Don't report lambda parameters as unused.
+ (if (and (memq gensym inner-vars)
+ (not (vhash-assq gensym refs))
+ (not (lambda-case? x)))
+ (let ((name (cadr var))
+ ;; We can get approximate source location by going up
+ ;; the LOCS location stack.
+ (loc (or (caddr var)
+ (find pair? locs))))
+ (warning 'unused-variable loc name)))))
+ vars)
+ (vlist-drop vars (length inner-vars)))
;; For simplicity, we leave REFS untouched, i.e., with
;; names of variables that are now going out of scope.
@@ -667,7 +665,7 @@ accurate information is missing from a given `tree-il'
element."
(else info))))
(lambda (result env) #t)
- (make-binding-info '() '())))
+ (make-binding-info vlist-null vlist-null)))
;;;
@@ -686,9 +684,10 @@ accurate information is missing from a given `tree-il'
element."
(refs reference-graph-refs) ;; ((REF-CONTEXT REF ...) ...)
(toplevel-context reference-graph-toplevel-context)) ;; NAME | #f
-(define (graph-reachable-nodes root refs)
- ;; Return the list of nodes reachable from ROOT in graph REFS. REFS is an
alist
- ;; representing edges: ((A B C) (B A) (C)) corresponds to
+(define (graph-reachable-nodes root refs reachable)
+ ;; Add to REACHABLE the nodes reachable from ROOT in graph REFS. REFS is a
+ ;; vhash mapping nodes to the list of their children: for instance,
+ ;; ((A -> (B C)) (B -> (A)) (C -> ())) corresponds to
;;
;; ,-------.
;; v |
@@ -696,30 +695,49 @@ accurate information is missing from a given `tree-il'
element."
;; |
;; v
;; C
+ ;;
+ ;; REACHABLE is a vhash of nodes known to be otherwise reachable.
(let loop ((root root)
- (path '())
- (result '()))
- (if (or (memq root path)
- (memq root result))
+ (path vlist-null)
+ (result reachable))
+ (if (or (vhash-assq root path)
+ (vhash-assq root result))
result
- (let ((children (assoc-ref refs root)))
- (if (not children)
- result
- (let ((path (cons root path)))
- (append children
- (fold (lambda (child result)
- (loop child path result))
- result
- children))))))))
+ (let* ((children (or (and=> (vhash-assq root refs) cdr) '()))
+ (path (vhash-consq root #t path))
+ (result (fold (lambda (kid result)
+ (loop kid path result))
+ result
+ children)))
+ (fold (lambda (kid result)
+ (vhash-consq kid #t result))
+ result
+ children)))))
(define (graph-reachable-nodes* roots refs)
;; Return the list of nodes in REFS reachable from the nodes listed in ROOTS.
- ;; FIXME: Choose a more efficient algorithm.
- (apply lset-union eq?
- (map (lambda (node)
- (cons node (graph-reachable-nodes node refs)))
- roots)))
+ (vlist-fold (lambda (root+true result)
+ (let* ((root (car root+true))
+ (reachable (graph-reachable-nodes root refs result)))
+ (vhash-consq root #t reachable)))
+ vlist-null
+ roots))
+
+(define (partition* pred vhash)
+ ;; Partition VHASH according to PRED. Return the two resulting vhashes.
+ (let ((result
+ (vlist-fold (lambda (k+v result)
+ (let ((k (car k+v))
+ (v (cdr k+v))
+ (r1 (car result))
+ (r2 (cdr result)))
+ (if (pred k)
+ (cons (vhash-consq k v r1) r2)
+ (cons r1 (vhash-consq k v r2)))))
+ (cons vlist-null vlist-null)
+ vhash)))
+ (values (car result) (cdr result))))
(define unused-toplevel-analysis
;; Report unused top-level definitions that are not exported.
@@ -729,9 +747,8 @@ accurate information is missing from a given `tree-il'
element."
(let* ((refs (reference-graph-refs graph))
(defs (reference-graph-defs graph))
(ctx (reference-graph-toplevel-context graph))
- (ctx-refs (or (assoc-ref refs ctx) '())))
- (make-reference-graph (alist-cons ctx (cons name ctx-refs)
- (alist-delete ctx refs eq?))
+ (ctx-refs (or (and=> (vhash-assq ctx refs) cdr) '())))
+ (make-reference-graph (vhash-consq ctx (cons name ctx-refs) refs)
defs ctx)))))
(define (macro-variable? name env)
(and (module? env)
@@ -756,8 +773,8 @@ accurate information is missing from a given `tree-il'
element."
(record-case x
((<toplevel-define> name src)
(let ((refs refs)
- (defs (alist-cons name (or src (find pair? locs))
- defs)))
+ (defs (vhash-consq name (or src (find pair? locs))
+ defs)))
(make-reference-graph refs defs name)))
((<toplevel-set> name src)
(add-ref-from-context graph name))
@@ -787,27 +804,24 @@ accurate information is missing from a given `tree-il'
element."
#t))
(let-values (((public-defs private-defs)
- (partition (lambda (name+src)
- (let ((name (car name+src)))
- (or (exported? name)
- (macro-variable? name env))))
- (reference-graph-defs graph))))
- (let* ((roots (cons #f (map car public-defs)))
+ (partition* (lambda (name)
+ (or (exported? name)
+ (macro-variable? name env)))
+ (reference-graph-defs graph))))
+ (let* ((roots (vhash-consq #f #t public-defs))
(refs (reference-graph-refs graph))
(reachable (graph-reachable-nodes* roots refs))
- (unused (filter (lambda (name+src)
- ;; FIXME: This is inefficient when
- ;; REACHABLE is large (e.g., boot-9.scm);
- ;; use a vhash or equivalent.
- (not (memq (car name+src) reachable)))
- private-defs)))
- (for-each (lambda (name+loc)
- (let ((name (car name+loc))
- (loc (cdr name+loc)))
- (warning 'unused-toplevel loc name)))
- (reverse unused)))))
-
- (make-reference-graph '() '() #f))))
+ (unused (vlist-filter (lambda (name+src)
+ (not (vhash-assq (car name+src)
+ reachable)))
+ private-defs)))
+ (vlist-for-each (lambda (name+loc)
+ (let ((name (car name+loc))
+ (loc (cdr name+loc)))
+ (warning 'unused-toplevel loc name)))
+ unused))))
+
+ (make-reference-graph vlist-null vlist-null #f))))
;;;
@@ -859,14 +873,14 @@ accurate information is missing from a given `tree-il'
element."
(define (bound? name)
(or (and (module? env)
(module-variable env name))
- (memq name defs)))
+ (vhash-assq name defs)))
(record-case x
((<toplevel-ref> name src)
(if (bound? name)
info
(let ((src (or src (find pair? locs))))
- (make-toplevel-info (alist-cons name src refs)
+ (make-toplevel-info (vhash-consq name src refs)
defs))))
(else info))))
@@ -878,18 +892,18 @@ accurate information is missing from a given `tree-il'
element."
(define (bound? name)
(or (and (module? env)
(module-variable env name))
- (memq name defs)))
+ (vhash-assq name defs)))
(record-case x
((<toplevel-set> name src)
(if (bound? name)
(make-toplevel-info refs defs)
(let ((src (find pair? locs)))
- (make-toplevel-info (alist-cons name src refs)
+ (make-toplevel-info (vhash-consq name src refs)
defs))))
((<toplevel-define> name)
- (make-toplevel-info (alist-delete name refs eq?)
- (cons name defs)))
+ (make-toplevel-info (vhash-delete name refs eq?)
+ (vhash-consq name #t defs)))
((<application> proc args)
;; Check for a dynamic top-level definition, as is
@@ -897,9 +911,9 @@ accurate information is missing from a given `tree-il'
element."
(let ((name (goops-toplevel-definition proc args
env)))
(if (symbol? name)
- (make-toplevel-info (alist-delete name refs
+ (make-toplevel-info (vhash-delete name refs
eq?)
- (cons name defs))
+ (vhash-consq name #t defs))
(make-toplevel-info refs defs))))
(else
(make-toplevel-info refs defs)))))
@@ -910,13 +924,13 @@ accurate information is missing from a given `tree-il'
element."
(lambda (toplevel env)
;; Post-process the result.
- (for-each (lambda (name+loc)
- (let ((name (car name+loc))
- (loc (cdr name+loc)))
- (warning 'unbound-variable loc name)))
- (reverse (toplevel-info-refs toplevel))))
+ (vlist-for-each (lambda (name+loc)
+ (let ((name (car name+loc))
+ (loc (cdr name+loc)))
+ (warning 'unbound-variable loc name)))
+ (vlist-reverse (toplevel-info-refs toplevel))))
- (make-toplevel-info '() '())))
+ (make-toplevel-info vlist-null vlist-null)))
;;;
@@ -1037,20 +1051,20 @@ accurate information is missing from a given `tree-il'
element."
(record-case val
((<lambda> body)
(make-arity-info toplevel-calls
- (alist-cons lexical-name val
- lexical-lambdas)
+ (vhash-consq lexical-name val
+ lexical-lambdas)
toplevel-lambdas))
((<lexical-ref> gensym)
;; lexical alias
- (let ((val* (assq gensym lexical-lambdas)))
+ (let ((val* (vhash-assq gensym lexical-lambdas)))
(if (pair? val*)
(extend lexical-name (cdr val*) info)
info)))
((<toplevel-ref> name)
;; top-level alias
(make-arity-info toplevel-calls
- (alist-cons lexical-name val
- lexical-lambdas)
+ (vhash-consq lexical-name val
+ lexical-lambdas)
toplevel-lambdas))
(else info))))
@@ -1064,17 +1078,17 @@ accurate information is missing from a given `tree-il'
element."
((<lambda> body)
(make-arity-info toplevel-calls
lexical-lambdas
- (alist-cons name exp toplevel-lambdas)))
+ (vhash-consq name exp toplevel-lambdas)))
((<toplevel-ref> name)
;; alias for another toplevel
- (let ((proc (assq name toplevel-lambdas)))
+ (let ((proc (vhash-assq name toplevel-lambdas)))
(make-arity-info toplevel-calls
lexical-lambdas
- (alist-cons (toplevel-define-name x)
- (if (pair? proc)
- (cdr proc)
- exp)
- toplevel-lambdas))))
+ (vhash-consq (toplevel-define-name x)
+ (if (pair? proc)
+ (cdr proc)
+ exp)
+ toplevel-lambdas))))
(else info)))
((<let> vars vals)
(fold extend info vars vals))
@@ -1089,16 +1103,16 @@ accurate information is missing from a given `tree-il'
element."
(validate-arity proc x #t)
info)
((<toplevel-ref> name)
- (make-arity-info (alist-cons name x toplevel-calls)
+ (make-arity-info (vhash-consq name x toplevel-calls)
lexical-lambdas
toplevel-lambdas))
((<lexical-ref> gensym)
- (let ((proc (assq gensym lexical-lambdas)))
+ (let ((proc (vhash-assq gensym lexical-lambdas)))
(if (pair? proc)
(record-case (cdr proc)
((<toplevel-ref> name)
;; alias to toplevel
- (make-arity-info (alist-cons name x toplevel-calls)
+ (make-arity-info (vhash-consq name x toplevel-calls)
lexical-lambdas
toplevel-lambdas))
(else
@@ -1119,7 +1133,9 @@ accurate information is missing from a given `tree-il'
element."
(lexical-lambdas (lexical-lambdas info))
(toplevel-lambdas (toplevel-lambdas info)))
(make-arity-info toplevel-calls
- (alist-delete name lexical-lambdas eq?)
+ (if (vhash-assq name lexical-lambdas)
+ (vlist-tail lexical-lambdas)
+ lexical-lambdas)
toplevel-lambdas)))
(let ((toplevel-calls (toplevel-procedure-calls info))
@@ -1140,26 +1156,25 @@ accurate information is missing from a given `tree-il'
element."
;; encountered.
(let ((toplevel-calls (toplevel-procedure-calls result))
(toplevel-lambdas (toplevel-lambdas result)))
- (for-each (lambda (name+application)
- (let* ((name (car name+application))
- (application (cdr name+application))
- (proc
- (or (assoc-ref toplevel-lambdas name)
- (and (module? env)
- (false-if-exception
- (module-ref env name)))))
- (proc*
- ;; handle toplevel aliases
- (if (toplevel-ref? proc)
- (let ((name (toplevel-ref-name proc)))
- (and (module? env)
- (false-if-exception
- (module-ref env name))))
- proc)))
- ;; (format #t "toplevel-call to ~A (~A) from ~A~%"
- ;; name proc* application)
- (if (or (lambda? proc*) (procedure? proc*))
- (validate-arity proc* application (lambda? proc*)))))
- toplevel-calls)))
-
- (make-arity-info '() '() '())))
+ (vlist-for-each
+ (lambda (name+application)
+ (let* ((name (car name+application))
+ (application (cdr name+application))
+ (proc
+ (or (and=> (vhash-assq name toplevel-lambdas) cdr)
+ (and (module? env)
+ (false-if-exception
+ (module-ref env name)))))
+ (proc*
+ ;; handle toplevel aliases
+ (if (toplevel-ref? proc)
+ (let ((name (toplevel-ref-name proc)))
+ (and (module? env)
+ (false-if-exception
+ (module-ref env name))))
+ proc)))
+ (if (or (lambda? proc*) (procedure? proc*))
+ (validate-arity proc* application (lambda? proc*)))))
+ toplevel-calls)))
+
+ (make-arity-info vlist-null vlist-null vlist-null)))
diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm
index bd7dae8..39f4e34 100644
--- a/module/srfi/srfi-9.scm
+++ b/module/srfi/srfi-9.scm
@@ -1,6 +1,6 @@
;;; srfi-9.scm --- define-record-type
-;; Copyright (C) 2001, 2002, 2006, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2002, 2006, 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
@@ -88,6 +88,7 @@
((_ formals ...)
#'(begin body ...))
(_
+ (identifier? x)
#'proc-name))))))))))
(define-syntax define-record-type
@@ -118,7 +119,7 @@
(ctor-args (map (lambda (field)
(cons (syntax->datum field) field))
#'(field ...))))
- #`(define #,constructor-spec
+ #`(define-inlinable #,constructor-spec
(make-struct #,type-name 0
#,@(unfold
(lambda (field-num)
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index f29b1ca..c65f4d3 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/lib.scm b/test-suite/lib.scm
index 1e78c71..d67b957 100644
--- a/test-suite/lib.scm
+++ b/test-suite/lib.scm
@@ -22,6 +22,7 @@
:export (
;; Exceptions which are commonly being tested for.
+ exception:syntax-pattern-unmatched
exception:bad-variable
exception:missing-expression
exception:out-of-range exception:unbound-var
@@ -248,6 +249,8 @@ with-locale with-locale*
;;;;
;;; Define some exceptions which are commonly being tested for.
+(define exception:syntax-pattern-unmatched
+ (cons 'syntax-error "source expression failed to match any pattern"))
(define exception:bad-variable
(cons 'syntax-error "Bad variable"))
(define exception:missing-expression
diff --git a/test-suite/tests/srfi-9.test b/test-suite/tests/srfi-9.test
index f8cb0b4..a645ddc 100644
--- a/test-suite/tests/srfi-9.test
+++ b/test-suite/tests/srfi-9.test
@@ -1,7 +1,7 @@
;;;; srfi-9.test --- Test suite for Guile's SRFI-9 functions. -*- scheme -*-
;;;; Martin Grabmueller, 2001-05-10
;;;;
-;;;; Copyright (C) 2001, 2006, 2007 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2006, 2007, 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
@@ -19,6 +19,7 @@
(define-module (test-suite test-numbers)
#:use-module (test-suite lib)
+ #:use-module ((system base compile) #:select (compile))
#:use-module (srfi srfi-9))
@@ -35,10 +36,21 @@
(with-test-prefix "constructor"
+ ;; Constructors are defined using `define-integrable', meaning that direct
+ ;; calls as in `(make-foo)' lead to a compile-time psyntax error, hence the
+ ;; distinction below.
+
+ (pass-if-exception "foo 0 args (inline)" exception:syntax-pattern-unmatched
+ (compile '(make-foo) #:env (current-module)))
+ (pass-if-exception "foo 2 args (inline)" exception:syntax-pattern-unmatched
+ (compile '(make-foo 1 2) #:env (current-module)))
+
(pass-if-exception "foo 0 args" exception:wrong-num-args
- (make-foo))
+ (let ((make-foo make-foo))
+ (make-foo)))
(pass-if-exception "foo 2 args" exception:wrong-num-args
- (make-foo 1 2)))
+ (let ((make-foo make-foo))
+ (make-foo 1 2))))
(with-test-prefix "predicate"
diff --git a/test-suite/tests/vlist.test b/test-suite/tests/vlist.test
new file mode 100644
index 0000000..47e386e
--- /dev/null
+++ b/test-suite/tests/vlist.test
@@ -0,0 +1,303 @@
+;;;; vlist.test --- VLists. -*- mode: scheme; coding: utf-8; -*-
+;;;;
+;;;; Ludovic Courtès <address@hidden>
+;;;;
+;;;; 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)))))
diff --git a/testsuite/t-records.scm b/testsuite/t-records.scm
index 0cb320d..9aa4daa 100644
--- a/testsuite/t-records.scm
+++ b/testsuite/t-records.scm
@@ -11,5 +11,4 @@
(and (stuff? (%make-stuff 12))
(= 7 (stuff:chbouib (%make-stuff 7)))
- (not (stuff? 12))
- (not (false-if-exception (%make-stuff))))
+ (not (stuff? 12)))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-7-46-ga670e67,
Ludovic Courtès <=