X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=63b899b61a1c68a5613572b0a8a68992817a560a;hb=2dbee6e782b54f8780933790d61a24cdb67b8d04;hp=f2e6012229248616a851ff02effe2414fdbf8619;hpb=aab81dccfb1a311eac523a855004a3669340aca6;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index f2e6012..63b899b 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -298,7 +298,7 @@ ;;; This maps SB!C::COMPILED-DEBUG-FUNs to ;;; COMPILED-DEBUG-FUNs, so we can get at cached stuff and not ;;; duplicate COMPILED-DEBUG-FUN structures. -(defvar *compiled-debug-funs* (make-hash-table :test 'eq)) +(defvar *compiled-debug-funs* (make-hash-table :test 'eq :weakness :key)) ;;; Make a COMPILED-DEBUG-FUN for a SB!C::COMPILER-DEBUG-FUN and its ;;; component. This maps the latter to the former in @@ -479,7 +479,7 @@ ;; valid value at this code-location. (unexported). (%live-set :unparsed :type (or simple-bit-vector (member :unparsed))) ;; (unexported) To see SB!C::LOCATION-KIND, do - ;; (SB!KERNEL:TYPE-EXPAND 'SB!C::LOCATION-KIND). + ;; (SB!KERNEL:TYPEXPAND 'SB!C::LOCATION-KIND). (kind :unparsed :type (or (member :unparsed) sb!c::location-kind)) (step-info :unparsed :type (or (member :unparsed :foo) simple-string))) @@ -515,7 +515,7 @@ (defun fun-word-offset (fun) (fun-word-offset fun)) #!-sb-fluid (declaim (inline control-stack-pointer-valid-p)) -(defun control-stack-pointer-valid-p (x) +(defun control-stack-pointer-valid-p (x &optional (aligned t)) (declare (type system-area-pointer x)) (let* (#!-stack-grows-downward-not-upward (control-stack-start @@ -526,11 +526,11 @@ #!-stack-grows-downward-not-upward (and (sap< x (current-sp)) (sap<= control-stack-start x) - (zerop (logand (sap-int x) sb!vm:fixnum-tag-mask))) + (or (not aligned) (zerop (logand (sap-int x) sb!vm:fixnum-tag-mask)))) #!+stack-grows-downward-not-upward (and (sap>= x (current-sp)) (sap> control-stack-end x) - (zerop (logand (sap-int x) sb!vm:fixnum-tag-mask))))) + (or (not aligned) (zerop (logand (sap-int x) sb!vm:fixnum-tag-mask)))))) (declaim (inline component-ptr-from-pc)) (sb!alien:define-alien-routine component-ptr-from-pc (system-area-pointer) @@ -558,7 +558,7 @@ (- (get-lisp-obj-address code) sb!vm:other-pointer-lowtag) code-header-len))) -; (format t "c-lra-fpc ~A ~A ~A~%" pc code pc-offset) + ;;(format t "c-lra-fpc ~A ~A ~A~%" pc code pc-offset) (values pc-offset code))))) #!+(or x86 x86-64) @@ -594,61 +594,14 @@ (declaim (maybe-inline x86-call-context)) (defun x86-call-context (fp) (declare (type system-area-pointer fp)) - (labels ((fail () - (values nil - (int-sap 0) - (int-sap 0))) - (handle (fp) - (cond - ((not (control-stack-pointer-valid-p fp)) - (fail)) - (t - ;; Check the two possible frame pointers. - (let ((lisp-ocfp (sap-ref-sap fp (- (* (1+ ocfp-save-offset) - sb!vm::n-word-bytes)))) - (lisp-ra (sap-ref-sap fp (- (* (1+ return-pc-save-offset) - sb!vm::n-word-bytes)))) - (c-ocfp (sap-ref-sap fp (* 0 sb!vm:n-word-bytes))) - (c-ra (sap-ref-sap fp (* 1 sb!vm:n-word-bytes)))) - (cond ((and (sap> lisp-ocfp fp) - (control-stack-pointer-valid-p lisp-ocfp) - (ra-pointer-valid-p lisp-ra) - (sap> c-ocfp fp) - (control-stack-pointer-valid-p c-ocfp) - (ra-pointer-valid-p c-ra)) - ;; Look forward another step to check their validity. - (let ((lisp-ok (handle lisp-ocfp)) - (c-ok (handle c-ocfp))) - (cond ((and lisp-ok c-ok) - ;; Both still seem valid - choose the lisp frame. - #!+freebsd - (if (sap> lisp-ocfp c-ocfp) - (values t lisp-ra lisp-ocfp) - (values t c-ra c-ocfp)) - #!-freebsd - (values t lisp-ra lisp-ocfp)) - (lisp-ok - ;; The lisp convention is looking good. - (values t lisp-ra lisp-ocfp)) - (c-ok - ;; The C convention is looking good. - (values t c-ra c-ocfp)) - (t - ;; Neither seems right? - (fail))))) - ((and (sap> lisp-ocfp fp) - (control-stack-pointer-valid-p lisp-ocfp) - (ra-pointer-valid-p lisp-ra)) - ;; The lisp convention is looking good. - (values t lisp-ra lisp-ocfp)) - ((and (sap> c-ocfp fp) - (control-stack-pointer-valid-p c-ocfp) - #!-linux (ra-pointer-valid-p c-ra)) - ;; The C convention is looking good. - (values t c-ra c-ocfp)) - (t - (fail)))))))) - (handle fp))) + (let ((ocfp (sap-ref-sap fp (sb!vm::frame-byte-offset ocfp-save-offset))) + (ra (sap-ref-sap fp (sb!vm::frame-byte-offset return-pc-save-offset)))) + (if (and (control-stack-pointer-valid-p fp) + (sap> ocfp fp) + (control-stack-pointer-valid-p ocfp) + (ra-pointer-valid-p ra)) + (values t ra ocfp) + (values nil (int-sap 0) (int-sap 0))))) ) ; #+x86 PROGN @@ -662,8 +615,9 @@ ;;; this function. (defun top-frame () (/noshow0 "entering TOP-FRAME") - (multiple-value-bind (fp pc) (%caller-frame-and-pc) - (compute-calling-frame (descriptor-sap fp) pc nil))) + (compute-calling-frame (descriptor-sap (%caller-frame)) + (%caller-pc) + nil)) ;;; Flush all of the frames above FRAME, and renumber all the frames ;;; below FRAME. @@ -677,7 +631,9 @@ (defun find-saved-frame-down (fp up-frame) (multiple-value-bind (saved-fp saved-pc) (sb!c:find-saved-fp-and-pc fp) (when saved-fp - (compute-calling-frame (descriptor-sap saved-fp) saved-pc up-frame)))) + (compute-calling-frame (descriptor-sap saved-fp) + (descriptor-sap saved-pc) + up-frame)))) ;;; Return the frame immediately below FRAME on the stack; or when ;;; FRAME is the bottom of the stack, return NIL. @@ -743,8 +699,7 @@ (#.ocfp-save-offset (stack-ref pointer stack-slot)) (#.lra-save-offset - (sap-ref-sap pointer (- (* (1+ stack-slot) - sb!vm::n-word-bytes)))))))) + (sap-ref-sap pointer (sb!vm::frame-byte-offset stack-slot))))))) (defun (setf get-context-value) (value frame stack-slot loc) (declare (type compiled-frame frame) (type unsigned-byte stack-slot) @@ -760,8 +715,8 @@ (#.ocfp-save-offset (setf (stack-ref pointer stack-slot) value)) (#.lra-save-offset - (setf (sap-ref-sap pointer (- (* (1+ stack-slot) - sb!vm::n-word-bytes))) value)))))) + (setf (sap-ref-sap pointer (sb!vm::frame-byte-offset stack-slot)) + value)))))) (defun foreign-function-backtrace-name (sap) (let ((name (sap-foreign-symbol sap))) @@ -878,7 +833,9 @@ (declare (type (unsigned-byte 32) n) (optimize (speed 3) (safety 0))) (sb!alien:sap-alien (sb!vm::current-thread-offset-sap - (+ sb!vm::thread-interrupt-contexts-offset n)) + (+ sb!vm::thread-interrupt-contexts-offset + #!-alpha n + #!+alpha (* 2 n))) (* os-context-t))) #!+(or x86 x86-64) @@ -1249,35 +1206,30 @@ register." ;;; Return a DEBUG-FUN that represents debug information for FUN. (defun fun-debug-fun (fun) (declare (type function fun)) - (ecase (widetag-of fun) - (#.sb!vm:closure-header-widetag - (fun-debug-fun (%closure-fun fun))) - (#.sb!vm:funcallable-instance-header-widetag - (fun-debug-fun (funcallable-instance-fun fun))) - (#.sb!vm:simple-fun-header-widetag - (let* ((name (%simple-fun-name fun)) - (component (fun-code-header fun)) - (res (find-if - (lambda (x) - (and (sb!c::compiled-debug-fun-p x) - (eq (sb!c::compiled-debug-fun-name x) name) - (eq (sb!c::compiled-debug-fun-kind x) nil))) - (sb!c::compiled-debug-info-fun-map - (%code-debug-info component))))) - (if res - (make-compiled-debug-fun res component) - ;; KLUDGE: comment from CMU CL: - ;; This used to be the non-interpreted branch, but - ;; William wrote it to return the debug-fun of fun's XEP - ;; instead of fun's debug-fun. The above code does this - ;; more correctly, but it doesn't get or eliminate all - ;; appropriate cases. It mostly works, and probably - ;; works for all named functions anyway. - ;; -- WHN 20000120 - (debug-fun-from-pc component - (* (- (fun-word-offset fun) - (get-header-data component)) - sb!vm:n-word-bytes))))))) + (let ((simple-fun (%fun-fun fun))) + (let* ((name (%simple-fun-name simple-fun)) + (component (fun-code-header simple-fun)) + (res (find-if + (lambda (x) + (and (sb!c::compiled-debug-fun-p x) + (eq (sb!c::compiled-debug-fun-name x) name) + (eq (sb!c::compiled-debug-fun-kind x) nil))) + (sb!c::compiled-debug-info-fun-map + (%code-debug-info component))))) + (if res + (make-compiled-debug-fun res component) + ;; KLUDGE: comment from CMU CL: + ;; This used to be the non-interpreted branch, but + ;; William wrote it to return the debug-fun of fun's XEP + ;; instead of fun's debug-fun. The above code does this + ;; more correctly, but it doesn't get or eliminate all + ;; appropriate cases. It mostly works, and probably + ;; works for all named functions anyway. + ;; -- WHN 20000120 + (debug-fun-from-pc component + (* (- (fun-word-offset simple-fun) + (get-header-data component)) + sb!vm:n-word-bytes)))))) ;;; Return the kind of the function, which is one of :OPTIONAL, ;;; :EXTERNAL, :TOPLEVEL, :CLEANUP, or NIL. @@ -1652,22 +1604,13 @@ register." (without-package-locks (setf (compiled-debug-var-symbol (svref vars i)) (intern (format nil "ARG-~V,'0D" width i) - ;; KLUDGE: It's somewhat nasty to have a bare - ;; package name string here. It would be - ;; nicer to have #.(FIND-PACKAGE "SB!DEBUG") - ;; instead, since then at least it would transform - ;; correctly under package renaming and stuff. - ;; However, genesis can't handle dumped packages.. - ;; -- WHN 20000129 - ;; - ;; FIXME: Maybe this could be fixed by moving the - ;; whole debug-int.lisp file to warm init? (after - ;; which dumping a #.(FIND-PACKAGE ..) expression - ;; would work fine) If this is possible, it would - ;; probably be a good thing, since minimizing the - ;; amount of stuff in cold init is basically good. - (or (find-package "SB-DEBUG") - (find-package "SB!DEBUG")))))))) + ;; The cross-compiler won't dump literal package + ;; references because the target package objects + ;; aren't created until partway through + ;; cold-init. In lieu of adding smarts to the + ;; build framework to handle this, we use an + ;; explicit load-time-value form. + (load-time-value (find-package "SB!DEBUG")))))))) ;;; Parse the packed representation of DEBUG-VARs from ;;; DEBUG-FUN's SB!C::COMPILED-DEBUG-FUN, returning a vector @@ -2049,8 +1992,11 @@ register." (values (make-unprintable-object (format nil "invalid object #x~X" val)) nil)))) -#!-(or x86 x86-64) (defun sub-access-debug-var-slot (fp sc-offset &optional escaped) + ;; NOTE: The long-float support in here is obviously decayed. When + ;; the x86oid and non-x86oid versions of this function were unified, + ;; the behavior of long-floats was preserved, which only served to + ;; highlight its brokenness. (macrolet ((with-escaped-value ((var) &body forms) `(if escaped (let ((,var (sb!vm:context-register @@ -2065,7 +2011,21 @@ register." (sb!c:sc-offset-offset sc-offset) ',format) :invalid-value-for-unescaped-register-storage)) + (escaped-complex-float-value (format offset) + `(if escaped + (complex + (sb!vm:context-float-register + escaped (sb!c:sc-offset-offset sc-offset) ',format) + (sb!vm:context-float-register + escaped (+ (sb!c:sc-offset-offset sc-offset) ,offset) ',format)) + :invalid-value-for-unescaped-register-storage)) (with-nfp ((var) &body body) + ;; x86oids have no separate number stack, so dummy it + ;; up for them. + #!+(or x86 x86-64) + `(let ((,var fp)) + ,@body) + #!-(or x86 x86-64) `(let ((,var (if escaped (sb!sys:int-sap (sb!vm:context-register escaped @@ -2077,12 +2037,22 @@ register." (sb!vm::make-number-stack-pointer (sb!sys:sap-ref-32 fp (* nfp-save-offset sb!vm:n-word-bytes)))))) - ,@body))) + ,@body)) + (stack-frame-offset (data-width offset) + #!+(or x86 x86-64) + `(sb!vm::frame-byte-offset (+ (sb!c:sc-offset-offset sc-offset) + (1- ,data-width) + ,offset)) + #!-(or x86 x86-64) + (declare (ignore data-width)) + #!-(or x86 x86-64) + `(* (+ (sb!c:sc-offset-offset sc-offset) ,offset) + sb!vm:n-word-bytes))) (ecase (sb!c:sc-offset-scn sc-offset) ((#.sb!vm:any-reg-sc-number #.sb!vm:descriptor-reg-sc-number #!+rt #.sb!vm:word-pointer-reg-sc-number) - (sb!sys:without-gcing + (without-gcing (with-escaped-value (val) (make-lisp-obj val nil)))) (#.sb!vm:character-reg-sc-number @@ -2099,8 +2069,10 @@ register." (#.sb!vm:unsigned-reg-sc-number (with-escaped-value (val) val)) + #!-(or x86 x86-64) (#.sb!vm:non-descriptor-reg-sc-number (error "Local non-descriptor register access?")) + #!-(or x86 x86-64) (#.sb!vm:interior-reg-sc-number (error "Local interior register access?")) (#.sb!vm:single-reg-sc-number @@ -2111,187 +2083,57 @@ register." (#.sb!vm:long-reg-sc-number (escaped-float-value long-float)) (#.sb!vm:complex-single-reg-sc-number - (if escaped - (complex - (sb!vm:context-float-register - escaped (sb!c:sc-offset-offset sc-offset) 'single-float) - (sb!vm:context-float-register - escaped (1+ (sb!c:sc-offset-offset sc-offset)) 'single-float)) - :invalid-value-for-unescaped-register-storage)) + (escaped-complex-float-value single-float 1)) (#.sb!vm:complex-double-reg-sc-number - (if escaped - (complex - (sb!vm:context-float-register - escaped (sb!c:sc-offset-offset sc-offset) 'double-float) - (sb!vm:context-float-register - escaped (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 2 #!-sparc 1) - 'double-float)) - :invalid-value-for-unescaped-register-storage)) + (escaped-complex-float-value double-float #!+sparc 2 #!-sparc 1)) #!+long-float (#.sb!vm:complex-long-reg-sc-number - (if escaped - (complex - (sb!vm:context-float-register - escaped (sb!c:sc-offset-offset sc-offset) 'long-float) - (sb!vm:context-float-register - escaped (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4) - 'long-float)) - :invalid-value-for-unescaped-register-storage)) + (escaped-complex-float-value long-float + #!+sparc 4 #!+(or x86 x86-64) 1 + #!-(or sparc x86 x86-64) 0)) (#.sb!vm:single-stack-sc-number (with-nfp (nfp) - (sb!sys:sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes)))) + (sb!sys:sap-ref-single nfp (stack-frame-offset 1 0)))) (#.sb!vm:double-stack-sc-number (with-nfp (nfp) - (sb!sys:sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes)))) + (sb!sys:sap-ref-double nfp (stack-frame-offset 2 0)))) #!+long-float (#.sb!vm:long-stack-sc-number (with-nfp (nfp) - (sb!sys:sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes)))) + (sb!sys:sap-ref-long nfp (stack-frame-offset 3 0)))) (#.sb!vm:complex-single-stack-sc-number (with-nfp (nfp) (complex - (sb!sys:sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes)) - (sb!sys:sap-ref-single nfp (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes))))) + (sb!sys:sap-ref-single nfp (stack-frame-offset 1 0)) + (sb!sys:sap-ref-single nfp (stack-frame-offset 1 1))))) (#.sb!vm:complex-double-stack-sc-number (with-nfp (nfp) (complex - (sb!sys:sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes)) - (sb!sys:sap-ref-double nfp (* (+ (sb!c:sc-offset-offset sc-offset) 2) - sb!vm:n-word-bytes))))) + (sb!sys:sap-ref-double nfp (stack-frame-offset 2 0)) + (sb!sys:sap-ref-double nfp (stack-frame-offset 2 2))))) #!+long-float (#.sb!vm:complex-long-stack-sc-number (with-nfp (nfp) (complex - (sb!sys:sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes)) - (sb!sys:sap-ref-long nfp (* (+ (sb!c:sc-offset-offset sc-offset) - #!+sparc 4) - sb!vm:n-word-bytes))))) + (sb!sys:sap-ref-long nfp (stack-frame-offset 3 0)) + (sb!sys:sap-ref-long nfp + (stack-frame-offset 3 #!+sparc 4 + #!+(or x86 x86-64) 3 + #!-(or sparc x86 x86-64) 0))))) (#.sb!vm:control-stack-sc-number - (sb!kernel:stack-ref fp (sb!c:sc-offset-offset sc-offset))) + (stack-ref fp (sb!c:sc-offset-offset sc-offset))) (#.sb!vm:character-stack-sc-number (with-nfp (nfp) - (code-char (sb!sys:sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes))))) + (code-char (sb!sys:sap-ref-word nfp (stack-frame-offset 1 0))))) (#.sb!vm:unsigned-stack-sc-number (with-nfp (nfp) - (sb!sys:sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes)))) + (sb!sys:sap-ref-word nfp (stack-frame-offset 1 0)))) (#.sb!vm:signed-stack-sc-number (with-nfp (nfp) - (sb!sys:signed-sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes)))) + (sb!sys:signed-sap-ref-word nfp (stack-frame-offset 1 0)))) (#.sb!vm:sap-stack-sc-number (with-nfp (nfp) - (sb!sys:sap-ref-sap nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes))))))) - -#!+(or x86 x86-64) -(defun sub-access-debug-var-slot (fp sc-offset &optional escaped) - (declare (type system-area-pointer fp)) - (macrolet ((with-escaped-value ((var) &body forms) - `(if escaped - (let ((,var (sb!vm:context-register - escaped - (sb!c:sc-offset-offset sc-offset)))) - ,@forms) - :invalid-value-for-unescaped-register-storage)) - (escaped-float-value (format) - `(if escaped - (sb!vm:context-float-register - escaped (sb!c:sc-offset-offset sc-offset) ',format) - :invalid-value-for-unescaped-register-storage)) - (escaped-complex-float-value (format) - `(if escaped - (complex - (sb!vm:context-float-register - escaped (sb!c:sc-offset-offset sc-offset) ',format) - (sb!vm:context-float-register - escaped (1+ (sb!c:sc-offset-offset sc-offset)) ',format)) - :invalid-value-for-unescaped-register-storage))) - (ecase (sb!c:sc-offset-scn sc-offset) - ((#.sb!vm:any-reg-sc-number #.sb!vm:descriptor-reg-sc-number) - (without-gcing - (with-escaped-value (val) - (make-lisp-obj val nil)))) - (#.sb!vm:character-reg-sc-number - (with-escaped-value (val) - (code-char val))) - (#.sb!vm:sap-reg-sc-number - (with-escaped-value (val) - (int-sap val))) - (#.sb!vm:signed-reg-sc-number - (with-escaped-value (val) - (if (logbitp (1- sb!vm:n-word-bits) val) - (logior val (ash -1 sb!vm:n-word-bits)) - val))) - (#.sb!vm:unsigned-reg-sc-number - (with-escaped-value (val) - val)) - (#.sb!vm:single-reg-sc-number - (escaped-float-value single-float)) - (#.sb!vm:double-reg-sc-number - (escaped-float-value double-float)) - #!+long-float - (#.sb!vm:long-reg-sc-number - (escaped-float-value long-float)) - (#.sb!vm:complex-single-reg-sc-number - (escaped-complex-float-value single-float)) - (#.sb!vm:complex-double-reg-sc-number - (escaped-complex-float-value double-float)) - #!+long-float - (#.sb!vm:complex-long-reg-sc-number - (escaped-complex-float-value long-float)) - (#.sb!vm:single-stack-sc-number - (sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes)))) - (#.sb!vm:double-stack-sc-number - (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2) - sb!vm:n-word-bytes)))) - #!+long-float - (#.sb!vm:long-stack-sc-number - (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3) - sb!vm:n-word-bytes)))) - (#.sb!vm:complex-single-stack-sc-number - (complex - (sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes))) - (sap-ref-single fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2) - sb!vm:n-word-bytes))))) - (#.sb!vm:complex-double-stack-sc-number - (complex - (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2) - sb!vm:n-word-bytes))) - (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 4) - sb!vm:n-word-bytes))))) - #!+long-float - (#.sb!vm:complex-long-stack-sc-number - (complex - (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3) - sb!vm:n-word-bytes))) - (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 6) - sb!vm:n-word-bytes))))) - (#.sb!vm:control-stack-sc-number - (stack-ref fp (sb!c:sc-offset-offset sc-offset))) - (#.sb!vm:character-stack-sc-number - (code-char - (sap-ref-word fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes))))) - (#.sb!vm:unsigned-stack-sc-number - (sap-ref-word fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes)))) - (#.sb!vm:signed-stack-sc-number - (signed-sap-ref-word fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes)))) - (#.sb!vm:sap-stack-sc-number - (sap-ref-sap fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes))))))) + (sb!sys:sap-ref-sap nfp (stack-frame-offset 1 0))))))) ;;; This stores value as the value of DEBUG-VAR in FRAME. In the ;;; COMPILED-DEBUG-VAR case, access the current value to determine if @@ -2321,8 +2163,22 @@ register." (compiled-debug-var-sc-offset debug-var)) value)))) -#!-(or x86 x86-64) (defun sub-set-debug-var-slot (fp sc-offset value &optional escaped) + ;; Like sub-access-debug-var-slot, this is the unification of two + ;; divergent copy-pasted functions. The astute reviewer will notice + ;; that long-floats are messed up here as well, that x86oids + ;; apparently don't support accessing float values that are in + ;; registers, and that non-x86oids store the real part of a float + ;; for both the real and imaginary parts of a complex on the stack + ;; (but not in registers, oddly enough). Some research has + ;; indicated that the different forms of THE used for validating the + ;; type of complex float components between x86oid and non-x86oid + ;; systems are only significant in the case of using a non-complex + ;; number as input (as the non-x86oid case effectively converts + ;; non-complex numbers to complex ones and the x86oid case will + ;; error out). That said, the error message from entering a value + ;; of the wrong type will be slightly easier to understand on x86oid + ;; systems. (macrolet ((set-escaped-value (val) `(if escaped (setf (sb!vm:context-register @@ -2338,7 +2194,24 @@ register." ',format) ,val) value)) + (set-escaped-complex-float-value (format offset val) + `(progn + (when escaped + (setf (sb!vm:context-float-register + escaped (sb!c:sc-offset-offset sc-offset) ',format) + (realpart value)) + (setf (sb!vm:context-float-register + escaped (+ (sb!c:sc-offset-offset sc-offset) ,offset) + ',format) + (imagpart value))) + ,val)) (with-nfp ((var) &body body) + ;; x86oids have no separate number stack, so dummy it + ;; up for them. + #!+(or x86 x86-64) + `(let ((,var fp)) + ,@body) + #!-(or x86 x86-64) `(let ((,var (if escaped (int-sap (sb!vm:context-register escaped @@ -2352,7 +2225,17 @@ register." (sap-ref-32 fp (* nfp-save-offset sb!vm:n-word-bytes)))))) - ,@body))) + ,@body)) + (stack-frame-offset (data-width offset) + #!+(or x86 x86-64) + `(sb!vm::frame-byte-offset (+ (sb!c:sc-offset-offset sc-offset) + (1- ,data-width) + ,offset)) + #!-(or x86 x86-64) + (declare (ignore data-width)) + #!-(or x86 x86-64) + `(* (+ (sb!c:sc-offset-offset sc-offset) ,offset) + sb!vm:n-word-bytes))) (ecase (sb!c:sc-offset-scn sc-offset) ((#.sb!vm:any-reg-sc-number #.sb!vm:descriptor-reg-sc-number @@ -2368,214 +2251,108 @@ register." (set-escaped-value (logand value (1- (ash 1 sb!vm:n-word-bits))))) (#.sb!vm:unsigned-reg-sc-number (set-escaped-value value)) + #!-(or x86 x86-64) (#.sb!vm:non-descriptor-reg-sc-number (error "Local non-descriptor register access?")) + #!-(or x86 x86-64) (#.sb!vm:interior-reg-sc-number (error "Local interior register access?")) (#.sb!vm:single-reg-sc-number + #!-(or x86 x86-64) ;; don't have escaped floats. (set-escaped-float-value single-float value)) (#.sb!vm:double-reg-sc-number + #!-(or x86 x86-64) ;; don't have escaped floats -- still in npx? (set-escaped-float-value double-float value)) #!+long-float (#.sb!vm:long-reg-sc-number + #!-(or x86 x86-64) ;; don't have escaped floats -- still in npx? (set-escaped-float-value long-float value)) + #!-(or x86 x86-64) (#.sb!vm:complex-single-reg-sc-number - (when escaped - (setf (sb!vm:context-float-register escaped - (sb!c:sc-offset-offset sc-offset) - 'single-float) - (realpart value)) - (setf (sb!vm:context-float-register - escaped (1+ (sb!c:sc-offset-offset sc-offset)) - 'single-float) - (imagpart value))) - value) + (set-escaped-complex-float-value single-float 1 value)) + #!-(or x86 x86-64) (#.sb!vm:complex-double-reg-sc-number - (when escaped - (setf (sb!vm:context-float-register - escaped (sb!c:sc-offset-offset sc-offset) 'double-float) - (realpart value)) - (setf (sb!vm:context-float-register - escaped - (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 2 #!-sparc 1) - 'double-float) - (imagpart value))) - value) - #!+long-float + (set-escaped-complex-float-value double-float #!+sparc 2 #!-sparc 1 value)) + #!+(and long-float (not (or x86 x86-64))) (#.sb!vm:complex-long-reg-sc-number - (when escaped - (setf (sb!vm:context-float-register - escaped (sb!c:sc-offset-offset sc-offset) 'long-float) - (realpart value)) - (setf (sb!vm:context-float-register - escaped - (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4) - 'long-float) - (imagpart value))) - value) + (set-escaped-complex-float-value long-float #!+sparc 4 #!-sparc 0 value)) (#.sb!vm:single-stack-sc-number (with-nfp (nfp) - (setf (sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes)) + (setf (sap-ref-single nfp (stack-frame-offset 1 0)) (the single-float value)))) (#.sb!vm:double-stack-sc-number (with-nfp (nfp) - (setf (sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes)) + (setf (sap-ref-double nfp (stack-frame-offset 2 0)) (the double-float value)))) #!+long-float (#.sb!vm:long-stack-sc-number (with-nfp (nfp) - (setf (sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes)) + (setf (sap-ref-long nfp (stack-frame-offset 3 0)) (the long-float value)))) (#.sb!vm:complex-single-stack-sc-number (with-nfp (nfp) (setf (sap-ref-single - nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes)) + nfp (stack-frame-offset 1 0)) + #!+(or x86 x86-64) + (realpart (the (complex single-float) value)) + #!-(or x86 x86-64) (the single-float (realpart value))) (setf (sap-ref-single - nfp (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes)) + nfp (stack-frame-offset 1 1)) + #!+(or x86 x86-64) + (imagpart (the (complex single-float) value)) + #!-(or x86 x86-64) (the single-float (realpart value))))) (#.sb!vm:complex-double-stack-sc-number (with-nfp (nfp) (setf (sap-ref-double - nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes)) + nfp (stack-frame-offset 2 0)) + #!+(or x86 x86-64) + (realpart (the (complex double-float) value)) + #!-(or x86 x86-64) (the double-float (realpart value))) (setf (sap-ref-double - nfp (* (+ (sb!c:sc-offset-offset sc-offset) 2) - sb!vm:n-word-bytes)) + nfp (stack-frame-offset 2 2)) + #!+(or x86 x86-64) + (imagpart (the (complex double-float) value)) + #!-(or x86 x86-64) (the double-float (realpart value))))) #!+long-float (#.sb!vm:complex-long-stack-sc-number (with-nfp (nfp) (setf (sap-ref-long - nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes)) + nfp (stack-frame-offset 3 0)) + #!+(or x86 x86-64) + (realpart (the (complex long-float) value)) + #!-(or x86 x86-64) (the long-float (realpart value))) (setf (sap-ref-long - nfp (* (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4) - sb!vm:n-word-bytes)) + nfp (stack-frame-offset 3 #!+sparc 4 + #!+(or x86 x86-64) 3 + #!-(or sparc x86 x86-64) 0)) + #!+(or x86 x86-64) + (imagpart (the (complex long-float) value)) + #!-(or x86 x86-64) (the long-float (realpart value))))) (#.sb!vm:control-stack-sc-number (setf (stack-ref fp (sb!c:sc-offset-offset sc-offset)) value)) (#.sb!vm:character-stack-sc-number (with-nfp (nfp) - (setf (sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes)) + (setf (sap-ref-word nfp (stack-frame-offset 1 0)) (char-code (the character value))))) (#.sb!vm:unsigned-stack-sc-number (with-nfp (nfp) - (setf (sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes)) + (setf (sap-ref-word nfp (stack-frame-offset 1 0)) (the (unsigned-byte 32) value)))) (#.sb!vm:signed-stack-sc-number (with-nfp (nfp) - (setf (signed-sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes)) + (setf (signed-sap-ref-word nfp (stack-frame-offset 1 0)) (the (signed-byte 32) value)))) (#.sb!vm:sap-stack-sc-number (with-nfp (nfp) - (setf (sap-ref-sap nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes)) + (setf (sap-ref-sap nfp (stack-frame-offset 1 0)) (the system-area-pointer value))))))) -#!+(or x86 x86-64) -(defun sub-set-debug-var-slot (fp sc-offset value &optional escaped) - (macrolet ((set-escaped-value (val) - `(if escaped - (setf (sb!vm:context-register - escaped - (sb!c:sc-offset-offset sc-offset)) - ,val) - value))) - (ecase (sb!c:sc-offset-scn sc-offset) - ((#.sb!vm:any-reg-sc-number #.sb!vm:descriptor-reg-sc-number) - (without-gcing - (set-escaped-value - (get-lisp-obj-address value)))) - (#.sb!vm:character-reg-sc-number - (set-escaped-value (char-code value))) - (#.sb!vm:sap-reg-sc-number - (set-escaped-value (sap-int value))) - (#.sb!vm:signed-reg-sc-number - (set-escaped-value (logand value (1- (ash 1 sb!vm:n-word-bits))))) - (#.sb!vm:unsigned-reg-sc-number - (set-escaped-value value)) - (#.sb!vm:single-reg-sc-number - #+nil ;; don't have escaped floats. - (set-escaped-float-value single-float value)) - (#.sb!vm:double-reg-sc-number - #+nil ;; don't have escaped floats -- still in npx? - (set-escaped-float-value double-float value)) - #!+long-float - (#.sb!vm:long-reg-sc-number - #+nil ;; don't have escaped floats -- still in npx? - (set-escaped-float-value long-float value)) - (#.sb!vm:single-stack-sc-number - (setf (sap-ref-single - fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes))) - (the single-float value))) - (#.sb!vm:double-stack-sc-number - (setf (sap-ref-double - fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2) - sb!vm:n-word-bytes))) - (the double-float value))) - #!+long-float - (#.sb!vm:long-stack-sc-number - (setf (sap-ref-long - fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3) - sb!vm:n-word-bytes))) - (the long-float value))) - (#.sb!vm:complex-single-stack-sc-number - (setf (sap-ref-single - fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes))) - (realpart (the (complex single-float) value))) - (setf (sap-ref-single - fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2) - sb!vm:n-word-bytes))) - (imagpart (the (complex single-float) value)))) - (#.sb!vm:complex-double-stack-sc-number - (setf (sap-ref-double - fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2) - sb!vm:n-word-bytes))) - (realpart (the (complex double-float) value))) - (setf (sap-ref-double - fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 4) - sb!vm:n-word-bytes))) - (imagpart (the (complex double-float) value)))) - #!+long-float - (#.sb!vm:complex-long-stack-sc-number - (setf (sap-ref-long - fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3) - sb!vm:n-word-bytes))) - (realpart (the (complex long-float) value))) - (setf (sap-ref-long - fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 6) - sb!vm:n-word-bytes))) - (imagpart (the (complex long-float) value)))) - (#.sb!vm:control-stack-sc-number - (setf (stack-ref fp (sb!c:sc-offset-offset sc-offset)) value)) - (#.sb!vm:character-stack-sc-number - (setf (sap-ref-word fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes))) - (char-code (the character value)))) - (#.sb!vm:unsigned-stack-sc-number - (setf (sap-ref-word fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes))) - (the sb!vm:word value))) - (#.sb!vm:signed-stack-sc-number - (setf (signed-sap-ref-word - fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes))) - (the (signed-byte #.sb!vm:n-word-bits) value))) - (#.sb!vm:sap-stack-sc-number - (setf (sap-ref-sap fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes))) - (the system-area-pointer value)))))) - ;;; The method for setting and accessing COMPILED-DEBUG-VAR values use ;;; this to determine if the value stored is the actual value or an ;;; indirection cell. @@ -2774,6 +2551,15 @@ register." (debug-signal 'frame-fun-mismatch :code-location loc :form form :frame frame)) (funcall res frame)))))) + +;;; EVAL-IN-FRAME + +(defun eval-in-frame (frame form) + (declare (type frame frame)) + #!+sb-doc + "Evaluate FORM in the lexical context of FRAME's current code location, + returning the results of the evaluation." + (funcall (preprocess-for-eval form (frame-code-location frame)) frame)) ;;;; breakpoints