[movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Fri Nov 26 14:59:38 UTC 2004
Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory common-lisp.net:/tmp/cvs-serv21019
Modified Files:
scavenge.lisp
Log Message:
Renamed the scavenging operators to map-header-vals and
map-stack-vector. Added map-lisp-vals.
Date: Fri Nov 26 15:59:36 2004
Author: ffjeld
Index: movitz/losp/muerte/scavenge.lisp
diff -u movitz/losp/muerte/scavenge.lisp:1.35 movitz/losp/muerte/scavenge.lisp:1.36
--- movitz/losp/muerte/scavenge.lisp:1.35 Tue Nov 23 17:09:17 2004
+++ movitz/losp/muerte/scavenge.lisp Fri Nov 26 15:59:31 2004
@@ -10,7 +10,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef at acm.org>
;;;; Created at: Mon Mar 29 14:54:08 2004
;;;;
-;;;; $Id: scavenge.lisp,v 1.35 2004/11/23 16:09:17 ffjeld Exp $
+;;;; $Id: scavenge.lisp,v 1.36 2004/11/26 14:59:31 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -29,9 +29,18 @@
(defvar *scan*) ; debugging
(defvar *scan-last*) ; debugging
-(defvar *map-heap-words-verbose* nil)
+(defvar *map-header-vals-verbose* nil)
-(defun map-heap-words (function start-location end-location)
+(defun map-lisp-vals (function start-location end-location)
+ (with-funcallable (do-map function)
+ (loop for location from start-location below end-location
+ as object = (memref location 0)
+ do (when (typep object 'pointer)
+ (let ((new-object (do-map object)))
+ (unless (eq object new-object)
+ (setf (memref location 0) new-object)))))))
+
+(defun map-header-vals (function start-location end-location)
"Map function over each potential pointer word between
start-location and end-location."
(macrolet ((scavenge-typep (x primary)
@@ -42,12 +51,12 @@
(byte 8 8)
(movitz:tag primary))))
`(= ,code ,x))))
- (do ((verbose *map-heap-words-verbose*)
+ (do ((verbose *map-header-vals-verbose*)
(*scan-last* nil) ; Last scanned object, for debugging.
(scan start-location (1+ scan)))
((>= scan end-location))
- (with-simple-restart (continue-map-heap-words
- "Continue map-heap-words at location ~S." (1+ scan))
+ (with-simple-restart (continue-map-header-vals
+ "Continue map-header-vals at location ~S." (1+ scan))
(let ((x (memref scan 0 :type :unsigned-byte16))
(x2 (memref scan 1 :type :unsigned-byte16)))
(when verbose
@@ -85,7 +94,7 @@
(code-vector (funobj-code-vector funobj))
(num-jumpers (funobj-num-jumpers funobj)))
(check-type code-vector code-vector)
- (map-heap-words function (+ scan 5) (+ scan 7)) ; scan funobj's lambda-list and name
+ (map-header-vals function (+ scan 5) (+ scan 7)) ; scan funobj's lambda-list and name
(let ((new-code-vector (funcall function code-vector scan)))
(check-type new-code-vector code-vector)
(unless (eq code-vector new-code-vector)
@@ -148,142 +157,143 @@
(setf (memref scan 0) new)))))))))
(values))
-(defun map-stack-words (function stack start-frame)
+(defun map-stack-vector (function stack start-frame &optional (map-region #'map-header-vals))
"Map function over the potential pointer words of a stack, starting
at the start-stack-frame location."
- (loop with next-frame with next-nether-frame
- for nether-frame = start-frame then (or next-nether-frame frame)
- and frame = (stack-frame-uplink stack start-frame) then (or next-frame
- (stack-frame-uplink stack frame))
- while (plusp frame)
- do (setf next-frame nil next-nether-frame nil)
- do (flet ((scavenge-funobj-code-vector (funobj)
- "Funobj 0 is assumed to be the DIT code-vector."
- (if (eq 0 funobj)
- (symbol-value 'default-interrupt-trampoline)
- (funobj-code-vector funobj))))
- (let ((funobj (funcall function (stack-frame-funobj stack frame) frame)))
- ;; If nether-frame is a DIT-frame, there are 4 more words to be skipped.
- (when (eq 0 (stack-frame-ref stack nether-frame -1))
- (incf nether-frame 4))
- (typecase funobj
- ((or function null)
- (assert (= 0 (funobj-frame-num-unboxed funobj)))
- (map-heap-words function (+ nether-frame 2) frame))
- ((eql 0) ; A dit interrupt-frame?
- (let* ((dit-frame frame)
- (casf-frame (dit-frame-casf stack dit-frame)))
- ;; 1. Scavenge the dit-frame
- (cond
- ((let ((atomically (dit-frame-ref stack dit-frame :atomically-continuation
- :unsigned-byte32)))
- (and (not (= 0 atomically))
- (= 0 (ldb (byte 2 0) atomically))))
- ;; Interrupt occurred inside an (non-pf) atomically, so none of the
- ;; registers are active.
- (map-heap-words function (+ nether-frame 2)
- (+ dit-frame 1 (dit-frame-index :tail-marker))))
- ((logbitp 10 (dit-frame-ref stack dit-frame :eflags :unsigned-byte32))
- ;; DF flag was 1, so EAX and EDX are not GC roots.
- #+ignore (warn "Interrupt in uncommon mode at ~S"
- (dit-frame-ref stack dit-frame :eip :unsigned-byte32))
- (map-heap-words function ; Assume nothing in the dit-frame above the location ..
- (+ nether-frame 2) ; ..of EDX holds pointers.
- (+ dit-frame (dit-frame-index :edx))))
- (t #+ignore (warn "Interrupt in COMMON mode!")
- (map-heap-words function ; Assume nothing in the dit-frame above the location ..
- (+ nether-frame 2) ; ..of ECX holds pointers.
- (+ dit-frame (dit-frame-index :ecx)))))
- ;; 2. Pop to (dit-)frame's CASF
- (setf nether-frame dit-frame
- frame (dit-frame-casf stack frame))
- (let ((casf-funobj (funcall function (stack-frame-funobj stack frame) frame))
- (interrupted-ebp (dit-frame-ref stack dit-frame :ebp))
- (interrupted-esp (dit-frame-esp stack dit-frame)))
+ (with-funcallable (map-region)
+ (loop with next-frame with next-nether-frame
+ for nether-frame = start-frame then (or next-nether-frame frame)
+ and frame = (stack-frame-uplink stack start-frame) then (or next-frame
+ (stack-frame-uplink stack frame))
+ while (plusp frame)
+ do (setf next-frame nil next-nether-frame nil)
+ do (flet ((scavenge-funobj-code-vector (funobj)
+ "Funobj 0 is assumed to be the DIT code-vector."
+ (if (eq 0 funobj)
+ (symbol-value 'default-interrupt-trampoline)
+ (funobj-code-vector funobj))))
+ (let ((funobj (funcall function (stack-frame-funobj stack frame) frame)))
+ ;; If nether-frame is a DIT-frame, there are 4 more words to be skipped.
+ (when (eq 0 (stack-frame-ref stack nether-frame -1))
+ (incf nether-frame 4))
+ (typecase funobj
+ ((or function null)
+ (assert (= 0 (funobj-frame-num-unboxed funobj)))
+ (map-region function (+ nether-frame 2) frame))
+ ((eql 0) ; A dit interrupt-frame?
+ (let* ((dit-frame frame)
+ (casf-frame (dit-frame-casf stack dit-frame)))
+ ;; 1. Scavenge the dit-frame
(cond
- #+ignore
- ((eq nil casf-funobj)
- (warn "Scanning interrupt in PF: ~S"
- (dit-frame-ref stack dit-frame :eip :unsigned-byte32)))
- ((or (eq 0 casf-funobj)
- (typep casf-funobj 'function))
- (let ((casf-code-vector (scavenge-funobj-code-vector casf-funobj)))
- ;; 3. Scavenge the interrupted frame, according to one of i. ii. or iii.
- (cond
- ((< interrupted-ebp interrupted-esp)
+ ((let ((atomically (dit-frame-ref stack dit-frame :atomically-continuation
+ :unsigned-byte32)))
+ (and (not (= 0 atomically))
+ (= 0 (ldb (byte 2 0) atomically))))
+ ;; Interrupt occurred inside an (non-pf) atomically, so none of the
+ ;; registers are active.
+ (map-region function (+ nether-frame 2)
+ (+ dit-frame 1 (dit-frame-index :tail-marker))))
+ ((logbitp 10 (dit-frame-ref stack dit-frame :eflags :unsigned-byte32))
+ ;; DF flag was 1, so EAX and EDX are not GC roots.
+ #+ignore (warn "Interrupt in uncommon mode at ~S"
+ (dit-frame-ref stack dit-frame :eip :unsigned-byte32))
+ (map-region function ; Assume nothing in the dit-frame above the location ..
+ (+ nether-frame 2) ; ..of EDX holds pointers.
+ (+ dit-frame (dit-frame-index :edx))))
+ (t #+ignore (warn "Interrupt in COMMON mode!")
+ (map-region function ; Assume nothing in the dit-frame above the location ..
+ (+ nether-frame 2) ; ..of ECX holds pointers.
+ (+ dit-frame (dit-frame-index :ecx)))))
+ ;; 2. Pop to (dit-)frame's CASF
+ (setf nether-frame dit-frame
+ frame (dit-frame-casf stack frame))
+ (let ((casf-funobj (funcall function (stack-frame-funobj stack frame) frame))
+ (interrupted-ebp (dit-frame-ref stack dit-frame :ebp))
+ (interrupted-esp (dit-frame-esp stack dit-frame)))
+ (cond
+ #+ignore
+ ((eq nil casf-funobj)
+ (warn "Scanning interrupt in PF: ~S"
+ (dit-frame-ref stack dit-frame :eip :unsigned-byte32)))
+ ((or (eq 0 casf-funobj)
+ (typep casf-funobj 'function))
+ (let ((casf-code-vector (scavenge-funobj-code-vector casf-funobj)))
+ ;; 3. Scavenge the interrupted frame, according to one of i. ii. or iii.
(cond
+ ((< interrupted-ebp interrupted-esp)
+ (cond
+ ((location-in-object-p casf-code-vector
+ (dit-frame-ref stack dit-frame :eip :location))
+ (warn "DIT at throw situation, in target EIP=~S"
+ (dit-frame-ref stack dit-frame :eip :unsigned-byte32))
+ (map-region function interrupted-esp frame))
+ ((location-in-object-p (scavenge-funobj-code-vector (dit-frame-ref stack
+ dit-frame
+ :scratch1))
+ (dit-frame-ref stack dit-frame :eip :location))
+ (warn "DIT at throw situation, in thrower EIP=~S"
+ (dit-frame-ref stack dit-frame :eip :unsigned-byte32))
+ (map-region function interrupted-esp frame))
+ (t (error "DIT with EBP<ESP, EBP=~S, ESP=~S"
+ interrupted-ebp
+ interrupted-esp))))
((location-in-object-p casf-code-vector
(dit-frame-ref stack dit-frame :eip :location))
- (warn "DIT at throw situation, in target EIP=~S"
- (dit-frame-ref stack dit-frame :eip :unsigned-byte32))
- (map-heap-words function interrupted-esp frame))
- ((location-in-object-p (scavenge-funobj-code-vector (dit-frame-ref stack
- dit-frame
- :scratch1))
- (dit-frame-ref stack dit-frame :eip :location))
- (warn "DIT at throw situation, in thrower EIP=~S"
- (dit-frame-ref stack dit-frame :eip :unsigned-byte32))
- (map-heap-words function interrupted-esp frame))
- (t (error "DIT with EBP<ESP, EBP=~S, ESP=~S"
- interrupted-ebp
- interrupted-esp))))
- ((location-in-object-p casf-code-vector
- (dit-frame-ref stack dit-frame :eip :location))
- (cond
- ((let ((x0-tag (ldb (byte 3 0)
- (memref interrupted-esp 0 :type :unsigned-byte8))))
- (and (member x0-tag '(1 5 6 7))
- (location-in-object-p casf-code-vector
- (memref interrupted-esp 0 :type :location))))
- ;; When code-vector migration is implemented...
- (warn "Scanning at ~S X0 call ~S in ~S."
- (dit-frame-ref stack dit-frame :eip :unsigned-byte32)
- (memref interrupted-esp 0 :type :unsigned-byte32)
- (funobj-name casf-funobj))
- #+ignore (map-heap-words function (+ interrupted-esp 1) frame)
- (when (eq 0 (stack-frame-ref stack frame -1))
- (break "X1 call in DIT-frame."))
- (setf next-frame frame
- next-nether-frame (+ interrupted-esp 1 -2)))
- ((let ((x1-tag (ldb (byte 3 0)
- (memref interrupted-esp 4 :type :unsigned-byte8))))
- (and (member x1-tag '(1 5 6 7))
- (location-in-object-p casf-code-vector
- (memref interrupted-esp 4 :type :location))))
- ;; When code-vector migration is implemented...
- (warn "Scanning at ~S X1 call ~S in ~S."
- (dit-frame-ref stack dit-frame :eip :unsigned-byte32)
- (memref interrupted-esp 4 :type :unsigned-byte32)
- (funobj-name casf-funobj))
- (when (eq 0 (stack-frame-ref stack frame -1))
- (break "X1 call in DIT-frame."))
- #+ignore (map-heap-words function (+ interrupted-esp 2) frame)
+ (cond
+ ((let ((x0-tag (ldb (byte 3 0)
+ (memref interrupted-esp 0 :type :unsigned-byte8))))
+ (and (member x0-tag '(1 5 6 7))
+ (location-in-object-p casf-code-vector
+ (memref interrupted-esp 0 :type :location))))
+ ;; When code-vector migration is implemented...
+ (warn "Scanning at ~S X0 call ~S in ~S."
+ (dit-frame-ref stack dit-frame :eip :unsigned-byte32)
+ (memref interrupted-esp 0 :type :unsigned-byte32)
+ (funobj-name casf-funobj))
+ (map-region function (+ interrupted-esp 1) frame)
+ (when (eq 0 (stack-frame-ref stack frame -1))
+ (break "X1 call in DIT-frame."))
+ (setf next-frame frame
+ next-nether-frame (+ interrupted-esp 1 -2)))
+ ((let ((x1-tag (ldb (byte 3 0)
+ (memref interrupted-esp 4 :type :unsigned-byte8))))
+ (and (member x1-tag '(1 5 6 7))
+ (location-in-object-p casf-code-vector
+ (memref interrupted-esp 4 :type :location))))
+ ;; When code-vector migration is implemented...
+ (warn "Scanning at ~S X1 call ~S in ~S."
+ (dit-frame-ref stack dit-frame :eip :unsigned-byte32)
+ (memref interrupted-esp 4 :type :unsigned-byte32)
+ (funobj-name casf-funobj))
+ (when (eq 0 (stack-frame-ref stack frame -1))
+ (break "X1 call in DIT-frame."))
+ (map-region function (+ interrupted-esp 2) frame)
+ (setf next-frame frame
+ next-nether-frame (+ interrupted-esp 2 -2)))
+ (t ;; Situation i. Nothing special on stack, scavenge frame normally.
+ ;; (map-region function interrupted-esp frame)
+ (setf next-frame frame
+ next-nether-frame (- interrupted-esp 2))
+ )))
+ ((eq casf-frame (memref interrupted-esp 0 :type :location))
+ ;; Situation ii. esp(0)=CASF, esp(1)=code-vector
+ (assert (location-in-object-p casf-code-vector
+ (memref interrupted-esp 4 :type :location))
+
+ () "Stack discipline situation ii. invariant broken. CASF=#x~X, ESP=~S, EBP=~S"
+ casf-frame interrupted-esp interrupted-ebp)
+ (map-region function (+ interrupted-esp 2) frame)
(setf next-frame frame
next-nether-frame (+ interrupted-esp 2 -2)))
- (t ;; Situation i. Nothing special on stack, scavenge frame normally.
- ;; (map-heap-words function interrupted-esp frame)
+ (t ;; Situation iii. esp(0)=code-vector.
+ (assert (location-in-object-p casf-code-vector
+ (memref interrupted-esp 0 :type :location))
+ () "Stack discipline situation iii. invariant broken. CASF=#x~X"
+ casf-frame)
+ (map-region function (+ interrupted-esp 1) frame)
(setf next-frame frame
- next-nether-frame (- interrupted-esp 2))
- )))
- ((eq casf-frame (memref interrupted-esp 0 :type :location))
- ;; Situation ii. esp(0)=CASF, esp(1)=code-vector
- (assert (location-in-object-p casf-code-vector
- (memref interrupted-esp 4 :type :location))
-
- () "Stack discipline situation ii. invariant broken. CASF=#x~X, ESP=~S, EBP=~S"
- casf-frame interrupted-esp interrupted-ebp)
- #+ignore (map-heap-words function (+ interrupted-esp 2) frame)
- (setf next-frame frame
- next-nether-frame (+ interrupted-esp 2 -2)))
- (t ;; Situation iii. esp(0)=code-vector.
- (assert (location-in-object-p casf-code-vector
- (memref interrupted-esp 0 :type :location))
- () "Stack discipline situation iii. invariant broken. CASF=#x~X"
- casf-frame)
- #+ignore (map-heap-words function (+ interrupted-esp 1) frame)
- (setf next-frame frame
- next-nether-frame (+ interrupted-esp 1 -2))))))
- (t (error "DIT-frame interrupted unknown CASF funobj: ~S" casf-funobj))))))
- (t (error "Don't know how to scavenge across frame ~S of kind ~S." frame funobj))))))
+ next-nether-frame (+ interrupted-esp 1 -2))))))
+ (t (error "DIT-frame interrupted unknown CASF funobj: ~S" casf-funobj))))))
+ (t (error "Don't know how to scavenge across frame ~S of kind ~S." frame funobj)))))))
(values))
More information about the Movitz-cvs
mailing list