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: