Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv9367

Modified Files: scavenge.lisp Log Message: Changed the way stack locations are represented: Rather than merely a 'location' (which is a simple pointer, and so GC-unsafe), we now use two values: a vector and an index. If vector is non-nil, index is a an index into the vector. If vector is nil, index is a location (as before), typically referencing the currently active stack, which won't move (but probably this mode should be deprecated).

Date: Mon Aug 23 06:58:35 2004 Author: ffjeld

Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.26 movitz/losp/muerte/scavenge.lisp:1.27 --- movitz/losp/muerte/scavenge.lisp:1.26 Thu Aug 12 10:11:55 2004 +++ movitz/losp/muerte/scavenge.lisp Mon Aug 23 06:58:34 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld frodef@acm.org ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.26 2004/08/12 17:11:55 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.27 2004/08/23 13:58:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

@@ -35,42 +35,34 @@ start-location and end-location." (macrolet ((scavenge-typep (x primary) (let ((code (movitz:tag primary))) - `(with-inline-assembly (:returns :boolean-zf=1) - (:compile-form (:result-mode :eax) ,x) - (:cmpb ,code :al)))) + `(= ,code (ldb (byte 8 0) ,x)))) (scavenge-wide-typep (x primary secondary) (let ((code (dpb secondary (byte 8 8) (movitz:tag primary)))) - `(with-inline-assembly (:returns :boolean-zf=1) - (:compile-form (:result-mode :eax) ,x) - (:cmpw ,code :ax)))) - (word-bigits (x) - "If x is a bignum header word, return the number of bigits." - `(with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) ,x) - (:shrl 16 :eax) - (:testb ,movitz:+movitz-fixnum-zmask+ :al) - (:jnz '(:sub-program () (:int 63)))))) + `(= ,code ,x)))) (do ((verbose *map-heap-words-verbose*) (*scan-last* nil) ; Last scanned object, for debugging. (scan start-location (1+ scan))) ((>= scan end-location)) (declare (special *scan-last*)) (let ((*scan* scan) - (x (memref scan 0 0 :lisp))) + (x (memref scan 0 0 :unsigned-byte16))) (declare (special *scan*)) (when verbose - (format *terminal-io* "~&MHW scanning at ~S: ~Z" scan x)) + (format *terminal-io* " [at ~S: ~S]" scan x)) (cond - ((typep x '(or null fixnum character))) + ((let ((tag (ldb (byte 3 0) x))) + (or (= tag #.(movitz:tag :null)) + (= tag #.(movitz:tag :fixnum)) + (scavenge-typep x :character)))) ((scavenge-typep x :illegal) - (error "Illegal word ~Z at ~S." x scan)) + (error "Illegal word ~S at ~S." x scan)) ((scavenge-typep x :bignum) (assert (evenp scan) () - "Scanned ~Z at odd location #x~X." x scan) + "Scanned ~S at odd location #x~X." x scan) ;; Just skip the bigits - (let* ((bigits (word-bigits x)) + (let* ((bigits (memref scan 0 1 :unsigned-byte14)) (delta (logior bigits 1))) (setf *scan-last* (%word-offset scan #.(movitz:tag :other))) (incf scan delta))) @@ -128,27 +120,28 @@ (error "Scanned unknown basic-vector #x~Z at address #x~X." x scan)) ((scavenge-typep x :old-vector) (error "Scanned old-vector ~Z at address #x~X." x scan)) - ((eq x (%lispval-object 3)) + ((eq x 3) (incf scan) (let ((delta (memref scan 0 0 :lisp))) (check-type delta positive-fixnum) ;; (warn "at ~S skipping ~S to ~S." scan delta (+ scan delta)) (incf scan delta))) - ((typep x 'pointer) - (let ((new (funcall function x scan))) + (t ;; (typep x 'pointer) + (let* ((old (memref scan 0 0 :lisp)) + (new (funcall function old scan))) (when verbose - (format *terminal-io* " [~Z => ~Z]" x new)) - (unless (eq new x) + (format *terminal-io* " [~Z => ~Z]" old new)) + (unless (eq old new) (setf (memref scan 0 0 :lisp) new)))))))) (values))

-(defun map-stack-words (function start-stack-frame) +(defun map-stack-words (function stack start-frame) "Map function over the potential pointer words of a stack, starting at the start-stack-frame location." - (loop for nether-frame = start-stack-frame then frame - and frame = (stack-frame-uplink start-stack-frame) then (stack-frame-uplink frame) + (loop for nether-frame = start-frame then frame + and frame = (stack-frame-uplink stack start-frame) then (stack-frame-uplink stack frame) while (plusp frame) - do (let ((funobj (funcall function (stack-frame-funobj frame t) nil))) + do (let ((funobj (funcall function (stack-frame-funobj stack frame) nil))) (typecase funobj (function (assert (= 0 (funobj-frame-num-unboxed funobj))) @@ -160,103 +153,108 @@ (cond ((logbitp 10 (dit-frame-ref :eflags :unsigned-byte32 0 dit-frame)) ;; DF flag was 1, so EAX and EDX are not GC roots. + #+ignore (warn "Interrupt in uncommon mode at ~S" (dit-frame-ref :eip :unsigned-byte32 0 dit-frame)) (map-heap-words function ; Assume nothing in the dit-frame above the location .. (+ nether-frame 2) ; ..of EBX holds pointers. (+ frame (dit-frame-index :ebx)))) - (t (warn "Interrupt in COMMON mode!") + (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. (+ frame (dit-frame-index :ecx))))) ;; 2. Pop to (dit-)frame's CASF (setf nether-frame frame frame (dit-frame-casf frame)) - (let ((casf-funobj (funcall function (stack-frame-funobj frame t) nil)) + (let ((casf-funobj (funcall function (stack-frame-funobj stack frame) nil)) (interrupted-esp (dit-frame-esp dit-frame))) - (assert (typep casf-funobj 'function) () - "Interrupted CASF frame was not a normal function: ~S" - casf-funobj) - (let ((casf-code-vector (funobj-code-vector casf-funobj))) - ;; 3. Scavenge the interrupted frame, according to one of i. ii. or iii. - (cond - ((location-in-object-p casf-code-vector - (dit-frame-ref :eip :location 0 dit-frame)) - ;; Situation i. Nothing special on stack, scavenge frame normally. - (map-heap-words function interrupted-esp frame)) - ((eq casf-frame (memref interrupted-esp 0 0 :location)) - ;; Situation ii. esp(0)=CASF, esp(1)=code-vector - (assert (location-in-object-p casf-code-vector - (memref interrupted-esp 0 1 :location)) - () "Stack discipline situation ii. invariant broken. CASF=#x~X" - casf-frame) - (map-heap-words function (+ interrupted-esp 2) frame)) - (t ;; Situation iii. esp(0)=code-vector. - (assert (location-in-object-p casf-code-vector - (memref interrupted-esp 0 0 :location)) - () "Stack discipline situation iii. invariant broken. CASF=#x~X" - casf-frame) - (map-heap-words function (+ interrupted-esp 1) frame))))))) + (cond + ((eq 0 casf-funobj) + (warn "Interrupt (presumably) in interrupt trampoline.")) + (t (assert (typep casf-funobj 'function) () + "Interrupted CASF frame was not a normal function: ~S" + casf-funobj) + (let ((casf-code-vector (funobj-code-vector casf-funobj))) + ;; 3. Scavenge the interrupted frame, according to one of i. ii. or iii. + (cond + ((location-in-object-p casf-code-vector + (dit-frame-ref :eip :location 0 dit-frame)) + ;; Situation i. Nothing special on stack, scavenge frame normally. + (map-heap-words function interrupted-esp frame)) + ((eq casf-frame (memref interrupted-esp 0 0 :location)) + ;; Situation ii. esp(0)=CASF, esp(1)=code-vector + (assert (location-in-object-p casf-code-vector + (memref interrupted-esp 0 1 :location)) + () "Stack discipline situation ii. invariant broken. CASF=#x~X" + casf-frame) + (map-heap-words function (+ interrupted-esp 2) frame)) + (t ;; Situation iii. esp(0)=code-vector. + (assert (location-in-object-p casf-code-vector + (memref interrupted-esp 0 0 :location)) + () "Stack discipline situation iii. invariant broken. CASF=#x~X" + casf-frame) + (map-heap-words function (+ interrupted-esp 1) frame))))))))) (t (error "Don't know how to scavenge across frame ~S of kind ~S." frame funobj))))) (values))

-(defparameter *primitive-funcall-patterns* - '((:or - (#xff #x57 (:function-offset :signed8)) ; - (#xff #x97 (:function-offset :signed32))))) ; - -(defun stack-frame-primitive-funcall (funobj stack-location eip-location) - "Is stack-frame in a primitive-function? -If so, return the primitive-function's code-vector." - (declare (ignore eip-location)) - ;; XXXX Really we should make comparisons against :call-local-pf - ;; such that we find the active set of local-pf's from the stack-location! - (let ((return-address (memref stack-location 0 0 :unsigned-byte32)) - (code-vector (funobj-code-vector funobj))) - (multiple-value-bind (return-location return-delta) - (truncate return-address #.movitz:+movitz-fixnum-factor+) - (if (not (location-in-object-p code-vector return-location)) - nil ; A PF must have return-address on top of stack. - (dotimes (offset 5 (warn "mismatch in ~S at ~D from #x~X in ~Z." - funobj - (+ (* (- return-location - (object-location code-vector)) - #.movitz:+movitz-fixnum-factor+) - return-delta - -3 -8) - return-address code-vector)) - (multiple-value-bind (success-p type code ip) - (match-code-pattern *primitive-funcall-patterns* - code-vector (+ (* (- return-location - (object-location code-vector)) - #.movitz:+movitz-fixnum-factor+) - return-delta - -3 -8 (- offset)) - :function-offset) - (when success-p - (return - (let* ((offset (case type - (:signed8 - (if (not (logbitp 7 code)) code (- code 256))) - (:signed32 - ;; We must read the unsigned-byte32 that starts at ip - (let ((x (logior (aref code-vector (- ip 1)) - (* (aref code-vector (+ 0 ip)) #x100) - (* (aref code-vector (+ 1 ip)) #x10000) - (* (aref code-vector (+ 2 ip)) #x1000000)))) - (if (not (logbitp 7 (aref code-vector (+ ip 2)))) - x - (break "Negative 32-bit offset.")))) - (t (break "Match fail: vec: ~Z, ip: ~D" - code-vector (+ (* (- return-location - (object-location code-vector)) - #.movitz:+movitz-fixnum-factor+) - return-delta - -3 -8))))) - (primitive-function (%word-offset (%run-time-context-ref offset) -2))) - (if (not (typep primitive-function 'code-vector)) - nil - primitive-function)))))))))) +;;;(defparameter *primitive-funcall-patterns* +;;; '((:or +;;; (#xff #x57 (:function-offset :signed8)) ; +;;; (#xff #x97 (:function-offset :signed32))))) ; +;;; +;;;(defun stack-frame-primitive-funcall (funobj stack-location eip-location) +;;; "Is stack-frame in a primitive-function? +;;;If so, return the primitive-function's code-vector." +;;; (declare (ignore eip-location)) +;;; ;; XXXX Really we should make comparisons against :call-local-pf +;;; ;; such that we find the active set of local-pf's from the stack-location! +;;; (let ((return-address (memref stack-location 0 0 :unsigned-byte32)) +;;; (code-vector (funobj-code-vector funobj))) +;;; (multiple-value-bind (return-location return-delta) +;;; (truncate return-address #.movitz:+movitz-fixnum-factor+) +;;; (if (not (location-in-object-p code-vector return-location)) +;;; nil ; A PF must have return-address on top of stack. +;;; (dotimes (offset 5 (warn "mismatch in ~S at ~D from #x~X in ~Z." +;;; funobj +;;; (+ (* (- return-location +;;; (object-location code-vector)) +;;; #.movitz:+movitz-fixnum-factor+) +;;; return-delta +;;; -3 -8) +;;; return-address code-vector)) +;;; (multiple-value-bind (success-p type code ip) +;;; (match-code-pattern *primitive-funcall-patterns* +;;; code-vector (+ (* (- return-location +;;; (object-location code-vector)) +;;; #.movitz:+movitz-fixnum-factor+) +;;; return-delta +;;; -3 -8 (- offset)) +;;; :function-offset) +;;; (when success-p +;;; (return +;;; (let* ((offset (case type +;;; (:signed8 +;;; (if (not (logbitp 7 code)) code (- code 256))) +;;; (:signed32 +;;; ;; We must read the unsigned-byte32 that starts at ip +;;; (let ((x (logior (aref code-vector (- ip 1)) +;;; (* (aref code-vector (+ 0 ip)) #x100) +;;; (* (aref code-vector (+ 1 ip)) #x10000) +;;; (* (aref code-vector (+ 2 ip)) #x1000000)))) +;;; (if (not (logbitp 7 (aref code-vector (+ ip 2)))) +;;; x +;;; (break "Negative 32-bit offset.")))) +;;; (t (break "Match fail: vec: ~Z, ip: ~D" +;;; code-vector (+ (* (- return-location +;;; (object-location code-vector)) +;;; #.movitz:+movitz-fixnum-factor+) +;;; return-delta +;;; -3 -8))))) +;;; (primitive-function (%word-offset (%run-time-context-ref offset) -2))) +;;; (if (not (typep primitive-function 'code-vector)) +;;; nil +;;; primitive-function)))))))))) ;;; (check-type primitive-function code-vector) ;;; (if (not (location-in-object-p primitive-function eip-location)) ;;; nil