Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory common-lisp.net:/tmp/cvs-serv13009
Modified Files:
scavenge.lisp
Log Message:
Rename to map-instruction-pointer.
Date: Tue Feb 15 23:22:47 2005
Author: ffjeld
Index: movitz/losp/muerte/scavenge.lisp
diff -u movitz/losp/muerte/scavenge.lisp:1.47 movitz/losp/muerte/scavenge.lisp:1.48
--- movitz/losp/muerte/scavenge.lisp:1.47 Thu Feb 3 10:13:20 2005
+++ movitz/losp/muerte/scavenge.lisp Tue Feb 15 23:22:47 2005
@@ -10,7 +10,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org>
;;;; Created at: Mon Mar 29 14:54:08 2004
;;;;
-;;;; $Id: scavenge.lisp,v 1.47 2005/02/03 09:13:20 ffjeld Exp $
+;;;; $Id: scavenge.lisp,v 1.48 2005/02/15 22:22:47 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -98,7 +98,7 @@
(let ((new-code-vector (funcall function code-vector scan)))
(check-type new-code-vector code-vector)
(unless (eq code-vector new-code-vector)
- (error "Code-vector migration is not implemented.")
+ (error "Code-vector migration is not implemented (~S)." funobj)
(setf (memref scan 0 :index -1) (%word-offset new-code-vector 2))
;; Do more stuff here to update code-vectors and jumpers
))
@@ -195,24 +195,22 @@
(location-in-object-p x location)
x))))))
(cond
+ ((location-in-object-p (symbol-value 'ret-trampoline) location)
+ (symbol-value 'ret-trampoline))
+ ((location-in-object-p (%run-time-context-slot 'dynamic-jump-next) location)
+ (%run-time-context-slot 'dynamic-jump-next))
((eq 0 casf-funobj)
(let ((dit-code-vector (symbol-value 'default-interrupt-trampoline)))
(cond
((location-in-object-p dit-code-vector location)
dit-code-vector)
((match-funobj esi location))
- ((location-in-object-p (symbol-value 'ret-trampoline) location)
- (symbol-value 'ret-trampoline))
(t (break "DIT returns outside DIT??")))))
((match-funobj casf-funobj location))
((match-funobj esi location))
((match-funobj edx location))
((not (typep casf-funobj 'function))
(break "Unknown funobj/frame-type: ~S" casf-funobj))
- ((location-in-object-p (symbol-value 'ret-trampoline) location)
- (symbol-value 'ret-trampoline))
- ((location-in-object-p (%run-time-context-slot 'dynamic-jump-next) location)
- (%run-time-context-slot 'dynamic-jump-next))
((when primitive-function-p
(scavenge-find-pf location)
#+ignore
@@ -247,7 +245,7 @@
(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))
+ (map-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)
@@ -306,7 +304,7 @@
(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)))
+ (new-code-vector (map-instruction-pointer function eip-index old-code-vector)))
;; (when atomically (we should be more clever about the stack..))
(multiple-value-bind (x0-location x0-tag)
(stack-frame-ref nil next-frame-bottom 0 :signed-byte30+2)
@@ -324,7 +322,7 @@
casf-funobj interrupted-esi t
(unless secondary-register-mode-p
(dit-frame-ref nil dit-frame :edx)))))
- (map-stack-instruction-pointer function next-eip-index old-x0-code-vector))
+ (map-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)
@@ -339,19 +337,21 @@
(unless secondary-register-mode-p
interrupted-esi)
t)))
- (map-stack-instruction-pointer function next-eip-index old-x1-code-vector))
+ (map-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,
+(defun map-instruction-pointer (function location
+ &optional (old-code-vector (memref location 0 :type :code-vector)))
+ "Update the (raw) instruction-pointer at location,
assuming the pointer refers to old-code-vector."
- (assert (location-in-object-p old-code-vector (stack-frame-ref nil index 0 :location)))
+ (check-type old-code-vector code-vector)
+ (assert (location-in-object-p old-code-vector (memref location 0 :type :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))
+ (break "Code-vector for stack instruction-pointer moved at location ~S" location))
new-code-vector))