[movitz-cvs] CVS update: movitz/losp/los0-gc.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Wed Mar 9 07:31:29 UTC 2005
Update of /project/movitz/cvsroot/movitz/losp
In directory common-lisp.net:/tmp/cvs-serv8511
Modified Files:
los0-gc.lisp
Log Message:
Includes testing of code-vector migration.
Date: Wed Mar 9 08:31:28 2005
Author: ffjeld
Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.48 movitz/losp/los0-gc.lisp:1.49
--- movitz/losp/los0-gc.lisp:1.48 Thu Jan 27 08:48:53 2005
+++ movitz/losp/los0-gc.lisp Wed Mar 9 08:31:28 2005
@@ -10,7 +10,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef at acm.org>
;;;; Created at: Sat Feb 21 17:48:32 2004
;;;;
-;;;; $Id: los0-gc.lisp,v 1.48 2005/01/27 07:48:53 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.49 2005/03/09 07:31:28 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -335,9 +335,19 @@
(defparameter *x* #4000(nil)) ; Have this in static space.
(defparameter *xx* #4000(nil)) ; Have this in static space.
+(defparameter *code-vector-foo* 0)
+(defvar *old-code-vectors* #250())
+(defvar *new-code-vectors* #250())
+
+(defun debug (location x)
+ (setf (dummy x)
+ (let ((new (shallow-copy x)))
+ (warn "[~S] Migrating code-vector ~Z => ~Z." location x new)
+ new)))
(defun stop-and-copy (&optional evacuator)
(setf (fill-pointer *x*) 0)
+ (setf (fill-pointer *old-code-vectors*) 0)
(multiple-value-bind (newspace oldspace)
(without-interrupts
(let* ((space0 (%run-time-context-slot 'nursery-space))
@@ -349,14 +359,37 @@
(setf (%run-time-context-slot 'nursery-space) space1)
(values space1 space0)))
;; Evacuate-oldspace is to be mapped over every potential pointer.
- (let ((evacuator
+ (let ((*code-vector-foo* (incf *code-vector-foo* 2))
+ (evacuator
(or evacuator
(lambda (x location)
"If x is in oldspace, migrate it to newspace."
- (declare (ignore location))
+ ;; (declare (ignore location))
(cond
((null x)
nil)
+ ((object-in-space-p newspace x)
+ x)
+ ((and (typep x 'code-vector)
+ (not (object-in-space-p oldspace x))
+ (not (object-in-space-p newspace x))
+ (= (ldb (byte 12 0) (object-location x))
+ (ldb (byte 12 0) *code-vector-foo*))
+ (not (eq x (funobj-code-vector #'stop-and-copy)))
+ (not (eq x (symbol-value 'muerte::default-interrupt-trampoline)))
+;;; (not (eq x (symbol-value 'muerte::ret-trampoline)))
+ (not (muerte::scavenge-find-pf (lambda (x y) x) (object-location x))))
+ (let ((p (position (object-location x) *old-code-vectors*)))
+ (if p
+ (aref *new-code-vectors* p)
+ (setf (aref *new-code-vectors*
+ (vector-push (object-location x) *old-code-vectors*))
+ (let ((new (shallow-copy x)))
+ (warn "[~S] Migrating ~@[~S ~]~Z => ~Z."
+ location
+ (muerte::locate-function (object-location x))
+ x new)
+ new)))))
((not (object-in-space-p oldspace x))
x)
(t (or (and (eq (object-tag x)
@@ -375,47 +408,57 @@
(setf (memref (object-location x) 0) forward-x)
forward-x))))))))
;; Scavenge roots
- (dolist (range muerte::%memory-map-roots%)
- (map-header-vals evacuator (car range) (cdr range)))
- (map-stack-vector evacuator nil (current-stack-frame))
+ (with-simple-restart (nil "Scanning stack.")
+ (map-stack-vector evacuator nil (current-stack-frame)))
+ (with-simple-restart (nil "Scanning heap.")
+ (dolist (range muerte::%memory-map-roots%)
+ (map-header-vals evacuator (car range) (cdr range))))
;; Scan newspace, Cheney style.
- (loop with newspace-location = (+ 2 (object-location newspace))
- with scan-pointer = 2
- as fresh-pointer = (space-fresh-pointer newspace)
- while (< scan-pointer fresh-pointer)
- do (map-header-vals evacuator
- (+ newspace-location scan-pointer)
- (+ newspace-location (space-fresh-pointer newspace)))
- (setf scan-pointer fresh-pointer))
-
+ (with-simple-restart (nil "Cheney-scanning newspace.")
+ (loop with newspace-location = (+ 2 (object-location newspace))
+ with scan-pointer = 2
+ as fresh-pointer = (space-fresh-pointer newspace)
+ while (< scan-pointer fresh-pointer)
+ do (map-header-vals evacuator
+ (+ newspace-location scan-pointer)
+ (+ newspace-location (space-fresh-pointer newspace)))
+ (setf scan-pointer fresh-pointer)))
;; Consistency check..
+ (map-stack-vector (lambda (x foo)
+ (declare (ignore foo))
+ x)
+ nil
+ (current-stack-frame))
(when *gc-consitency-check*
- (without-interrupts
- (let ((a *x*))
- ;; First, restore the state of old-space
- (do ((i 0 (+ i 3)))
- ((>= i (length a)))
- (let ((old (%lispval-object (aref a i)))
- (old-class (aref a (+ i 1))))
- (setf (memref (object-location old) 0 :type :unsigned-byte32) old-class)))
- ;; Then, check that each migrated object is equalp to its new self.
- (do ((i 0 (+ i 3)))
- ((>= i (length a)))
- (let ((old (%lispval-object (aref a i)))
- (new (%lispval-object (aref a (+ i 2)))))
- (unless (and (object-in-space-p newspace new)
- (object-in-space-p oldspace old)
- (objects-equalp old new))
- (let ((*old* old)
- (*new* new)
- (*old-class* (aref a (+ i 1))))
- (declare (special *old* *new* *old-class*))
- (with-simple-restart (continue "Ignore failed GC consistency check.")
+ (with-simple-restart (continue "Ignore failed GC consistency check.")
+ (without-interrupts
+ (let ((a *x*))
+ ;; First, restore the state of old-space
+ (do ((end (- (length a) 2))
+ (i 0 (+ i 3)))
+ ((>= i end))
+ (let ((old (%lispval-object (aref a i)))
+ (old-class (aref a (+ i 1))))
+ (setf (memref (object-location old) 0 :type :unsigned-byte32) old-class)))
+ ;; Then, check that each migrated object is equalp to its new self.
+ (do ((i 0 (+ i 3)))
+ ((>= i (length a)))
+ (let ((old (%lispval-object (aref a i)))
+ (new (%lispval-object (aref a (+ i 2)))))
+ (unless (and (object-in-space-p newspace new)
+ (not (object-in-space-p newspace old))
+ (objects-equalp old new))
+ (let ((*evacuator* evacuator)
+ (*old* old)
+ (*new* new)
+ (*old-class* (aref a (+ i 1))))
+ (declare (special *old* *new* *old-class* *evacuator*))
(error "GC consistency check failed:
old object: ~Z: ~S
new object: ~Z: ~S
+equalp: ~S
oldspace: ~Z, newspace: ~Z, i: ~D"
- old old new new oldspace newspace i))))))
+ old old new new (objects-equalp old new) oldspace newspace i))))))
(map-header-vals (lambda (x y)
(declare (ignore y))
(when (location-in-object-p (space-other (%run-time-context-slot 'nursery-space))
@@ -442,6 +485,10 @@
(location-in-object-p oldspace (object-location o)))
(break "Seeing old (unmapped) object ~Z in stack at ~S."
o (+ (object-location stack) i 2))))))))
+ (loop for o across *old-code-vectors*
+ for n across *new-code-vectors*
+ do (setf (memref o 0) (memref n -6))
+ (fill (muerte::%location-object o 6) #xcc))
;; GC completed, oldspace is evacuated.
(unless *gc-quiet*
(let ((old-size (truncate (- (space-fresh-pointer oldspace) 2) 2))
@@ -454,9 +501,37 @@
(fill oldspace #x13 :start 2)
;; (setf *gc-stack2* *gc-stack*)
(setf *gc-stack* (muerte::copy-current-control-stack))
- (setf (fill-pointer *xx*) (fill-pointer *x*))
- (replace *xx* *x*)))
+ #+ignore (setf (fill-pointer *xx*) (fill-pointer *x*))
+ #+ignore (replace *xx* *x*)))
(values))
+
+(defun simple-stop-and-copy (newspace oldspace)
+ (flet ((evacuator (x)
+ "If x is in oldspace, migrate it to newspace."
+ (if (not (object-in-space-p oldspace x))
+ x
+ (or (and (eq (object-tag x)
+ (memref (object-location x) 0 :type :tag))
+ (let ((forwarded-x (memref (object-location x) 0)))
+ (and (object-in-space-p newspace forwarded-x)
+ forwarded-x)))
+ (setf (memref (object-location x) 0)
+ (shallow-copy x))))))
+ ;; Scavenge roots
+ (map-stack-vector #'evacuator nil (current-stack-frame))
+ (dolist (range muerte::%memory-map-roots%)
+ (map-header-vals #'evacuator (car range) (cdr range)))
+ ;; Scan newspace, Cheney style.
+ (loop with newspace-location = (+ 2 (object-location newspace))
+ with scan-pointer = 2
+ as fresh-pointer = (space-fresh-pointer newspace)
+ while (< scan-pointer fresh-pointer)
+ do (map-header-vals #'evacuator
+ (+ newspace-location scan-pointer)
+ (+ newspace-location (space-fresh-pointer newspace)))
+ (setf scan-pointer fresh-pointer))
+ (initialize-space oldspace)
+ (values)))
(defun find-object-by-location (location &key (continuep t) (breakp nil))
More information about the Movitz-cvs
mailing list