Permalink
Browse files

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.
  • Loading branch information...
1 parent 9f04194 commit a3f2751fbff90a4e5db758b8ed2e0ebc2479bfc3 @smithzvk committed Jun 26, 2011
Showing with 42 additions and 41 deletions.
  1. +42 −41 versioned-arrays.lisp
View
@@ -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) ))

0 comments on commit a3f2751

Please sign in to comment.