[fset-cvs] r20 - trunk/Code
Scott L. Burson
sburson at common-lisp.net
Mon Nov 3 05:08:58 UTC 2008
Author: sburson
Date: Mon Nov 3 05:08:58 2008
New Revision: 20
Log:
Some final tweaks for the 1.2 release.
Modified:
trunk/Code/fset.lisp
trunk/Code/interval.lisp
trunk/Code/port.lisp
trunk/Code/relations.lisp
trunk/Code/tuples.lisp
trunk/Code/wb-trees.lisp
Modified: trunk/Code/fset.lisp
==============================================================================
--- trunk/Code/fset.lisp (original)
+++ trunk/Code/fset.lisp Mon Nov 3 05:08:58 2008
@@ -1847,7 +1847,6 @@
(map-default m)))
(defmethod domain ((m wb-map))
- ;; &&& Cache this? It's pretty fast anyway.
(make-wb-set (WB-Map-Tree-Domain (wb-map-contents m))))
(defmethod compare ((map1 wb-map) (map2 wb-map))
Modified: trunk/Code/interval.lisp
==============================================================================
--- trunk/Code/interval.lisp (original)
+++ trunk/Code/interval.lisp Mon Nov 3 05:08:58 2008
@@ -390,11 +390,12 @@
;;; for this). Adam Megacz calls it a "topological bag", but that doesn't seem
;;; right to me (it's certainly not a bag in the sense in which I use the word).
+#|| Someday
(defstruct (interval-set-relation
(:constructor make-interval-set-relation (contents))
(:predicate interval-set-relation?)
(:print-function print-interval-set-relation)
(:copier nil))
contents)
-
+||#
Modified: trunk/Code/port.lisp
==============================================================================
--- trunk/Code/port.lisp (original)
+++ trunk/Code/port.lisp Mon Nov 3 05:08:58 2008
@@ -28,39 +28,42 @@
(defmacro write-memory-barrier ()
'nil))
-#+(and allegro os-threads)
+#+(and allegro os-threads) ; &&& untested
(progn
- (defun make-lock (&optional (name "A lock"))
- (mp:make-process-lock :name name))
+ (defun make-lock (&optional name)
+ (apply #'mp:make-process-lock (and name `(:name ,name))))
(defmacro with-lock ((lock &key (wait? t)) &body body)
- ;; See the OpenMCL code below for a suggestion of how to implement non-waiting
- ;; mode (Allegro doesn't have it built in).
- (error "&&& Write me"))
- (defvar *Allegro-Read-Memory-Barrier-Lock*
- (mp:make-process-lock :name "Read Memory Barrier Lock"))
- (defmacro read-memory-barrier ()
- ;; Allegro doesn't seem to have any better way to do this.
- (mp:with-process-lock (*Allegro-Read-Memory-Barrier-Lock*)
- nil))
- (defvar *Allegro-Write-Memory-Barrier-Lock*
- (mp:make-process-lock :name "Write Memory Barrier Lock"))
+ `(mp:with-process-lock (,lock :timeout (if ,wait? nil 0))
+ . ,body))
+ ;; For those implementations that support SMP but don't give us direct ways
+ ;; to generate memory barriers, we assume that grabbing a lock suffices.
+ (deflex *Memory-Barrier-Lock*
+ (mp:make-process-lock :name "Memory Barrier Lock"))
+ (defmacro read-memory-barrier ()
+ '(mp:with-process-lock (*Memory-Barrier-Lock*)
+ nil))
(defmacro write-memory-barrier ()
- ;; Allegro doesn't seem to have any better way to do this.
- (mp:with-process-lock (*Allegro-Write-Memory-Barrier-Lock*)
- nil)))
+ '(mp:with-process-lock (*Memory-Barrier-Lock*)
+ nil)))
+
#+lispworks
(progn
(defun make-lock (&optional name)
- (declare (ignore name))
- nil)
+ (apply #'mp:make-lock (and name `(:name ,name))))
(defmacro with-lock ((lock &key (wait? t)) &body body)
- (declare (ignore lock wait?))
- `(mp:without-interrupts . ,body))
+ `(mp:with-lock (,lock :timeout (if ,wait? nil 0))
+ . ,body))
+ ;; For those implementations that support SMP but don't give us direct ways
+ ;; to generate memory barriers, we assume that grabbing a lock suffices.
+ (deflex *Memory-Barrier-Lock*
+ (mp:make-lock :name "Memory Barrier Lock"))
(defmacro read-memory-barrier ()
- 'nil)
+ '(mp:with-lock (*Memory-Barrier-Lock*)
+ nil))
(defmacro write-memory-barrier ()
- 'nil))
+ '(mp:with-lock (*Memory-Barrier-Lock*)
+ nil)))
#+cmu
@@ -76,33 +79,38 @@
(defmacro write-memory-barrier ()
'nil))
-#+sbcl
+
+#+(and sbcl (not sb-thread))
(progn
(defun make-lock (&optional name)
- (sb-thread:make-mutex :name name))
+ nil)
(defmacro with-lock ((lock &key (wait? t)) &body body)
- `(sb-thread:with-mutex (,lock :wait-p ,wait?)
+ (declare (ignore lock wait?))
+ `(progn
. ,body))
- #-sb-thread
(progn
(defmacro read-memory-barrier ()
- nil)
+ 'nil)
(defmacro write-memory-barrier ()
- nil))
- #+sb-thread
- (progn
- (defvar *SBCL-Read-Memory-Barrier-Lock*
- (sb-thread:make-mutex :name "Read Memory Barrier Lock"))
- (defmacro read-memory-barrier ()
- ;; SBCL doesn't seem to have any better way to do this (yet).
- (mp:with-process-lock (*SBCL-Read-Memory-Barrier-Lock*)
- nil))
- (defvar *SBCL-Write-Memory-Barrier-Lock*
- (sb-thread:make-mutex :name "Write Memory Barrier Lock"))
- (defmacro write-memory-barrier ()
- ;; SBCL doesn't seem to have any better way to do this (yet).
- (mp:with-process-lock (*SBCL-Write-Memory-Barrier-Lock*)
- nil))))
+ 'nil)))
+
+#+(and sbcl sb-thread)
+(progn
+ (defun make-lock (&optional name)
+ (apply #'sb-thread:make-mutex (and name `(:name ,name))))
+ (defmacro with-lock ((lock &key (wait? t)) &body body)
+ `(sb-thread:with-mutex (,lock :wait-p ,wait?)
+ . ,body))
+ ;; For those implementations that support SMP but don't give us direct ways
+ ;; to generate memory barriers, we assume that grabbing a lock suffices.
+ (deflex *Memory-Barrier-Lock*
+ (sb-thread:make-mutex :name "Memory Barrier Lock"))
+ (defmacro read-memory-barrier ()
+ '(mp:with-process-lock (*Memory-Barrier-Lock*)
+ nil))
+ (defmacro write-memory-barrier ()
+ '(mp:with-process-lock (*Memory-Barrier-Lock*)
+ nil)))
#+scl
@@ -111,12 +119,13 @@
(thread:make-lock name :type ':recursive :auto-free t))
(defmacro with-lock ((lock &key (wait? t)) &body body)
`(thread:with-lock-held (,lock "Lock Wait" :wait ,wait?)
- . ,body))
+ . ,body))
(defmacro read-memory-barrier ()
'(kernel:read-memory-barrier))
(defmacro write-memory-barrier ()
'(kernel:write-memory-barrier)))
+
#+openmcl
(progn
(defun make-lock (&optional name)
@@ -139,18 +148,17 @@
. ,body))
(when ,try-succeeded?-var
(ccl:release-lock ,lock-var)))))))
- (defvar *OpenMCL-Read-Memory-Barrier-Lock*
- (ccl:make-lock "Read Memory Barrier Lock"))
+ ;; For those implementations that support SMP but don't give us direct ways
+ ;; to generate memory barriers, we assume that grabbing a lock suffices.
+ (deflex *Memory-Barrier-Lock*
+ (ccl:make-lock "Memory Barrier Lock"))
(defmacro read-memory-barrier ()
- ;; OpenMCL doesn't seem to have any better way to do this.
- (ccl:with-lock-grabbed (*OpenMCL-Read-Memory-Barrier-Lock*)
- nil))
- (defvar *OpenMCL-Write-Memory-Barrier-Lock*
- (ccl:make-lock "Write Memory Barrier Lock"))
+ `(ccl:with-lock-grabbed (*Memory-Barrier-Lock*)
+ nil))
(defmacro write-memory-barrier ()
- ;; OpenMCL doesn't seem to have any better way to do this.
- (ccl:with-lock-grabbed (*OpenMCL-Write-Memory-Barrier-Lock*)
- nil)))
+ `(ccl:with-lock-grabbed (*Memory-Barrier-Lock*)
+ nil)))
+
#+(and genera new-scheduler)
(progn
@@ -165,7 +173,7 @@
(defmacro read-memory-barrier ()
'nil))
-;;; Some implementations have no threading at all (yet).
+
#+clisp
(progn
(defun make-lock (&optional name)
@@ -180,6 +188,54 @@
'nil))
+#+(and ecl (not threads))
+(progn
+ (defun make-lock (&optional name)
+ (declare (ignore name))
+ nil)
+ (defmacro with-lock ((lock &key (wait? t)) &body body)
+ (declare (ignore lock wait?))
+ `(progn . ,body))
+ (defmacro read-memory-barrier ()
+ 'nil)
+ (defmacro write-memory-barrier ()
+ 'nil))
+
+#+(and ecl threads)
+(progn
+ (defun make-lock (&optional name)
+ (apply #'mp:make-lock (and name `(:name ,name))))
+ (defmacro with-lock ((lock &key (wait? t)) &body body)
+ (let ((lock-var (gensym "LOCK-"))
+ (wait?-var (gensym "WAIT?-"))
+ (try-succeeded?-var (gensym "TRY-SUCCEEDED?-")))
+ `(let ((,lock-var ,lock)
+ . ,(and (not (eq wait? 't))
+ `((,wait?-var ,wait?)
+ (,try-succeeded?-var nil))))
+ ,(if (eq wait? 't)
+ `(mp:with-lock (,lock-var)
+ . ,body)
+ `(unwind-protect
+ (and (or ,wait?-var (and (mp:get-lock ,lock-var nil)
+ (setq ,try-succeeded?-var t)))
+ (mp:with-lock (,lock-var)
+ . ,body))
+ (when ,try-succeeded?-var
+ (mp:giveup-lock ,lock-var)))))))
+ (deflex *ECL-Read-Memory-Barrier-Lock*
+ (mp:make-lock :name "Read Memory Barrier Lock"))
+ (defmacro read-memory-barrier ()
+ '(mp:with-lock (*ECL-Read-Memory-Barrier-Lock*)
+ nil))
+ (deflex *ECL-Write-Memory-Barrier-Lock*
+ (mp:make-lock :name "Write Memory Barrier Lock"))
+ (defmacro write-memory-barrier ()
+ '(mp:with-lock (*ECL-Write-Memory-Barrier-Lock*)
+ nil)))
+
+
+
;;; ----------------
;;; Constants used by the tuple implementation. We choose the widths of
@@ -187,9 +243,11 @@
(defconstant Tuple-Key-Number-Size
(ecase (integer-length most-positive-fixnum)
+ (61 40) ; ECL, 64-bit
(60 40) ; SBCL, OpenMCL, Scieneer CL, 64-bit
+ (48 32) ; CLISP, 64-bit
(31 18) ; Symbolics L-machine, I-machine
- (29 17) ; Allegro, CMUCL, SBCL, LispWorks (most), 32-bit
+ (29 17) ; Allegro, CMUCL, SBCL, LispWorks (most), ECL, 32-bit
(24 15) ; CLISP, 32-bit
(23 14)) ; LispWorks 4 on Linux
"This limits the number of tuple-keys that can exist in a session.")
@@ -199,7 +257,9 @@
(defconstant Tuple-Value-Index-Size
(ecase (integer-length most-positive-fixnum)
+ (61 21)
(60 20)
+ (48 16)
(31 13)
(29 12)
(24 9)
Modified: trunk/Code/relations.lisp
==============================================================================
--- trunk/Code/relations.lisp (original)
+++ trunk/Code/relations.lisp Mon Nov 3 05:08:58 2008
@@ -448,18 +448,18 @@
nil))))))
-(defgeneric closure (2-relation set)
+(defgeneric transitive-closure (2-relation set)
(:documentation
"The transitive closure of the set over the relation. The relation may
also be supplied as a function returning a set."))
-(defmethod closure ((fn function) (s set))
- (set-closure fn s))
+(defmethod transitive-closure ((fn function) (s set))
+ (set-transitive-closure fn s))
-(defmethod closure ((r 2-relation) (s set))
- (set-closure r s))
+(defmethod transitive-closure ((r 2-relation) (s set))
+ (set-transitive-closure r s))
-(defun set-closure (r s)
+(defun set-transitive-closure (r s)
;; This could probably use a little moer work.
(let ((workset (set-difference
(reduce #'union (image r (convert 'seq s)) :initial-value (set))
Modified: trunk/Code/tuples.lisp
==============================================================================
--- trunk/Code/tuples.lisp (original)
+++ trunk/Code/tuples.lisp Mon Nov 3 05:08:58 2008
@@ -124,11 +124,11 @@
; (called with one argument, the tuple), or nil
number) ; used for lookup and sorting
-(defvar *Tuple-Key-Name-Map* (empty-map))
+(deflex +Tuple-Key-Name-Map+ (empty-map))
-(defvar *Tuple-Key-Seq* (empty-seq))
+(deflex +Tuple-Key-Seq+ (empty-seq))
-(defvar *Tuple-Key-Lock* (make-lock "Tuple Key Lock"))
+(deflex +Tuple-Key-Lock+ (make-lock "Tuple Key Lock"))
(defun get-tuple-key (name &optional default-fn)
"Finds or creates a tuple key named `name'. If the key did not already exist,
@@ -136,23 +136,24 @@
the tuple has no explicit pair with this key; it is called with one argument,
the tuple."
(assert (or (null default-fn) (typep default-fn 'function)))
- (with-lock (*Tuple-Key-Lock*)
- (let ((key (lookup *Tuple-Key-Name-Map* name))
- (key-idx (size *Tuple-Key-Seq*)))
+ (with-lock (+Tuple-Key-Lock+)
+ (let ((key (lookup +Tuple-Key-Name-Map+ name))
+ (key-idx (size +Tuple-Key-Seq+)))
(or key
(if (<= key-idx Tuple-Key-Number-Mask)
(let ((key (make-tuple-key name default-fn key-idx)))
- (setf (lookup *Tuple-Key-Name-Map* name) key)
- (push-last *Tuple-Key-Seq* key)
+ (setf (lookup +Tuple-Key-Name-Map+ name) key)
+ (push-last +Tuple-Key-Seq+ key)
key)
(error "Tuple key space exhausted"))))))
(defmacro def-tuple-key (name &optional default-fn)
- "Defines a tuple key named `name'. If `default-fn' is supplied, it is used
-to compute a value for lookups where the tuple has no explicit pair with this
-key; it is called with one argument, the tuple."
+ "Defines a tuple key named `name' as a global lexical variable (see `deflex').
+If `default-fn' is supplied, it is used to compute a value for lookups where
+the tuple has no explicit pair with this key; it is called with one argument,
+the tuple."
(assert (symbolp name))
- `(defvar ,name (get-tuple-key ',name ,default-fn)))
+ `(deflex ,name (get-tuple-key ',name ,default-fn)))
(defun print-tuple-key (key stream level)
(declare (ignore level))
@@ -193,17 +194,17 @@
;; Serial number (used for `Reorder-Map-Map').
Serial-Number)
-(defvar Tuple-Desc-Next-Serial-Number 0)
+(deflex +Tuple-Desc-Next-Serial-Number+ 0)
-(defvar Tuple-Desc-Next-Serial-Number-Lock (make-lock))
+(deflex +Tuple-Desc-Next-Serial-Number-Lock+ (make-lock))
(defun Make-Tuple-Desc (key-set pairs)
(Make-Tuple-Desc-Internal key-set pairs (make-lock)
- (prog1 Tuple-Desc-Next-Serial-Number
- (with-lock (Tuple-Desc-Next-Serial-Number-Lock)
- (incf Tuple-Desc-Next-Serial-Number)))))
+ (prog1 +Tuple-Desc-Next-Serial-Number+
+ (with-lock (+Tuple-Desc-Next-Serial-Number-Lock+)
+ (incf +Tuple-Desc-Next-Serial-Number+)))))
-(defvar *Tuple-Descriptor-Map* (empty-map))
+(deflex +Tuple-Descriptor-Map+ (empty-map))
(defmethod compare ((x Tuple-Desc) (y Tuple-Desc))
(let ((xser (Tuple-Desc-Serial-Number x))
@@ -233,13 +234,13 @@
(defun empty-dyn-tuple ()
"Returns an empty dyn-tuple."
- (let ((desc (lookup *Tuple-Descriptor-Map* (empty-map))))
+ (let ((desc (lookup +Tuple-Descriptor-Map+ (empty-map))))
(unless desc
(setq desc (Make-Tuple-Desc (empty-set) (vector)))
- (setf (lookup *Tuple-Descriptor-Map* (empty-map)) desc))
+ (setf (lookup +Tuple-Descriptor-Map+ (empty-map)) desc))
(make-dyn-tuple desc (vector))))
-(defvar *Tuple-Random-Value* 0
+(deflex +Tuple-Random-Value+ 0
"State for an extremely fast, low-quality generator of small numbers of
pseudorandom bits. Yep, this is about as quick-and-dirty as it gets --
we just increment this value by some small prime like 5 each time. We
@@ -248,8 +249,8 @@
(declaim (inline Tuple-Random-Value))
(defun Tuple-Random-Value ()
(the fixnum
- (setf *Tuple-Random-Value*
- (logand (+ (the fixnum *Tuple-Random-Value*) 5)
+ (setf +Tuple-Random-Value+
+ (logand (+ (the fixnum +Tuple-Random-Value+) 5)
most-positive-fixnum))))
(defconstant Tuple-Reorder-Frequency 31
@@ -349,7 +350,7 @@
(let ((nks (with (Tuple-Desc-Key-Set old-desc) key))
((nd (progn
(read-memory-barrier)
- (lookup *Tuple-Descriptor-Map* nks)))))
+ (lookup +Tuple-Descriptor-Map+ nks)))))
(when nd
(setf (lookup (Tuple-Desc-Next-Desc-Map old-desc) key) nd))
(values nd nks)))))
@@ -358,7 +359,7 @@
(old-pairs (Tuple-Desc-Pairs old-desc)))
(unless new-desc
;; Lock out reorderings while we do this. One might think we also need a
- ;; lock to protect `*Tuple-Descriptor-Map*', but actually it doesn't hurt
+ ;; lock to protect `+Tuple-Descriptor-Map+', but actually it doesn't hurt
;; anything if we lose an occasional entry -- some tuples will use a
;; descriptor not in the map, but nothing goes wrong as a consequence.
(with-lock ((Tuple-Desc-Lock old-desc))
@@ -380,12 +381,12 @@
(dotimes (i (- nkeys window-size 1))
(add-pair (+ i window-size 1)
(svref old-pairs (+ i window-size)))))))))
- ;(setf (lookup *Tuple-Descriptor-Map* new-key-set) new-desc)
+ ;(setf (lookup +Tuple-Descriptor-Map+ new-key-set) new-desc)
;; Technically, we need a memory barrier to make sure the new map value
;; is fully constructed before being made available to other threads.
- (setq *Tuple-Descriptor-Map*
+ (setq +Tuple-Descriptor-Map+
(prog1
- (with *Tuple-Descriptor-Map* new-key-set new-desc)
+ (with +Tuple-Descriptor-Map+ new-key-set new-desc)
(write-memory-barrier)))
(setf (lookup (Tuple-Desc-Next-Desc-Map old-desc) key) new-desc))
(let ((reorder-map (Tuple-Get-Reorder-Map old-desc new-desc))
@@ -478,7 +479,7 @@
(declare (fixnum ,idx-var))
(let ((,pr-var (the fixnum (svref ,pairs-var ,idx-var)))
((,val-idx-var (ash ,pr-var (- Tuple-Key-Number-Size)))))
- (let ((,key-var (lookup *Tuple-Key-Seq*
+ (let ((,key-var (lookup +Tuple-Key-Seq+
(logand ,pr-var Tuple-Key-Number-Mask)))
(,value-var (svref (svref ,contents-var
(ash ,val-idx-var
Modified: trunk/Code/wb-trees.lisp
==============================================================================
--- trunk/Code/wb-trees.lisp (original)
+++ trunk/Code/wb-trees.lisp Mon Nov 3 05:08:58 2008
@@ -1610,7 +1610,8 @@
;;; Utilities used by all tree types in this file
(defun Make-WB-Tree-Iterator (tree size frame-size nodes-have-values?)
- (declare (type fixnum frame-size))
+ (declare (optimize (speed 3) (safety 0))
+ (type fixnum frame-size))
(let ((depth (the fixnum (WB-Tree-Max-Depth size nodes-have-values?)))
((stack (make-array (the fixnum (1+ (the fixnum (* frame-size depth))))))))
(setf (svref stack 0) 1)
@@ -1632,11 +1633,11 @@
(defconstant WB-Tree-Precomputed-Max-Depths 1000)
-(defvar *WB-Tree-Max-Depths-Without-Values*
+(deflex +WB-Tree-Max-Depths-Without-Values+
(gmap :vector (lambda (i) (WB-Tree-True-Max-Depth i nil))
(:index 0 WB-Tree-Precomputed-Max-Depths)))
-(defvar *WB-Tree-Max-Depths-With-Values*
+(deflex +WB-Tree-Max-Depths-With-Values+
(gmap :vector (lambda (i) (WB-Tree-True-Max-Depth i t))
(:index 0 WB-Tree-Precomputed-Max-Depths)))
@@ -1649,8 +1650,8 @@
(type fixnum size))
(if (< size WB-Tree-Precomputed-Max-Depths)
(svref (if nodes-have-values?
- *WB-Tree-Max-Depths-With-Values*
- *WB-Tree-Max-Depths-Without-Values*)
+ +WB-Tree-Max-Depths-With-Values+
+ +WB-Tree-Max-Depths-Without-Values+)
size)
(values (ceiling (* (1- (integer-length size))
;; constant:
More information about the Fset-cvs
mailing list