Commit 51fcb181 authored by ieslick's avatar ieslick
Browse files

Additional tweaks to new gc

darcs-hash:517e2039ead50214f947da8a3780d5cc2610ae80
parent 3c7d25e9
Loading
Loading
Loading
Loading
+23 −21
Original line number Diff line number Diff line
@@ -61,7 +61,7 @@

(defmethod drop-instance ((bt btree))
  "The standard method for reclaiming storage of persistent objects"
  (ensure-transaction (:store-controller *store-controller*)
  (ensure-transaction (:store-controller (get-con bt))
    (drop-btree bt)
    (call-next-method)))

@@ -118,13 +118,6 @@ existing primary entries (may be expensive!)"))
  (ifret (get-index ibt idxname)
	 (add-index ibt :index-name idxname :key-form key-form :populate populate)))

(defmethod drop-btree ((bt indexed-btree))
  (map-indices (lambda (name index)
		 (declare (ignore index))
		 (remove-index bt name))
	       bt)
  (call-next-method))

;;
;; Secondary Indices
;;
@@ -140,11 +133,6 @@ existing primary entries (may be expensive!)"))
  (:metaclass persistent-metaclass)
  (:documentation "Secondary index to an indexed-btree."))

(defmethod drop-btree ((index btree-index))
  "Btree indices don't need to have values removed,
   this happens on the primary when remove-kv is called"
  nil)

(define-condition invalid-keyform (error)
  ((key-form :reader key-form-of :initarg :key-form))
  (:report (lambda (c s)
@@ -427,14 +415,6 @@ not), evaluates the forms, then closes the cursor."
	  (progn ,@body)
       (cursor-close ,var))))

(defmethod drop-btree ((bt btree))
  (ensure-transaction (:store-controller *store-controller*)
    (with-btree-cursor (cur bt)
      (loop for (exists? key) = (multiple-value-list (cursor-first cur))
	 then (multiple-value-list (cursor-next cur))
	 while exists?
	 do (remove-kv key bt)))))

(defmethod remove-kv-pair (key value (dbt dup-btree))
  "Too bad there isn't a direct way to do this, but with
   ordered duplicates this should be reasonably efficient"
@@ -447,6 +427,27 @@ not), evaluates the forms, then closes the cursor."
  	  (when exists? 
	    (cursor-delete cur)))))))

(defmethod drop-btree ((bt btree))
  (ensure-transaction (:store-controller (get-con bt))
    (with-btree-cursor (cur bt)
      (loop for (exists? key) = (multiple-value-list (cursor-first cur))
	 then (multiple-value-list (cursor-next cur))
	 while exists?
	 do (remove-kv key bt)))))

(defmethod drop-btree ((bt indexed-btree))
  (with-transaction (:store-controller (get-con bt))
    (map-indices (lambda (name index)
		   (declare (ignore index))
		   (remove-index bt name))
		 bt)
    (call-next-method)))

(defmethod drop-btree ((index btree-index))
  "Btree indices don't need to have values removed,
   this happens on the primary when remove-kv is called"
  nil)

;; =======================================
;;   Generic Mapping Functions
;; =======================================
@@ -700,6 +701,7 @@ not), evaluates the forms, then closes the cursor."
(defmethod map-index (fn (index btree-index) &rest args
		      &key start end (value nil value-set-p) from-end collect 
		      &allow-other-keys)
  (declare (ignore args))
  (validate-map-call start end)
  (cond (value-set-p (map-index-values fn index value collect))
	(from-end (map-index-from-end fn index start end collect))
+31 −31
Original line number Diff line number Diff line
@@ -55,23 +55,15 @@
    (setf *mark-table* (make-btree sc))
    (setf *max-oid* (oid *mark-table*))

    ;; Clean up stale memory references
    #+sbcl (sb-ext:gc :full t)
    #-sbcl (cl-user::gc))

    ;; Core of GC
    (mark-all sc)
    (sweep-all sc test)
    (sweep-all-classes sc test)

    ;; Drop mark table rather than reset?
    (unless test 
      (drop-instance *mark-table*)
      (setf *mark-table* nil))
      (setf *mark-table* nil))))

    ;; Final GC to clean up stale mem refs to collections
    ;; were reclaimed
    #+sbcl (sb-ext:gc)
    #-sbcl (cl-user::gc))

;; MARK

@@ -89,17 +81,23 @@

;; SWEEP

(defun sweep-all (sc &optional test (chunk-size 100))
  (declare (ignore chunk-size))
(defun sweep-all-classes (sc &optional test (step 5))
  "For each unindexed class, sweep all instances that
   are not on the mark list.  One txn per class for now"
  (dolist (class (unindexed-classes sc))
    (let ((cid (class-schema-id sc class)))
      (map-index (lambda (k v pk)
		   (declare (ignore k v))
		   (if test 
		       (sweep-debug sc pk)
		       (sweep-instance sc pk)))
		 (controller-instance-class-index sc)
		 :value cid))))
      (sweep-class sc cid step test))))

(defun sweep-class (sc cid step &optional test)
  "Sweep over the class and reclaim instances"
  (declare (ignore step))
  (map-index (lambda (k v pk)
	       (declare (ignore k v))
	       (if test 
		   (sweep-debug sc pk)
		   (sweep-instance sc pk)))
	     (controller-instance-class-index sc)
	     :value cid))

(defun sweep-instance (sc oid)
  (unless (get-value oid *mark-table*)
@@ -144,7 +142,7 @@
	       (walk-heap v))
	     obj))

(defmethod walk-btree ((obj indexed-btree))
(defmethod walk-heap ((obj indexed-btree))
  "Key values of indices can be persistent objects"
  (map-indices (lambda (name index)
		 (declare (ignore name))
@@ -222,22 +220,24 @@
     collect (find-class (default-class-id-type i sc))))


;; Garbage collection thread
;;
;; Pre-packaged garbage collection thread
;;

(defvar gc-step-size 100
  "Number of OIDs to mark per invocation")
;; (defvar gc-step-size 100
;;   "Number of OIDs to mark per invocation")

(defvar gc-step-interval 500
  "Number of ms to wait between chunk executions")
;; (defvar gc-step-interval 500
;;   "Number of ms to wait between chunk executions")

(defvar gc-oid-interval 1000
  "Number of OIDs to allocate ")
;; (defvar gc-oid-interval 1000
;;   "Number of OIDs to allocate ")

(defvar gc-pass-check-interval 10000
  "Number of ms to wait between checking for a new pass")
;; (defvar gc-pass-check-interval 10000
;;   "Number of ms to wait between checking for a new pass")

(defvar gc-drop-undefined-classes nil
  "Drop all instances of classes that do not exist in the image")
;; (defvar gc-drop-undefined-classes nil
;;   "Drop all instances of classes that do not exist in the image")

;;(defun gc-loop ()
;;  (loop
+2 −2
Original line number Diff line number Diff line
@@ -74,10 +74,10 @@

(defmethod class-indexing-enabled-p ((class persistent-metaclass))
  (and (not (subtypep (class-name class) 'persistent-collection))
       (%class-indexing class) t))
       (%class-indexing class)))

(defun migrate-class-index-p (class)
  (%class-indexing class) t)
  (%class-indexing class))

;;
;; Top level defclass form - hide metaclass option