X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=63b899b61a1c68a5613572b0a8a68992817a560a;hb=2dbee6e782b54f8780933790d61a24cdb67b8d04;hp=c714d28cbedbeb675603c49a44bcca32bf172361;hpb=abfd7c2c9d4882e05a2e9953baf87f8e02a6a1af;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index c714d28..63b899b 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -298,17 +298,21 @@ ;;; 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 -;;; *COMPILED-DEBUG-FUNS*. If there already is a -;;; COMPILED-DEBUG-FUN, then this returns it from -;;; *COMPILED-DEBUG-FUNS*. +;;; Make a COMPILED-DEBUG-FUN for a SB!C::COMPILER-DEBUG-FUN and its +;;; component. This maps the latter to the former in +;;; *COMPILED-DEBUG-FUNS*. If there already is a COMPILED-DEBUG-FUN, +;;; then this returns it from *COMPILED-DEBUG-FUNS*. +;;; +;;; FIXME: It seems this table can potentially grow without bounds, +;;; and retains roots to functions that might otherwise be collected. (defun make-compiled-debug-fun (compiler-debug-fun component) - (or (gethash compiler-debug-fun *compiled-debug-funs*) - (setf (gethash compiler-debug-fun *compiled-debug-funs*) - (%make-compiled-debug-fun compiler-debug-fun component)))) + (let ((table *compiled-debug-funs*)) + (with-locked-hash-table (table) + (or (gethash compiler-debug-fun table) + (setf (gethash compiler-debug-fun table) + (%make-compiled-debug-fun compiler-debug-fun component)))))) (defstruct (bogus-debug-fun (:include debug-fun) @@ -320,8 +324,6 @@ (%function nil))) (:copier nil)) %name) - -(defvar *ir1-lambda-debug-fun* (make-hash-table :test 'eq)) ;;;; DEBUG-BLOCKs @@ -356,8 +358,6 @@ (:copier nil)) ;; code-location information for the block (code-locations nil :type simple-vector)) - -(defvar *ir1-block-debug-block* (make-hash-table :test 'eq)) ;;;; breakpoints @@ -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. @@ -674,6 +628,13 @@ ((not (frame-p frame))) (setf (frame-number frame) number))) +(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) + (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. (defun frame-down (frame) @@ -703,8 +664,9 @@ (when (control-stack-pointer-valid-p fp) #!+(or x86 x86-64) (multiple-value-bind (ok ra ofp) (x86-call-context fp) - (and ok - (compute-calling-frame ofp ra frame))) + (if ok + (compute-calling-frame ofp ra frame) + (find-saved-frame-down fp frame))) #!-(or x86 x86-64) (compute-calling-frame #!-alpha @@ -737,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) @@ -754,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))) @@ -872,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) @@ -1243,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. @@ -1646,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 @@ -2023,19 +1972,19 @@ register." ;; pointer #!+(or x86 x86-64) (not (zerop (valid-lisp-pointer-p (int-sap val)))) - ;; FIXME: There is no fundamental reason not to use the above - ;; function on other platforms as well, but I didn't have - ;; others available while doing this. --NS 2007-06-21 - #!-(or x86 x86-64) - (and (logbitp 0 val) - (or (< sb!vm:read-only-space-start val - (* sb!vm:*read-only-space-free-pointer* - sb!vm:n-word-bytes)) - (< sb!vm:static-space-start val - (* sb!vm:*static-space-free-pointer* - sb!vm:n-word-bytes)) - (< (current-dynamic-space-start) val - (sap-int (dynamic-space-free-pointer)))))) + ;; FIXME: There is no fundamental reason not to use the above + ;; function on other platforms as well, but I didn't have + ;; others available while doing this. --NS 2007-06-21 + #!-(or x86 x86-64) + (and (logbitp 0 val) + (or (< sb!vm:read-only-space-start val + (* sb!vm:*read-only-space-free-pointer* + sb!vm:n-word-bytes)) + (< sb!vm:static-space-start val + (* sb!vm:*static-space-free-pointer* + sb!vm:n-word-bytes)) + (< (current-dynamic-space-start) val + (sap-int (dynamic-space-free-pointer)))))) (values (%make-lisp-obj val) t) (if errorp (error "~S is not a valid argument to ~S" @@ -2043,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 @@ -2059,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 @@ -2071,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 @@ -2093,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 @@ -2105,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 @@ -2315,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 @@ -2332,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 @@ -2346,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 @@ -2362,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. @@ -2643,13 +2426,6 @@ register." ;;; Given the DEFUN, 3 gets you the LET, 1 gets you the bindings, 0 ;;; gets the first binding, and 1 gets the AREF form. -;;; temporary buffer used to build form-number => source-path translation in -;;; FORM-NUMBER-TRANSLATIONS -(defvar *form-number-temp* (make-array 10 :fill-pointer 0 :adjustable t)) - -;;; table used to detect CAR circularities in FORM-NUMBER-TRANSLATIONS -(defvar *form-number-circularity-table* (make-hash-table :test 'eq)) - ;;; This returns a table mapping form numbers to source-paths. A ;;; source-path indicates a descent into the TOPLEVEL-FORM form, ;;; going directly to the subform corressponding to the form number. @@ -2658,32 +2434,32 @@ register." ;;; NODE-SOURCE-PATH; that is, the first element is the form number and ;;; the last is the TOPLEVEL-FORM number. (defun form-number-translations (form tlf-number) - (clrhash *form-number-circularity-table*) - (setf (fill-pointer *form-number-temp*) 0) - (sub-translate-form-numbers form (list tlf-number)) - (coerce *form-number-temp* 'simple-vector)) -(defun sub-translate-form-numbers (form path) - (unless (gethash form *form-number-circularity-table*) - (setf (gethash form *form-number-circularity-table*) t) - (vector-push-extend (cons (fill-pointer *form-number-temp*) path) - *form-number-temp*) - (let ((pos 0) - (subform form) - (trail form)) - (declare (fixnum pos)) - (macrolet ((frob () - '(progn - (when (atom subform) (return)) - (let ((fm (car subform))) - (when (consp fm) - (sub-translate-form-numbers fm (cons pos path))) - (incf pos)) - (setq subform (cdr subform)) - (when (eq subform trail) (return))))) - (loop - (frob) - (frob) - (setq trail (cdr trail))))))) + (let ((seen nil) + (translations (make-array 12 :fill-pointer 0 :adjustable t))) + (labels ((translate1 (form path) + (unless (member form seen) + (push form seen) + (vector-push-extend (cons (fill-pointer translations) path) + translations) + (let ((pos 0) + (subform form) + (trail form)) + (declare (fixnum pos)) + (macrolet ((frob () + '(progn + (when (atom subform) (return)) + (let ((fm (car subform))) + (when (consp fm) + (translate1 fm (cons pos path))) + (incf pos)) + (setq subform (cdr subform)) + (when (eq subform trail) (return))))) + (loop + (frob) + (frob) + (setq trail (cdr trail)))))))) + (translate1 form (list tlf-number))) + (coerce translations 'simple-vector))) ;;; FORM is a top level form, and path is a source-path into it. This ;;; returns the form indicated by the source-path. Context is the @@ -2775,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 @@ -2872,7 +2657,7 @@ register." ;;; This maps bogus-lra-components to cookies, so that ;;; HANDLE-FUN-END-BREAKPOINT can find the appropriate cookie for the ;;; breakpoint hook. -(defvar *fun-end-cookies* (make-hash-table :test 'eq)) +(defvar *fun-end-cookies* (make-hash-table :test 'eq :synchronized t)) ;;; This returns a hook function for the start helper breakpoint ;;; associated with a :FUN-END breakpoint. The returned function @@ -3124,7 +2909,7 @@ register." ;;;; breakpoint handlers (layer between C and exported interface) ;;; This maps components to a mapping of offsets to BREAKPOINT-DATAs. -(defvar *component-breakpoint-offsets* (make-hash-table :test 'eq)) +(defvar *component-breakpoint-offsets* (make-hash-table :test 'eq :synchronized t)) ;;; This returns the BREAKPOINT-DATA object associated with component cross ;;; offset. If none exists, this makes one, installs it, and returns it. @@ -3146,6 +2931,8 @@ register." ;;; We use this when there are no longer any active breakpoints ;;; corresponding to DATA. (defun delete-breakpoint-data (data) + ;; Again, this looks brittle. Is there no danger of being interrupted + ;; here? (let* ((component (breakpoint-data-component data)) (offsets (delete (breakpoint-data-offset data) (gethash component *component-breakpoint-offsets*) @@ -3249,6 +3036,8 @@ register." ;;; [old C code] or HANDLE-FUN-END-BREAKPOINT calls this directly ;;; [new C code]. (defun handle-fun-end-breakpoint-aux (breakpoints data signal-context) + ;; FIXME: This looks brittle: what if we are interrupted somewhere + ;; here? ...or do we have interrupts disabled here? (delete-breakpoint-data data) (let* ((scp (locally @@ -3303,8 +3092,7 @@ register." (trap-loc (foreign-symbol-sap "fun_end_breakpoint_trap")) (length (sap- src-end src-start)) (code-object - (%primitive sb!c:allocate-code-object (1+ bogus-lra-constants) - length)) + (sb!c:allocate-code-object (1+ bogus-lra-constants) length)) (dst-start (code-instructions code-object))) (declare (type system-area-pointer src-start src-end dst-start trap-loc) @@ -3387,9 +3175,9 @@ register." ;; sense in signaling the condition. (when step-info (let ((*step-frame* - #+(or x86 x86-64) + #!+(or x86 x86-64) (signal-context-frame (sb!alien::alien-sap context)) - #-(or x86 x86-64) + #!-(or x86 x86-64) ;; KLUDGE: Use the first non-foreign frame as the ;; *STACK-TOP-HINT*. Getting the frame from the signal ;; context as on x86 would be cleaner, but