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

Modified Files: scavenge.lisp Log Message: Much improved support for scavenging stacks with interrupts on them.

Date: Tue Apr 6 20:16:38 2004 Author: ffjeld

Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.4 movitz/losp/muerte/scavenge.lisp:1.5 --- movitz/losp/muerte/scavenge.lisp:1.4 Tue Apr 6 10:33:10 2004 +++ movitz/losp/muerte/scavenge.lisp Tue Apr 6 20:16:38 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.4 2004/04/06 14:33:10 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.5 2004/04/07 00:16:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

@@ -96,11 +96,80 @@ and frame = (stack-frame-uplink start-stack-frame) then (stack-frame-uplink frame) while (plusp frame) do (let ((funobj (stack-frame-funobj frame t))) - (etypecase funobj - (integer - (error "Don't know how to scavenge across an interrupt frame.")) + #+ignore + (format t "~&fill ~S frame for ~S" + (aref (%run-time-context-slot 'nursery-space) 0) + funobj) + (typecase funobj (function (assert (= 0 (funobj-frame-num-unboxed funobj))) - (map-heap-words function (+ nether-frame 2) frame))))) + (map-heap-words function (+ nether-frame 2) frame)) + ((eql 0) + ;; 1. Scavenge the interrupt-frame + (map-heap-words function + (+ nether-frame 2) + (+ frame (int-frame-index :ecx))) + (let* ((interrupt-frame frame) + (interrupted-eip-loc + (int-frame-ref interrupt-frame :eip :signed-byte30+2))) + ;; 2. Pop to interrupted frame + (setf nether-frame frame + frame (stack-frame-uplink frame)) + (let ((interrupted-funobj (stack-frame-funobj frame)) + (interrupted-esp (+ interrupt-frame 6))) + (assert (typep interrupted-funobj 'function) () + "Interrupted frame was not a normal function: ~S" + interrupted-funobj) + ;; 3. Scavenge the interrupted frame, skipping EFLAGS etc. + (if (location-in-object-p (funobj-code-vector interrupted-funobj) + interrupted-eip-loc) + ;; The simple case: The interruptee matches interrupted EIP + (map-heap-words function interrupted-esp frame) + (let ((primitive-function-vector + (stack-frame-primitive-funcall interrupted-funobj + interrupted-esp + interrupted-eip-loc))) + (if primitive-function-vector + ;; Next simplest case: The interruptee was in a primitive-function, + ;; with the return-address at top of stack. + (map-heap-words function (1+ interrupted-esp) frame) + (error "Don't know how to scavenge across interrupt frame at ~S." + interrupt-frame))))))) + (t (error "Don't know how to scavenge across a frame of kind ~S." funobj))))) (values))

+(defparameter *primitive-funcall-patterns* + '(#xff #x57 (:function-offset :signed8))) + +(defun stack-frame-primitive-funcall (funobj stack-location eip-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 + (multiple-value-bind (success-p type code) + (match-code-pattern *primitive-funcall-patterns* + code-vector (+ (* (- return-location + (object-location code-vector)) + #.movitz:+movitz-fixnum-factor+) + return-delta + -3 -8) + :function-offset) + (if (not success-p) + (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) + (let* ((offset (ecase type + (:signed8 + (if (not (logbitp 7 code)) code (- code 256))))) + (primitive-function (%word-offset (%run-time-context-ref offset) -2))) + (check-type primitive-function vector-u8) + (if (not (location-in-object-p primitive-function eip-location)) + nil + primitive-function))))))))