[movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Tue Jan 25 13:56:21 UTC 2005
Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory common-lisp.net:/tmp/cvs-serv17178
Modified Files:
scavenge.lisp
Log Message:
Re-working the stack discipline/scavenging strategy. Still not quite
there, but it seems close.
Date: Tue Jan 25 05:56:19 2005
Author: ffjeld
Index: movitz/losp/muerte/scavenge.lisp
diff -u movitz/losp/muerte/scavenge.lisp:1.39 movitz/losp/muerte/scavenge.lisp:1.40
--- movitz/losp/muerte/scavenge.lisp:1.39 Tue Jan 4 08:54:27 2005
+++ movitz/losp/muerte/scavenge.lisp Tue Jan 25 05:56:18 2005
@@ -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.39 2005/01/04 16:54:27 ffjeld Exp $
+;;;; $Id: scavenge.lisp,v 1.40 2005/01/25 13:56:18 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -36,7 +36,7 @@
(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)))
+ (let ((new-object (do-map object location)))
(unless (eq object new-object)
(setf (memref location 0) new-object)))))))
@@ -139,7 +139,7 @@
#.(bt:enum-value 'movitz:movitz-vector-element-type :any-t))
(setf *scan-last* (%word-offset scan #.(movitz:tag :other)))
(error "Scanned unknown basic-vector-header ~S at location #x~X." x scan)))
- ((eq x 3)
+ ((and (eq x 3) (eq x2 0))
(setf *scan-last* scan)
(incf scan)
(let ((delta (memref scan 0)))
@@ -147,17 +147,208 @@
;; (warn "at ~S skipping ~S to ~S." scan delta (+ scan delta))
(incf scan delta)))
(t ;; (typep x 'pointer)
- (let* ((old (memref scan 0))
- (new (funcall function old scan)))
- (when verbose
- (format *terminal-io* " [~Z => ~Z]" old new))
- (unless (eq old new)
- (setf (memref scan 0) new)))))))))
+ (let ((old (memref scan 0)))
+ (unless (eq old (load-global-constant new-unbound-value))
+ (let ((new (funcall function old scan)))
+ (when verbose
+ (format *terminal-io* " [~Z => ~Z]" old new))
+ (unless (eq old new)
+ (setf (memref scan 0) new)))))))))))
(values))
(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."
+ (assert (typep (stack-frame-funobj stack start-frame) 'function) (start-frame)
+ "Cannot start map-stack-vector at a non-normal frame.")
+ (assert (eq nil stack))
+ (map-stack function
+ (stack-frame-uplink stack start-frame)
+ (+ start-frame 2)
+ (+ start-frame 1)
+ map-region))
+
+;;;(defun map-code-vector-slot (function stack slot casf-funobj)
+;;; (let ((casf-code-vector (if (eq 0 casf-funobj)
+;;; (symbol-value 'default-interrupt-trampoline)
+;;; (funobj-code-vector casf-funobj)))
+;;; (eip-location (stack-frame-ref stack slot 0 :location)))
+;;; (cond
+;;; ((location-in-object-p casf-code-vector eip-location)
+;;; (let ((new (funcall function casf-code-vector nil)))
+;;; (when (not (eq new casf-code-vector))
+;;; ;; Perform some pointer arithmetics..
+;;; (let ((offset (- (stack-frame-ref stack slot 0 :unsigned-byte32)
+;;; (%object-lispval casf-code-vector))))
+;;; (break "Code-vector for ~S moved, offset is ~D." casf-code-vector offset))))))))
+
+(defun scavenge-find-code-vector (location casf-funobj esi &optional searchp)
+ (flet ((match-funobj (funobj location)
+ (cond
+ ((let ((x (funobj-code-vector casf-funobj)))
+ (and (location-in-object-p x location) x)))
+ ((let ((x (funobj-code-vector%1op casf-funobj)))
+ (and (typep x 'vector)
+ (location-in-object-p x location)
+ x)))
+ ((let ((x (funobj-code-vector%2op casf-funobj)))
+ (and (typep x 'vector)
+ (location-in-object-p x location)
+ x)))
+ ((let ((x (funobj-code-vector%3op casf-funobj)))
+ (and (typep x 'vector)
+ (location-in-object-p x location)
+ x))))))
+ (cond
+ ((eq 0 casf-funobj)
+ (let ((dit-code-vector (symbol-value 'default-interrupt-trampoline)))
+ (if (location-in-object-p dit-code-vector location)
+ dit-code-vector
+ (break "DIT returns outside DIT??"))))
+ ((and (typep esi 'function)
+ (match-funobj esi location)))
+ ((match-funobj casf-funobj location))
+ ((not (typep casf-funobj 'function))
+ (break "Unknown funobj/frame-type: ~S" casf-funobj))
+ ((when searchp
+ (%find-code-vector location)))
+ (t (error "Unable to decode EIP #x~X funobj ~S." location casf-funobj)))))
+
+(defun map-stack-value (function value frame)
+ (if (not (typep value 'pointer))
+ value
+ (funcall function value frame)))
+
+(defun map-stack (function frame frame-bottom eip-index map-region)
+ (with-funcallable (map-region)
+ (loop
+ ;; for frame = frame then (stack-frame-uplink frame)
+ ;; as frame-end = frame-end then frame
+ while (not (eq 0 frame))
+ do (map-lisp-vals function (1- frame) frame)
+ (let ((frame-funobj (map-stack-value function (stack-frame-funobj nil frame) frame)))
+ (cond
+ ((eq 0 frame-funobj)
+ (return (map-stack-dit function frame frame-bottom eip-index map-region)))
+ ((not (typep frame-funobj 'function))
+ (error "Unknown stack-frame funobj ~S at ~S" frame-funobj frame))
+ (t (let* ((old-code-vector
+ (scavenge-find-code-vector (stack-frame-ref nil eip-index 0 :location)
+ frame-funobj nil nil)))
+ (map-stack-instruction-pointer function eip-index old-code-vector))
+ (let ((raw-locals (funobj-frame-raw-locals frame-funobj)))
+ (if (= 0 raw-locals)
+ (map-region function frame-bottom frame)
+ (progn
+ (break "~D raw-locals for ~S?" raw-locals frame-funobj)
+ (map-region function (1- frame) frame)
+ (map-region function frame-bottom (- frame 1 raw-locals))))
+ (setf eip-index (+ frame 1)
+ frame-bottom (+ frame 2)
+ frame (stack-frame-uplink nil frame)))))))))
+
+(defun test-stack ()
+ (let ((z (current-stack-frame)))
+ (map-stack (lambda (x y)
+ (format t "~&[~S]: ~S" y x)
+ x)
+ (stack-frame-uplink nil z) (+ z 2) (+ z 1)
+ #'map-header-vals)))
+
+(defun map-stack-dit (function dit-frame frame-bottom eip-index map-region)
+ (with-funcallable (map-region)
+ (let* ((atomically
+ (dit-frame-ref nil dit-frame :atomically-continuation :unsigned-byte32))
+ (secondary-register-mode-p
+ (logbitp 10 (dit-frame-ref nil dit-frame :eflags :unsigned-byte32)))
+ (casf-frame
+ (dit-frame-casf nil dit-frame))
+ (casf-funobj (map-stack-value function (stack-frame-funobj nil casf-frame) casf-frame))
+ (casf-code-vector (map-stack-value function
+ (case casf-funobj
+ (0 (symbol-value 'default-interrupt-trampoline))
+ (t (funobj-code-vector casf-funobj)))
+ casf-frame)))
+ ;; 1. Scavenge the dit-frame
+ (cond
+ ((and (not (= 0 atomically))
+ (= 0 (ldb (byte 2 0) atomically)))
+ ;; Interrupt occurred inside an (non-pf) atomically, so none of the
+ ;; GC-root registers are active.
+ (setf (dit-frame-ref nil dit-frame :eax) nil
+ (dit-frame-ref nil dit-frame :ebx) nil
+ (dit-frame-ref nil dit-frame :edx) nil
+ (dit-frame-ref nil dit-frame :esi) nil)
+ (map-region function frame-bottom (+ dit-frame 1 (dit-frame-index :scratch1))))
+ (secondary-register-mode-p
+ ;; EBX is also active
+ (map-region function frame-bottom (+ dit-frame 1 (dit-frame-index :ebx))))
+ (t ;; EDX and EAX too.
+ (map-region function frame-bottom (+ dit-frame 1 (dit-frame-index :eax)))))
+ ;; The DIT's return-address
+ (let* ((interrupted-esi (dit-frame-ref nil dit-frame :esi))
+ (next-frame-bottom (+ dit-frame 1 (dit-frame-index :eflags)))
+ (next-eip-index (+ dit-frame (dit-frame-index :eip)))
+ (old-code-vector
+ (scavenge-find-code-vector (stack-frame-ref nil eip-index 0 :location)
+ 0 interrupted-esi
+ nil))
+ (new-code-vector (map-stack-instruction-pointer function eip-index old-code-vector)))
+ ;;
+ (multiple-value-bind (x0-location x0-tag)
+ (stack-frame-ref nil next-frame-bottom 0 :signed-byte30+2)
+ ;; (warn "X0: ~S ~S" x0-location x0-tag)
+ (cond
+ ((and (or (eq x0-tag 1) ; 1 or 5?
+ (eq x0-tag 3) ; 3 or 7?
+ (and (oddp x0-location) (eq x0-tag 2))) ; 6?
+ (location-in-object-p casf-code-vector x0-location))
+ (let* ((old-x0-code-vector
+ (scavenge-find-code-vector (stack-frame-ref nil next-eip-index 0 :location)
+ casf-funobj interrupted-esi t)))
+ (map-stack-instruction-pointer function next-eip-index old-x0-code-vector))
+ (setf next-eip-index next-frame-bottom
+ next-frame-bottom (1+ next-frame-bottom)))
+ (t (multiple-value-bind (x1-location x1-tag)
+ (stack-frame-ref nil next-frame-bottom 1 :signed-byte30+2)
+ (when (and (or (eq x1-tag 1) ; 1 or 5?
+ (eq x1-tag 3) ; 3 or 7?
+ (and (oddp x1-location) (eq x1-tag 2))) ; 6?
+ (location-in-object-p casf-code-vector x1-location))
+ (warn "X1: ~S ~S" x1-location x1-tag)
+ (let* ((old-x1-code-vector
+ (scavenge-find-code-vector (stack-frame-ref nil next-eip-index 0 :location)
+ casf-funobj interrupted-esi t)))
+ (map-stack-instruction-pointer function next-eip-index old-x1-code-vector))
+ (setf next-eip-index (+ 1 next-frame-bottom)
+ next-frame-bottom (+ 2 next-frame-bottom)))))))
+ ;; proceed
+ (map-stack function casf-frame next-frame-bottom next-eip-index map-region)))))
+
+(defun map-stack-instruction-pointer (function index old-code-vector)
+ "Update the (raw) instruction-pointer in stack at index,
+assuming the pointer refers to old-code-vector."
+ (assert (location-in-object-p old-code-vector (stack-frame-ref nil index 0 :location)))
+ (let ((new-code-vector (funcall function old-code-vector nil)))
+ (when (not (eq old-code-vector new-code-vector))
+ (break "Code-vector for stack instruction-pointer moved. [index: ~S]" index))
+ new-code-vector))
+
+(defun map-stack-flaccid-pointer (function index)
+ "If the pointed-to object is moved, reset pointer to NIL."
+ (let ((old (stack-frame-ref nil index 0)))
+ (cond
+ ((not (typep old 'pointer))
+ old)
+ ((eq old (funcall function old index))
+ old)
+ (t (setf (stack-frame-ref nil index 0) nil)))))
+
+
+#+ignore
+(defun old-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."
(with-funcallable (map-region)
(loop with next-frame with next-nether-frame
for nether-frame = start-frame then (or next-nether-frame frame)
@@ -176,7 +367,7 @@
(incf nether-frame 4))
(typecase funobj
((or function null)
- (assert (= 0 (funobj-frame-num-unboxed funobj)))
+ (assert (= 0 (funobj-frame-raw-locals funobj)))
(map-region function (+ nether-frame 2) frame))
((eql 0) ; A dit interrupt-frame?
(let* ((dit-frame frame)
@@ -210,10 +401,6 @@
(interrupted-ebp (dit-frame-ref stack dit-frame :ebp))
(casf-funobj (funcall function (stack-frame-funobj stack frame) 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)))
More information about the Movitz-cvs
mailing list