X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=e8a188d31f00afa16e6134c281c9ba5306664a7f;hb=b14a61c6af3e3005c94e633e727177346240066e;hp=80b08ce1ce82678e3e1975635ef596dfab30dbb1;hpb=f68d0f59fa6f9c448b3a147b5940937af03f940a;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 80b08ce..e8a188d 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -205,12 +205,13 @@ (defstruct (compiled-debug-var (:include debug-var) (:constructor make-compiled-debug-var - (symbol id alive-p sc-offset save-sc-offset)) + (symbol id alive-p sc-offset save-sc-offset info)) (:copier nil)) ;; storage class and offset (unexported) (sc-offset nil :type sb!c:sc-offset) ;; storage class and offset when saved somewhere - (save-sc-offset nil :type (or sb!c:sc-offset null))) + (save-sc-offset nil :type (or sb!c:sc-offset null)) + (info nil)) ;;;; frames @@ -298,17 +299,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-system-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 +325,6 @@ (%function nil))) (:copier nil)) %name) - -(defvar *ir1-lambda-debug-fun* (make-hash-table :test 'eq)) ;;;; DEBUG-BLOCKs @@ -356,8 +359,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 +480,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))) @@ -510,12 +511,12 @@ (defun %set-stack-ref (s n value) (%set-stack-ref s n value)) (defun fun-code-header (fun) (fun-code-header fun)) (defun lra-code-header (lra) (lra-code-header lra)) -(defun make-lisp-obj (value) (make-lisp-obj value)) +(defun %make-lisp-obj (value) (%make-lisp-obj value)) (defun get-lisp-obj-address (thing) (get-lisp-obj-address thing)) (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,16 +527,22 @@ #!-stack-grows-downward-not-upward (and (sap< x (current-sp)) (sap<= control-stack-start x) - (zerop (logand (sap-int x) #b11))) + (or (not aligned) (zerop (logand (sap-int x) + (1- (ash 1 sb!vm:word-shift)))))) #!+stack-grows-downward-not-upward (and (sap>= x (current-sp)) (sap> control-stack-end x) - (zerop (logand (sap-int x) #b11))))) + (or (not aligned) (zerop (logand (sap-int x) + (1- (ash 1 sb!vm:word-shift)))))))) (declaim (inline component-ptr-from-pc)) (sb!alien:define-alien-routine component-ptr-from-pc (system-area-pointer) (pc system-area-pointer)) +(declaim (inline valid-lisp-pointer-p)) +(sb!alien:define-alien-routine valid-lisp-pointer-p sb!alien:int + (pointer system-area-pointer)) + (declaim (inline component-from-component-ptr)) (defun component-from-component-ptr (component-ptr) (declare (type system-area-pointer component-ptr)) @@ -554,7 +561,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) @@ -590,61 +597,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 @@ -658,8 +618,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. @@ -670,6 +631,15 @@ ((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!alien-internals:find-saved-fp-and-pc fp) + (when saved-fp + (compute-calling-frame (descriptor-sap saved-fp) + (descriptor-sap saved-pc) + up-frame + t)))) + ;;; Return the frame immediately below FRAME on the stack; or when ;;; FRAME is the bottom of the stack, return NIL. (defun frame-down (frame) @@ -699,8 +669,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 @@ -733,8 +704,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) @@ -750,8 +720,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))) @@ -776,7 +746,9 @@ #!-(or x86 x86-64) (defun compute-calling-frame (caller lra up-frame) (declare (type system-area-pointer caller)) + (/noshow0 "entering COMPUTE-CALLING-FRAME") (when (control-stack-pointer-valid-p caller) + (/noshow0 "in WHEN") (multiple-value-bind (code pc-offset escaped) (if lra (multiple-value-bind (word-offset code) @@ -812,6 +784,7 @@ "bogus stack frame")) (t (debug-fun-from-pc code pc-offset))))) + (/noshow0 "returning MAKE-COMPILED-FRAME from COMPUTE-CALLING-FRAME") (make-compiled-frame caller up-frame d-fun (code-location-from-pc d-fun pc-offset escaped) @@ -819,13 +792,14 @@ escaped)))))) #!+(or x86 x86-64) -(defun compute-calling-frame (caller ra up-frame) +(defun compute-calling-frame (caller ra up-frame &optional savedp) (declare (type system-area-pointer caller ra)) (/noshow0 "entering COMPUTE-CALLING-FRAME") (when (control-stack-pointer-valid-p caller) (/noshow0 "in WHEN") ;; First check for an escaped frame. - (multiple-value-bind (code pc-offset escaped) (find-escaped-frame caller) + (multiple-value-bind (code pc-offset escaped off-stack) + (find-escaped-frame caller) (/noshow0 "at COND") (cond (code ;; If it's escaped it may be a function end breakpoint trap. @@ -859,109 +833,145 @@ (code-location-from-pc d-fun pc-offset escaped) (if up-frame (1+ (frame-number up-frame)) 0) - escaped))))) + ;; If we have an interrupt-context that's not on + ;; our stack at all, and we're computing the + ;; from from a saved FP, we're probably looking + ;; at an interrupted syscall. + (or escaped (and savedp off-stack))))))) (defun nth-interrupt-context (n) (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))) +;;;; Perform the lookup which FOREIGN-SYMBOL-ADDRESS would do if the +;;;; linkage table were disabled, i.e. always return the actual symbol +;;;; address, not the linkage table trampoline, even if the symbol would +;;;; ordinarily go through the linkage table. Important when +;;;; SB-DYNAMIC-CORE is enabled and our caller assumes `name' to be a +;;;; "static" symbol; a concept which doesn't exist in such builds. +(defun true-foreign-symbol-address (name) + #!+linkage-table ;we have dlsym -- let's use it. + (find-dynamic-foreign-symbol-address name) + #!-linkage-table ;possibly no dlsym, but hence no indirection anyway. + (foreign-symbol-address)) + +;;;; See above. +(defun true-foreign-symbol-sap (name) + (int-sap (true-foreign-symbol-address name))) + #!+(or x86 x86-64) (defun find-escaped-frame (frame-pointer) (declare (type system-area-pointer frame-pointer)) (/noshow0 "entering FIND-ESCAPED-FRAME") (dotimes (index *free-interrupt-context-index* (values nil 0 nil)) - (/noshow0 "at head of WITH-ALIEN") - (let ((context (nth-interrupt-context index))) - (/noshow0 "got CONTEXT") - (when (= (sap-int frame-pointer) - (sb!vm:context-register context sb!vm::cfp-offset)) - (without-gcing - (/noshow0 "in WITHOUT-GCING") - (let* ((component-ptr (component-ptr-from-pc - (sb!vm:context-pc context))) - (code (unless (sap= component-ptr (int-sap #x0)) - (component-from-component-ptr component-ptr)))) - (/noshow0 "got CODE") - (when (null code) - (return (values code 0 context))) - (let* ((code-header-len (* (get-header-data code) - sb!vm:n-word-bytes)) - (pc-offset + (let* ((context (nth-interrupt-context index)) + (cfp (int-sap (sb!vm:context-register context sb!vm::cfp-offset)))) + (/noshow0 "got CONTEXT") + (unless (control-stack-pointer-valid-p cfp) + (return (values nil nil nil t))) + (when (sap= frame-pointer cfp) + (without-gcing + (/noshow0 "in WITHOUT-GCING") + (let* ((component-ptr (component-ptr-from-pc + (sb!vm:context-pc context))) + (code (unless (sap= component-ptr (int-sap #x0)) + (component-from-component-ptr component-ptr)))) + (/noshow0 "got CODE") + (when (null code) + ;; KLUDGE: Detect undefined functions by a range-check + ;; against the trampoline address and the following + ;; function in the runtime. + (if (< (true-foreign-symbol-address "undefined_tramp") + (sap-int (sb!vm:context-pc context)) + (true-foreign-symbol-address #!+x86 "closure_tramp" + #!+x86-64 "alloc_tramp")) + (return (values :undefined-function 0 context)) + (return (values code 0 context)))) + (let* ((code-header-len (* (get-header-data code) + sb!vm:n-word-bytes)) + (pc-offset (- (sap-int (sb!vm:context-pc context)) (- (get-lisp-obj-address code) sb!vm:other-pointer-lowtag) code-header-len))) - (/noshow "got PC-OFFSET") - (unless (<= 0 pc-offset - (* (code-header-ref code sb!vm:code-code-size-slot) - sb!vm:n-word-bytes)) - ;; We were in an assembly routine. Therefore, use the - ;; LRA as the pc. - ;; - ;; FIXME: Should this be WARN or ERROR or what? - (format t "** pc-offset ~S not in code obj ~S?~%" - pc-offset code)) - (/noshow0 "returning from FIND-ESCAPED-FRAME") - (return - (values code pc-offset context))))))))) + (/noshow "got PC-OFFSET") + (unless (<= 0 pc-offset + (* (code-header-ref code sb!vm:code-code-size-slot) + sb!vm:n-word-bytes)) + ;; We were in an assembly routine. Therefore, use the + ;; LRA as the pc. + ;; + ;; FIXME: Should this be WARN or ERROR or what? + (format t "** pc-offset ~S not in code obj ~S?~%" + pc-offset code)) + (/noshow0 "returning from FIND-ESCAPED-FRAME") + (return + (values code pc-offset context))))))))) #!-(or x86 x86-64) (defun find-escaped-frame (frame-pointer) (declare (type system-area-pointer frame-pointer)) + (/noshow0 "entering FIND-ESCAPED-FRAME") (dotimes (index *free-interrupt-context-index* (values nil 0 nil)) (let ((scp (nth-interrupt-context index))) + (/noshow0 "got SCP") (when (= (sap-int frame-pointer) (sb!vm:context-register scp sb!vm::cfp-offset)) (without-gcing - (let ((code (code-object-from-bits - (sb!vm:context-register scp sb!vm::code-offset)))) - (when (symbolp code) - (return (values code 0 scp))) - (let* ((code-header-len (* (get-header-data code) - sb!vm:n-word-bytes)) - (pc-offset - (- (sap-int (sb!vm:context-pc scp)) - (- (get-lisp-obj-address code) - sb!vm:other-pointer-lowtag) - code-header-len))) - (let ((code-size (* (code-header-ref code - sb!vm:code-code-size-slot) - sb!vm:n-word-bytes))) - (unless (<= 0 pc-offset code-size) - ;; We were in an assembly routine. - (multiple-value-bind (new-pc-offset computed-return) - (find-pc-from-assembly-fun code scp) - (setf pc-offset new-pc-offset) - (unless (<= 0 pc-offset code-size) - (cerror - "Set PC-OFFSET to zero and continue backtrace." - 'bug - :format-control - "~@" - :format-arguments - (list pc-offset - (sap-int (sb!vm:context-pc scp)) - code - (%code-entry-points code) - (sb!vm:context-register scp sb!vm::lra-offset) - computed-return)) - ;; We failed to pinpoint where PC is, but set - ;; pc-offset to 0 to keep the backtrace from - ;; exploding. - (setf pc-offset 0))))) - (return - (if (eq (%code-debug-info code) :bogus-lra) - (let ((real-lra (code-header-ref code - real-lra-slot))) - (values (lra-code-header real-lra) - (get-header-data real-lra) - nil)) - (values code pc-offset scp)))))))))) + :format-arguments + (list pc-offset + (sap-int (sb!vm:context-pc scp)) + code + (%code-entry-points code) + (sb!vm:context-register scp sb!vm::lra-offset) + computed-return)) + ;; We failed to pinpoint where PC is, but set + ;; pc-offset to 0 to keep the backtrace from + ;; exploding. + (setf pc-offset 0))))) + (/noshow0 "returning from FIND-ESCAPED-FRAME") + (return + (if (eq (%code-debug-info code) :bogus-lra) + (let ((real-lra (code-header-ref code + real-lra-slot))) + (values (lra-code-header real-lra) + (get-header-data real-lra) + nil)) + (values code pc-offset scp)))))))))) #!-(or x86 x86-64) (defun find-pc-from-assembly-fun (code scp) @@ -982,7 +992,7 @@ register." #!-(or x86 x86-64) (defun code-object-from-bits (bits) (declare (type (unsigned-byte 32) bits)) - (let ((object (make-lisp-obj bits))) + (let ((object (make-lisp-obj bits nil))) (if (functionp object) (or (fun-code-header object) :undefined-function) @@ -1230,35 +1240,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. @@ -1438,10 +1443,13 @@ register." args (incf i) vars)) res)) (sb!c::more-arg - ;; Just ignore the fact that the next two args are - ;; the &MORE arg context and count, and act like they - ;; are regular arguments. - nil) + ;; The next two args are the &MORE arg context and count. + (push (list :more + (compiled-debug-fun-lambda-list-var + args (incf i) vars) + (compiled-debug-fun-lambda-list-var + args (incf i) vars)) + res)) (t ;; &KEY arg (push (list :keyword @@ -1633,22 +1641,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 @@ -1671,6 +1670,8 @@ register." (let* ((flags (geti)) (minimal (logtest sb!c::compiled-debug-var-minimal-p flags)) (deleted (logtest sb!c::compiled-debug-var-deleted-p flags)) + (more-context-p (logtest sb!c::compiled-debug-var-more-context-p flags)) + (more-count-p (logtest sb!c::compiled-debug-var-more-count-p flags)) (live (logtest sb!c::compiled-debug-var-environment-live flags)) (save (logtest sb!c::compiled-debug-var-save-loc-p flags)) @@ -1685,7 +1686,9 @@ register." id live sc-offset - save-sc-offset) + save-sc-offset + (cond (more-context-p :more-context) + (more-count-p :more-count))) buffer))))))) ;;;; CODE-LOCATIONs @@ -1990,12 +1993,24 @@ register." (compiled-debug-var-sc-offset debug-var)))))) ;;; a helper function for working with possibly-invalid values: -;;; Do (MAKE-LISP-OBJ VAL) only if the value looks valid. +;;; Do (%MAKE-LISP-OBJ VAL) only if the value looks valid. ;;; ;;; (Such values can arise in registers on machines with conservative ;;; GC, and might also arise in debug variable locations when ;;; those variables are invalid.) -(defun make-valid-lisp-obj (val) +;;; +;;; NOTE: this function is not GC-safe in the slightest when creating +;;; a pointer to an object in dynamic space. If a GC occurs between +;;; the start of the call to VALID-LISP-POINTER-P and the end of +;;; %MAKE-LISP-OBJ then the object could move before the boxed pointer +;;; is constructed. This can happen on CHENEYGC if an asynchronous +;;; interrupt occurs within the window. This can happen on GENCGC +;;; under the same circumstances, but is more likely due to all GENCGC +;;; platforms supporting threaded operation. This is somewhat +;;; mitigated on x86oids due to the conservative stack and interrupt +;;; context "scavenging" on such platforms, but there still may be a +;;; vulnerable window. +(defun make-lisp-obj (val &optional (errorp t)) (if (or ;; fixnum (zerop (logand val sb!vm:fixnum-tag-mask)) @@ -2007,24 +2022,29 @@ register." (= (logand val #xff) sb!vm:character-widetag)) ; char tag ;; unbound marker (= val sb!vm:unbound-marker-widetag) + ;; undefined_tramp doesn't validate properly as a pointer, and + ;; the actual value can vary by backend (x86oids need not + ;; apply) + #!+(or alpha hppa mips ppc) + (= val (+ (- (foreign-symbol-address "undefined_tramp") + (* sb!vm:n-word-bytes sb!vm:simple-fun-code-offset)) + sb!vm:fun-pointer-lowtag)) + #!+sparc + (= val (foreign-symbol-address "undefined_tramp")) ;; pointer - (and (logbitp 0 val) - ;; Check that the pointer is valid. XXX Could do a better - ;; job. FIXME: e.g. by calling out to an is_valid_pointer - ;; routine in the C runtime support code - (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)))))) - (make-lisp-obj val) - :invalid-object)) + (not (zerop (valid-lisp-pointer-p (int-sap val))))) + (values (%make-lisp-obj val) t) + (if errorp + (error "~S is not a valid argument to ~S" + val 'make-lisp-obj) + (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 @@ -2039,7 +2059,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 @@ -2051,14 +2085,24 @@ 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 - (with-escaped-value (val) (sb!kernel:make-lisp-obj val)))) - + (without-gcing + (with-escaped-value (val) + (make-lisp-obj val nil)))) (#.sb!vm:character-reg-sc-number (with-escaped-value (val) (code-char val))) @@ -2073,8 +2117,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 @@ -2085,187 +2131,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-valid-lisp-obj val)))) - (#.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 @@ -2295,8 +2211,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 @@ -2312,7 +2242,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 @@ -2326,7 +2273,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 @@ -2342,214 +2299,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. @@ -2568,12 +2419,10 @@ register." ;;; :unknown. Once we've called CODE-LOCATION-UNKNOWN-P, we know the ;;; live-set information has been cached in the code-location. (defun debug-var-validity (debug-var basic-code-location) - (etypecase debug-var - (compiled-debug-var - (compiled-debug-var-validity debug-var basic-code-location)) - ;; (There used to be more cases back before sbcl-0.7.0, when - ;; we did special tricks to debug the IR1 interpreter.) - )) + (compiled-debug-var-validity debug-var basic-code-location)) + +(defun debug-var-info (debug-var) + (compiled-debug-var-info debug-var)) ;;; This is the method for DEBUG-VAR-VALIDITY for COMPILED-DEBUG-VARs. ;;; For safety, make sure basic-code-location is what we think. @@ -2623,13 +2472,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. @@ -2638,32 +2480,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 @@ -2700,6 +2542,70 @@ register." (nconc (subseq form 0 n) (cons res (nthcdr (1+ n) form)))))))) (frob form path context)))) + +;;; Given a code location, return the associated form-number +;;; translations and the actual top level form. +(defun get-toplevel-form (location) + (let ((d-source (code-location-debug-source location))) + (let* ((offset (code-location-toplevel-form-offset location)) + (res + (cond ((debug-source-form d-source) + (debug-source-form d-source)) + ((debug-source-namestring d-source) + (get-file-toplevel-form location)) + (t (bug "Don't know how to use a DEBUG-SOURCE without ~ + a namestring or a form."))))) + (values (form-number-translations res offset) res)))) + +;;; To suppress the read-time evaluation #. macro during source read, +;;; *READTABLE* is modified. +;;; +;;; FIXME: This breaks #+#.(cl:if ...) Maybe we need a SAFE-READ-EVAL, which +;;; this code can use for side- effect free #. calls? +;;; +;;; FIXME: This also knows nothing of custom readtables. The assumption +;;; is that the current readtable is a decent approximation for what +;;; we want, but that's lossy. +(defun safe-readtable () + (let ((rt (copy-readtable))) + (set-dispatch-macro-character + #\# #\. (lambda (stream sub-char &rest rest) + (declare (ignore rest sub-char)) + (let ((token (read stream t nil t))) + (format nil "#.~S" token))) + rt) + rt)) + +;;; Locate the source file (if it still exists) and grab the top level +;;; form. If the file is modified, we use the top level form offset +;;; instead of the recorded character offset. +(defun get-file-toplevel-form (location) + (let* ((d-source (code-location-debug-source location)) + (tlf-offset (code-location-toplevel-form-offset location)) + (local-tlf-offset (- tlf-offset + (debug-source-root-number d-source))) + (char-offset + (aref (or (sb!di:debug-source-start-positions d-source) + (error "no start positions map")) + local-tlf-offset)) + (namestring (debug-source-namestring d-source))) + ;; FIXME: External format? + (with-open-file (f namestring :if-does-not-exist nil) + (unless f + (error "The source file no longer exists:~% ~A" namestring)) + (format *debug-io* "~%; file: ~A~%" namestring) + (let ((*readtable* (safe-readtable))) + (cond ((eql (debug-source-created d-source) (file-write-date f)) + (file-position f char-offset)) + (t + (format *debug-io* + "~%; File has been modified since compilation:~%; ~A~@ + ; Using form offset instead of character position.~%" + namestring) + (let ((*read-suppress* t)) + (loop repeat local-tlf-offset + do (read f))))) + (read f))))) ;;;; PREPROCESS-FOR-EVAL @@ -2715,7 +2621,9 @@ register." (defun preprocess-for-eval (form loc) (declare (type code-location loc)) (let ((n-frame (gensym)) - (fun (code-location-debug-fun loc))) + (fun (code-location-debug-fun loc)) + (more-context nil) + (more-count nil)) (unless (debug-var-info-available fun) (debug-signal 'no-debug-vars :debug-fun fun)) (sb!int:collect ((binds) @@ -2723,17 +2631,33 @@ register." (do-debug-fun-vars (var fun) (let ((validity (debug-var-validity var loc))) (unless (eq validity :invalid) + (case (debug-var-info var) + (:more-context + (setf more-context var)) + (:more-count + (setf more-count var))) (let* ((sym (debug-var-symbol var)) (found (assoc sym (binds)))) (if found (setf (second found) :ambiguous) (binds (list sym validity var))))))) + (when (and more-context more-count) + (let ((more (assoc 'sb!debug::more (binds)))) + (if more + (setf (second more) :ambiguous) + (binds (list 'sb!debug::more :more more-context more-count))))) (dolist (bind (binds)) (let ((name (first bind)) (var (third bind))) (ecase (second bind) (:valid (specs `(,name (debug-var-value ',var ,n-frame)))) + (:more + (let ((count-var (fourth bind))) + (specs `(,name (multiple-value-list + (sb!c:%more-arg-values (debug-var-value ',var ,n-frame) + 0 + (debug-var-value ',count-var ,n-frame))))))) (:unknown (specs `(,name (debug-signal 'invalid-value :debug-var ',var @@ -2755,6 +2679,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 @@ -2852,7 +2785,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 @@ -3086,14 +3019,14 @@ register." ;;; which GC is disabled, so that Lisp doesn't move objects around ;;; that C is pointing to. (sb!alien:define-alien-routine "breakpoint_install" sb!alien:unsigned-int - (code-obj sb!alien:unsigned-long) + (code-obj sb!alien:unsigned) (pc-offset sb!alien:int)) ;;; This removes the break instruction and replaces the original ;;; instruction. You must call this in a context in which GC is disabled ;;; so Lisp doesn't move objects around that C is pointing to. (sb!alien:define-alien-routine "breakpoint_remove" sb!alien:void - (code-obj sb!alien:unsigned-long) + (code-obj sb!alien:unsigned) (pc-offset sb!alien:int) (old-inst sb!alien:unsigned-int)) @@ -3104,7 +3037,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. @@ -3126,6 +3059,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*) @@ -3211,7 +3146,11 @@ register." (sb!alien:sap-alien signal-context (* os-context-t)))) (cfp (int-sap (sb!vm:context-register scp sb!vm::cfp-offset)))) (compute-calling-frame cfp - (sb!vm:context-pc scp) + ;; KLUDGE: This argument is ignored on + ;; x86oids in this scenario, but is + ;; declared to be a SAP. + #!+(or x86 x86-64) (sb!vm:context-pc scp) + #!-(or x86 x86-64) nil nil))) (defun handle-fun-end-breakpoint (offset component context) @@ -3229,6 +3168,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 @@ -3278,13 +3219,12 @@ register." (without-gcing ;; These are really code labels, not variables: but this way we get ;; their addresses. - (let* ((src-start (foreign-symbol-sap "fun_end_breakpoint_guts")) - (src-end (foreign-symbol-sap "fun_end_breakpoint_end")) - (trap-loc (foreign-symbol-sap "fun_end_breakpoint_trap")) + (let* ((src-start (true-foreign-symbol-sap "fun_end_breakpoint_guts")) + (src-end (true-foreign-symbol-sap "fun_end_breakpoint_end")) + (trap-loc (true-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) @@ -3307,11 +3247,10 @@ register." #!-(or x86 x86-64) (let ((new-lra (make-lisp-obj (+ (sap-int dst-start) sb!vm:other-pointer-lowtag)))) - (set-header-data - new-lra - (logandc2 (+ sb!vm:code-constants-offset bogus-lra-constants 1) - 1)) - (sb!vm:sanctify-for-execution code-object) + ;; We used to set the header value of the LRA here to the + ;; offset from the enclosing component to the LRA header, but + ;; MAKE-LISP-OBJ actually checks the value before we get a + ;; chance to set it, so it's now done in arch-assem.S. (values new-lra code-object (sap- trap-loc src-start)))))) ;;;; miscellaneous @@ -3351,8 +3290,8 @@ register." ;;; or replace the function that's about to be called with a wrapper ;;; which will signal the condition. -(defun handle-single-step-trap (context-sap kind callee-register-offset) - (let ((context (sb!alien:sap-alien context-sap (* os-context-t)))) +(defun handle-single-step-trap (kind callee-register-offset) + (let ((context (nth-interrupt-context (1- *free-interrupt-context-index*)))) ;; The following calls must get tail-call eliminated for ;; *STEP-FRAME* to get set correctly on non-x86. (if (= kind single-step-before-trap) @@ -3367,9 +3306,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 @@ -3396,7 +3335,7 @@ register." (defun handle-single-step-around-trap (context callee-register-offset) ;; Fetch the function / fdefn we're about to call from the ;; appropriate register. - (let* ((callee (sb!kernel::make-lisp-obj + (let* ((callee (make-lisp-obj (context-register context callee-register-offset))) (step-info (single-step-info-from-context context))) ;; If there was not enough debug information available, there's no