Cleaned up the implementation a bit. Removed recursive locking (even …

…though it was a pain) as CMUCL cannot do it. It now works in everything but ABCL.
smithzvk · Jun 26, 2011 · a3f2751 · a3f2751
1 parent 9f04194
commit a3f2751
Showing 1 changed file with 42 additions and 41 deletions.
diff --git a/versioned-arrays.lisp b/versioned-arrays.lisp
@@ -23,7 +23,7 @@
   (when (or adjustable fill-pointer displaced-to displaced-index-offset)
     (error "The capabilities: adjustable, fill-pointer, displaced-to, displaced-index-offset are not implemented yet") )
   (%make-versioned-array :car (apply #'make-array dimensions args)
-                         :lock (bt:make-recursive-lock) ))
+                         :lock (bt:make-lock) ))
 
 ;; Basically this works like this.  A versioned array is a list whose last
 ;; element is an array.  When you access a value from the array, the array moves
@@ -32,56 +32,57 @@
 ;; delta at the same time.
 
 (defun varef (v-arr &rest idx)
-  (bt:with-recursive-lock-held ((versioned-array-lock v-arr))
-    (multiple-value-bind (array changes) (get-array v-arr)
-      (invert-changes (versioned-array-cdr v-arr) changes v-arr)
-      (setf (versioned-array-car v-arr) array
-            (versioned-array-cdr v-arr) nil )
-      (apply #'aref (versioned-array-car v-arr) idx) )))
+  (bt:with-lock-held ((versioned-array-lock v-arr))
+    (raise-array! v-arr)
+    (apply #'aref (versioned-array-car v-arr) idx) ))
 
-(defun get-array (v-arr)
-  (if (arrayp (versioned-array-car v-arr))
-      (values (versioned-array-car v-arr) nil)
-      (multiple-value-bind (array changes)
-          (get-array (versioned-array-cdr v-arr))
-        (destructuring-bind (new-val &rest idx) (versioned-array-car v-arr)
-          (let ((old-val (apply #'aref array idx)))
-            (setf (apply #'aref array idx) new-val)
-            (values array
-                    (cons (cons old-val idx) changes) ))))))
-
-(defun invert-changes (old-v-arr changes last)
-  (cond ((null changes) nil)
-        (t (setf (versioned-array-cdr old-v-arr) last
-                 (versioned-array-car old-v-arr) (car changes) )
-         (invert-changes (versioned-array-cdr old-v-arr)
-                         (cdr changes) old-v-arr ))))
+(defun raise-array! (v-arr)
+  "Bubble array to beginning of list, along the way back, reverse the list.
+This assumes that locks are already held."
+  (if (not (versioned-array-cdr v-arr))
+      nil
+      (progn
+        (raise-array! (versioned-array-cdr v-arr))
+        (destructuring-bind (new-val &rest idx)
+            (versioned-array-car v-arr)
+          ;; Move the array
+          (setf (versioned-array-car v-arr)
+                (versioned-array-car (versioned-array-cdr v-arr)) )
+          ;; Invert delta
+          (setf (versioned-array-car (versioned-array-cdr v-arr))
+                (cons (apply #'aref (versioned-array-car v-arr) idx) idx) )
+          ;; Mutate array
+          (setf (apply #'aref (versioned-array-car v-arr) idx)
+                new-val )
+          ;; Reverse the list
+          (setf (versioned-array-cdr (versioned-array-cdr v-arr))
+                v-arr )
+          ;; Terminate the list
+          (setf (versioned-array-cdr v-arr) nil) ))))
 
 (define-modf-function varef 1 (new-val v-arr &rest idx)
-  (bt:with-recursive-lock-held ((versioned-array-lock v-arr))
-    (let ((old-value
-           ;; This moves the array to our version
-           (apply #'varef v-arr idx) ))
-      (let ((arr (versioned-array-car v-arr)))
-        (setf (apply #'aref arr idx) new-val)
-        (setf (versioned-array-cdr v-arr) (%make-versioned-array
-                                           :car arr
-                                           :lock (versioned-array-lock v-arr) )
-              (versioned-array-car v-arr) (cons old-value idx) ))))
-  (versioned-array-cdr v-arr) )
+  (bt:with-lock-held ((versioned-array-lock v-arr))
+    (raise-array! v-arr)
+    (let* ((arr (versioned-array-car v-arr))
+           (old-value (apply #'aref arr idx)) )
+      (setf (apply #'aref arr idx) new-val)
+      (setf (versioned-array-cdr v-arr) (%make-versioned-array
+                                         :car arr
+                                         :lock (versioned-array-lock v-arr) )
+            (versioned-array-car v-arr) (cons old-value idx) ))
+    (versioned-array-cdr v-arr) ))
 
 ;; Some niceties...
 
 (defun va-dimensions (v-arr)
-  (bt:with-recursive-lock-held ((versioned-array-lock v-arr))
-    (if (arrayp (versioned-array-car v-arr))
-        (array-dimensions (versioned-array-car v-arr))
-        (va-dimensions (versioned-array-cdr v-arr)) )))
+  (bt:with-lock-held ((versioned-array-lock v-arr))
+    (raise-array! v-arr)
+    (array-dimensions (versioned-array-car v-arr)) ))
 
 (defun va-dimension (v-arr n)
   (nth n (va-dimensions v-arr)) )
 
 (defmethod print-object ((obj versioned-array) str)
-  (bt:with-recursive-lock-held ((versioned-array-lock obj))
-    (varef obj 0 0)
+  (bt:with-lock-held ((versioned-array-lock obj))
+    (raise-array! obj)
     (print (versioned-array-car obj) str) ))