[movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp

[Frode Vatvedt Fjeld]

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

Modified Files:
	scavenge.lisp 
Log Message:
Added support for bignums in map-heap-words. So now you can GC all
those bigguns.

Date: Thu Jun 10 12:29:45 2004
Author: ffjeld

Index: movitz/losp/muerte/scavenge.lisp
diff -u movitz/losp/muerte/scavenge.lisp:1.8 movitz/losp/muerte/scavenge.lisp:1.9
--- movitz/losp/muerte/scavenge.lisp:1.8	Wed Jun  2 07:31:15 2004
+++ movitz/losp/muerte/scavenge.lisp	Thu Jun 10 12:29:45 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.8 2004/06/02 14:31:15 ffjeld Exp $
+;;;; $Id: scavenge.lisp,v 1.9 2004/06/10 19:29:45 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -52,6 +52,12 @@
 	 ((typep x '(or null fixnum character)))
 	 ((scavenge-typep x :illegal)
 	  (error "Illegal word ~Z at ~S." x scan))
+	 ((scavenge-typep x :bignum)
+	  ;; Just skip the bigits
+	  (let* ((bigits (memref scan 2 0 :unsigned-byte16))
+		 (size (+ 2 (logand bigits -2))))
+	    (assert (and (plusp bigits) (evenp size)))
+	    (incf scan size)))
 	 ((scavenge-typep x :funobj)
 	  ;; Process code-vector pointer specially..
 	  (let* ((funobj (%word-offset scan #.(movitz:tag :other)))
@@ -68,7 +74,7 @@
 		))
 	    (incf scan (+ 7 num-jumpers)))) ; Don't scan the jumpers.
 	 ((scavenge-typep x :infant-object)
-	  (error "Scanning an infant object ~Z at ~S." x scan))
+	  (error "Scanning an infant object ~Z at ~S (end ~S)." x scan end-location))
 	 ((or (scavenge-wide-typep x :vector
 				   #.(bt:enum-value 'movitz:movitz-vector-element-type :u8))
 	      (scavenge-wide-typep x :vector
@@ -140,37 +146,57 @@
   (values))
 
 (defparameter *primitive-funcall-patterns*
-    '(#xff #x57 (:function-offset :signed8)))
+    '((: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."
   (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))))))))
+	  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)))
+		  (check-type primitive-function vector-u8)
+		  (if (not (location-in-object-p primitive-function eip-location))
+		      nil
+		    primitive-function))))))))))