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

Modified Files: inspect.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:27 2004 Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.34 movitz/losp/muerte/inspect.lisp:1.35 --- movitz/losp/muerte/inspect.lisp:1.34 Thu Jul 29 05:51:40 2004 +++ movitz/losp/muerte/inspect.lisp Mon Aug 23 06:58:25 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld frodef@acm.org ;;;; Created at: Fri Oct 24 09:50:41 2003 ;;;; -;;;; $Id: inspect.lisp,v 1.34 2004/07/29 12:51:40 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.35 2004/08/23 13:58:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

@@ -38,33 +38,8 @@ (declare (without-check-stack-limit)) ; we do it explicitly.. (check-stack-limit))

-(defun stack-top () - (declare (without-check-stack-limit)) - (load-global-constant stack-top :thread-local t)) - -(defun stack-bottom () - (declare (without-check-stack-limit)) - (load-global-constant stack-bottom :thread-local t)) - -(defun (setf stack-top) (value) - (declare (without-check-stack-limit)) - (check-type value fixnum) - (with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) value) - ((:fs-override) :movl :eax (:edi #.(movitz::global-constant-offset 'stack-top))))) - - -(defun (setf stack-bottom) (value) - (declare (without-check-stack-limit)) - (check-type value fixnum) - (with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) value) - ((:fs-override) :movl :eax (:edi #.(movitz::global-constant-offset 'stack-bottom))))) - - -(defun stack-frame-uplink (stack-frame) - (values (truncate (stack-ref (* 4 stack-frame) 0 0 :unsigned-byte32) - 4))) +(defun stack-frame-uplink (stack frame) + (stack-frame-ref stack frame 0))

(define-compiler-macro current-stack-frame () `(with-inline-assembly (:returns :eax) @@ -72,42 +47,41 @@ :eax)))

(defun current-stack-frame () - (stack-frame-uplink (current-stack-frame))) + (stack-frame-uplink nil (current-stack-frame)))

-(defun stack-frame-funobj (stack-frame &optional accept-non-funobjs) +(defun stack-frame-funobj (stack frame) + (stack-frame-ref stack frame -1) + #+ignore (when stack-frame - (let ((x (stack-frame-ref stack-frame -1))) + (let ((x (stack-frame-ref stack-frame -1 stack))) (and (or accept-non-funobjs (typep x 'function)) x))))

-(defun stack-frame-call-site (stack-frame) +(defun stack-frame-call-site (stack frame) "Return the code-vector and offset into this vector that is immediately after the point that called this stack-frame." - (let ((funobj (stack-frame-funobj (stack-frame-uplink stack-frame)))) - (when funobj - (let* ((code-vector (funobj-code-vector funobj)) - (x (stack-ref (* 4 stack-frame) 0 1 :unsigned-byte32)) - (delta (- x 8 (* #.movitz::+movitz-fixnum-factor+ (object-location code-vector))))) - (when (below delta (length code-vector)) - (values delta code-vector funobj)))))) - -(defun stack-frame-ref (stack-frame index) - (if (= 0 index) - (stack-frame-uplink stack-frame) - (stack-ref (* 4 stack-frame) 0 index :lisp))) - -(defun stack-ref-p (pointer) - (let ((top (load-global-constant-u32 stack-top)) - (bottom (with-inline-assembly (:returns :eax) - (:movl :esp :eax) - (:shll #.movitz:+movitz-fixnum-shift+ :eax)))) - (<= bottom pointer top))) - -(defun stack-ref (pointer offset index type) - #+ignore (assert (stack-ref-p pointer) (pointer) - "Stack pointer not in range: #x~X" pointer) - (memref-int pointer offset index type)) + (let ((uplink (stack-frame-uplink stack frame))) + (when (and uplink (not (= 0 uplink))) + (let ((funobj (stack-frame-funobj stack uplink))) + (when (typep funobj 'function) + (let* ((code-vector (funobj-code-vector funobj)) + (eip (stack-frame-ref stack frame 1 :unsigned-byte32)) + (delta (- eip 8 (* #.movitz::+movitz-fixnum-factor+ (object-location code-vector))))) + (when (below delta (length code-vector)) + (values delta code-vector funobj)))))))) + +(defun stack-frame-ref (stack frame index &optional (type ':lisp)) + "If stack is provided, stack-frame is an index into that stack vector. +Otherwise, stack-frame is an absolute location." + (cond + ((not (null stack)) + (check-type stack (simple-array (unsigned-byte 32) 1)) + (let ((pos (+ frame index))) + (assert (< -1 pos (length stack)) + () "Index ~S, pos ~S, len ~S" index pos (length stack)) + (memref stack 2 pos type))) + (t (memref frame 0 index type))))

(defun current-dynamic-context () (with-inline-assembly (:returns :untagged-fixnum-ecx) @@ -340,7 +314,7 @@ (* 2 (truncate (+ (structure-object-length object) 1) 2))))))))

-(defun copy-control-stack (&key (absolutep) +(defun copy-control-stack (&key (relative-uplinks t) (stack (%run-time-context-slot 'stack-vector)) (frame (current-stack-frame))) (assert (location-in-object-p stack frame)) @@ -359,9 +333,13 @@ (assert (< -1 uplink-index (length copy)) () "Uplink-index outside copy: ~S, i: ~S" uplink-index i) (setf (svref%unsafe copy i) - (if absolutep + (if relative-uplinks uplink-index (let ((x (+ uplink-index copy-start-location))) - (assert (location-in-object-p copy x)) - (setf (svref%unsafe copy i) x)))) + (assert (= copy-start-location (+ 2 (object-location copy))) () + "Destination stack re-located!") + (assert (location-in-object-p copy x) () + "Bad uplink ~S computed from index ~S and copy ~Z, csl: ~S" + x uplink-index copy copy-start-location) + x))) (setf i uplink-index))))))))