X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=d8f4d729c37a58a0606223c2dd73662adce07b40;hb=97106bb159710a2e816bf4e72669d6a3818d08aa;hp=192ebda10f9acac1d0d8eea6a3a5f33182e12e1c;hpb=9514c25e89aad10784c6d04fea4595d8c8ae68cc;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 192ebda..d8f4d72 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -41,17 +41,6 @@ "All DEBUG-CONDITIONs inherit from this type. These are serious conditions that must be handled, but they are not programmer errors.")) -(define-condition no-debug-info (debug-condition) - ((code-component :reader no-debug-info-code-component - :initarg :code-component)) - #!+sb-doc - (:documentation "There is no usable debugging information available.") - (:report (lambda (condition stream) - (fresh-line stream) - (format stream - "no debug information available for ~S~%" - (no-debug-info-code-component condition))))) - (define-condition no-debug-fun-returns (debug-condition) ((debug-fun :reader no-debug-fun-returns-debug-fun :initarg :debug-fun)) @@ -64,8 +53,8 @@ (no-debug-fun-returns-debug-fun condition)))) (format stream "~&Cannot return values from ~:[frame~;~:*~S~] since ~ - the debug information lacks details about returning ~ - values here." + the debug information lacks details about returning ~ + values here." fun))))) (define-condition no-debug-blocks (debug-condition) @@ -105,13 +94,13 @@ (invalid-value-debug-var condition) (invalid-value-frame condition))))) -(define-condition ambiguous-variable-name (debug-condition) - ((name :reader ambiguous-variable-name-name :initarg :name) - (frame :reader ambiguous-variable-name-frame :initarg :frame)) +(define-condition ambiguous-var-name (debug-condition) + ((name :reader ambiguous-var-name-name :initarg :name) + (frame :reader ambiguous-var-name-frame :initarg :frame)) (:report (lambda (condition stream) (format stream "~&~S names more than one valid variable in ~S." - (ambiguous-variable-name-name condition) - (ambiguous-variable-name-frame condition))))) + (ambiguous-var-name-name condition) + (ambiguous-var-name-frame condition))))) ;;;; errors and DEBUG-SIGNAL @@ -195,7 +184,7 @@ (defstruct (debug-var (:constructor nil) (:copier nil)) ;; the name of the variable - (symbol (required-argument) :type symbol) + (symbol (missing-arg) :type symbol) ;; a unique integer identification relative to other variables with the same ;; symbol (id 0 :type index) @@ -204,7 +193,7 @@ (def!method print-object ((debug-var debug-var) stream) (print-unreadable-object (debug-var stream :type t :identity t) (format stream - "~S ~D" + "~S ~W" (debug-var-symbol debug-var) (debug-var-id debug-var)))) @@ -382,7 +371,7 @@ ;; This is the byte offset into the component. (offset nil :type index) ;; The original instruction replaced by the breakpoint. - (instruction nil :type (or null (unsigned-byte 32))) + (instruction nil :type (or null sb!vm::word)) ;; A list of user breakpoints at this location. (breakpoints nil :type list)) (def!method print-object ((obj breakpoint-data) str) @@ -394,15 +383,15 @@ (breakpoint-data-offset obj)))) (defstruct (breakpoint (:constructor %make-breakpoint - (hook-function what kind %info)) + (hook-fun what kind %info)) (:copier nil)) ;; This is the function invoked when execution encounters the ;; breakpoint. It takes a frame, the breakpoint, and optionally a - ;; list of values. Values are supplied for :FUN-END breakpoints - ;; as values to return for the function containing the breakpoint. - ;; :FUN-END breakpoint hook-functions also take a cookie - ;; argument. See COOKIE-FUN slot. - (hook-function nil :type function) + ;; list of values. Values are supplied for :FUN-END breakpoints as + ;; values to return for the function containing the breakpoint. + ;; :FUN-END breakpoint hook functions also take a cookie argument. + ;; See the COOKIE-FUN slot. + (hook-fun (required-arg) :type function) ;; CODE-LOCATION or DEBUG-FUN (what nil :type (or code-location debug-fun)) ;; :CODE-LOCATION, :FUN-START, or :FUN-END for that kind @@ -431,7 +420,7 @@ ;; for identifying :FUN-END breakpoint executions. That is, if ;; there is one :FUN-END breakpoint, but there may be multiple ;; pending calls of its function on the stack. This function takes - ;; the cookie, and the hook-function takes the cookie too. + ;; the cookie, and the hook function takes the cookie too. (cookie-fun nil :type (or null function)) ;; This slot users can set with whatever information they find useful. %info) @@ -454,9 +443,9 @@ ;; the DEBUG-FUN containing this CODE-LOCATION (debug-fun nil :type debug-fun) ;; This is initially :UNSURE. Upon first trying to access an - ;; :unparsed slot, if the data is unavailable, then this becomes t, + ;; :UNPARSED slot, if the data is unavailable, then this becomes T, ;; and the code-location is unknown. If the data is available, this - ;; becomes nil, a known location. We can't use a separate type + ;; becomes NIL, a known location. We can't use a separate type ;; code-location for this since we must return code-locations before ;; we can tell whether they're known or unknown. For example, when ;; parsing the stack, we don't want to unpack all the variables and @@ -466,10 +455,10 @@ ;; out and just find it in the blocks cache in DEBUG-FUN. (%debug-block :unparsed :type (or debug-block (member :unparsed))) ;; This is the number of forms processed by the compiler or loader - ;; before the top-level form containing this code-location. + ;; before the top level form containing this code-location. (%tlf-offset :unparsed :type (or index (member :unparsed))) ;; This is the depth-first number of the node that begins - ;; code-location within its top-level form. + ;; code-location within its top level form. (%form-number :unparsed :type (or index (member :unparsed)))) (def!method print-object ((obj code-location) str) (print-unreadable-object (obj str :type t) @@ -495,19 +484,19 @@ ;;;; DEBUG-SOURCEs -;;; Return the number of top-level forms processed by the compiler +;;; Return the number of top level forms processed by the compiler ;;; before compiling this source. If this source is uncompiled, this ;;; is zero. This may be zero even if the source is compiled since the ;;; first form in the first file compiled in one compilation, for ;;; example, must have a root number of zero -- the compiler saw no -;;; other top-level forms before it. +;;; other top level forms before it. (defun debug-source-root-number (debug-source) (sb!c::debug-source-source-root debug-source)) ;;;; frames ;;; This is used in FIND-ESCAPED-FRAME and with the bogus components -;;; and LRAs used for :FUN-END breakpoints. When a components +;;; and LRAs used for :FUN-END breakpoints. When a component's ;;; debug-info slot is :BOGUS-LRA, then the REAL-LRA-SLOT contains the ;;; real component to continue executing, as opposed to the bogus ;;; component which appeared in some frame's LRA location. @@ -524,32 +513,35 @@ (defun get-lisp-obj-address (thing) (get-lisp-obj-address thing)) (defun fun-word-offset (fun) (fun-word-offset fun)) -#!-sb-fluid (declaim (inline cstack-pointer-valid-p)) -(defun cstack-pointer-valid-p (x) +#!-sb-fluid (declaim (inline control-stack-pointer-valid-p)) +(defun control-stack-pointer-valid-p (x) (declare (type system-area-pointer x)) - #!-x86 ; stack grows toward high address values - (and (sap< x (current-sp)) - (sap<= (int-sap control-stack-start) - x) - (zerop (logand (sap-int x) #b11))) - #!+x86 ; stack grows toward low address values - (and (sap>= x (current-sp)) - (sap> (int-sap control-stack-end) x) - (zerop (logand (sap-int x) #b11)))) - -#!+x86 -(sb!alien:def-alien-routine component-ptr-from-pc (system-area-pointer) + (let* (#!-stack-grows-downward-not-upward + (control-stack-start + (descriptor-sap *control-stack-start*)) + #!+stack-grows-downward-not-upward + (control-stack-end + (descriptor-sap *control-stack-end*))) + #!-stack-grows-downward-not-upward + (and (sap< x (current-sp)) + (sap<= control-stack-start x) + (zerop (logand (sap-int x) #b11))) + #!+stack-grows-downward-not-upward + (and (sap>= x (current-sp)) + (sap> control-stack-end x) + (zerop (logand (sap-int x) #b11))))) + +(sb!alien:define-alien-routine component-ptr-from-pc (system-area-pointer) (pc system-area-pointer)) -#!+x86 (defun component-from-component-ptr (component-ptr) (declare (type system-area-pointer component-ptr)) (make-lisp-obj (logior (sap-int component-ptr) sb!vm:other-pointer-lowtag))) -;;;; X86 support +;;;; (OR X86 X86-64) support -#!+x86 +#!+(or x86 x86-64) (progn (defun compute-lra-data-from-pc (pc) @@ -575,10 +567,13 @@ (defun ra-pointer-valid-p (ra) (declare (type system-area-pointer ra)) (and - ;; Not the first page which is unmapped. + ;; not the first page (which is unmapped) + ;; + ;; FIXME: Where is this documented? Is it really true of every CPU + ;; architecture? Is it even necessarily true in current SBCL? (>= (sap-int ra) 4096) - ;; Not a Lisp stack pointer. - (not (cstack-pointer-valid-p ra)))) + ;; not a Lisp stack pointer + (not (control-stack-pointer-valid-p ra)))) ;;; Try to find a valid previous stack. This is complex on the x86 as ;;; it can jump between C and Lisp frames. To help find a valid frame @@ -592,21 +587,24 @@ (defun x86-call-context (fp &key (depth 0)) (declare (type system-area-pointer fp) (fixnum depth)) - ;;(format t "*CC ~S ~S~%" fp depth) +;; (format t "*CC ~S ~S~%" fp depth) (cond - ((not (cstack-pointer-valid-p fp)) + ((not (control-stack-pointer-valid-p fp)) #+nil (format t "debug invalid fp ~S~%" fp) nil) (t ;; Check the two possible frame pointers. - (let ((lisp-ocfp (sap-ref-sap fp (- (* (1+ ocfp-save-offset) 4)))) + (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) - 4)))) + 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) (cstack-pointer-valid-p lisp-ocfp) + #+nil (format t " lisp-ocfp=~S~% lisp-ra=~S~% c-ocfp=~S~% c-ra=~S~%" + lisp-ocfp lisp-ra c-ocfp c-ra) + (cond ((and (sap> lisp-ocfp fp) (control-stack-pointer-valid-p lisp-ocfp) (ra-pointer-valid-p lisp-ra) - (sap> c-ocfp fp) (cstack-pointer-valid-p c-ocfp) + (sap> c-ocfp fp) (control-stack-pointer-valid-p c-ocfp) (ra-pointer-valid-p c-ra)) #+nil (format t "*C Both valid ~S ~S ~S ~S~%" @@ -621,11 +619,11 @@ (format t "debug: both still valid ~S ~S ~S ~S~%" lisp-ocfp lisp-ra c-ocfp c-ra)) - #+freebsd + #!+freebsd (if (sap> lisp-ocfp c-ocfp) (values lisp-ra lisp-ocfp) (values c-ra c-ocfp)) - #-freebsd + #!-freebsd (values lisp-ra lisp-ocfp)) (lisp-path-fp ;; The lisp convention is looking good. @@ -640,12 +638,12 @@ #+nil (format t "debug: no valid2 fp found ~S ~S~%" lisp-ocfp c-ocfp) nil)))) - ((and (sap> lisp-ocfp fp) (cstack-pointer-valid-p lisp-ocfp) + ((and (sap> lisp-ocfp fp) (control-stack-pointer-valid-p lisp-ocfp) (ra-pointer-valid-p lisp-ra)) ;; The lisp convention is looking good. #+nil (format t "*C lisp-ocfp ~S ~S~%" lisp-ocfp lisp-ra) (values lisp-ra lisp-ocfp)) - ((and (sap> c-ocfp fp) (cstack-pointer-valid-p c-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. #+nil (format t "*C c-ocfp ~S ~S~%" c-ocfp c-ra) @@ -666,7 +664,7 @@ ;;; Return the top frame of the control stack as it was before calling ;;; this function. (defun top-frame () - (/show0 "entering TOP-FRAME") + (/noshow0 "entering TOP-FRAME") (multiple-value-bind (fp pc) (%caller-frame-and-pc) (compute-calling-frame (descriptor-sap fp) pc nil))) @@ -682,13 +680,13 @@ ;;; Return the frame immediately below FRAME on the stack; or when ;;; FRAME is the bottom of the stack, return NIL. (defun frame-down (frame) - (/show0 "entering FRAME-DOWN") + (/noshow0 "entering FRAME-DOWN") ;; We have to access the old-fp and return-pc out of frame and pass ;; them to COMPUTE-CALLING-FRAME. (let ((down (frame-%down frame))) (if (eq down :unparsed) (let ((debug-fun (frame-debug-fun frame))) - (/show0 "in DOWN :UNPARSED case") + (/noshow0 "in DOWN :UNPARSED case") (setf (frame-%down frame) (etypecase debug-fun (compiled-debug-fun @@ -705,11 +703,11 @@ frame))) (bogus-debug-fun (let ((fp (frame-pointer frame))) - (when (cstack-pointer-valid-p fp) - #!+x86 + (when (control-stack-pointer-valid-p fp) + #!+(or x86 x86-64) (multiple-value-bind (ra ofp) (x86-call-context fp) - (compute-calling-frame ofp ra frame)) - #!-x86 + (and ra (compute-calling-frame ofp ra frame))) + #!-(or x86 x86-64) (compute-calling-frame #!-alpha (sap-ref-sap fp (* ocfp-save-offset @@ -727,7 +725,7 @@ ;;; Get the old FP or return PC out of FRAME. STACK-SLOT is the ;;; standard save location offset on the stack. LOC is the saved ;;; SC-OFFSET describing the main location. -#!-x86 +#!-(or x86 x86-64) (defun get-context-value (frame stack-slot loc) (declare (type compiled-frame frame) (type unsigned-byte stack-slot) (type sb!c:sc-offset loc)) @@ -736,7 +734,7 @@ (if escaped (sub-access-debug-var-slot pointer loc escaped) (stack-ref pointer stack-slot)))) -#!+x86 +#!+(or x86 x86-64) (defun get-context-value (frame stack-slot loc) (declare (type compiled-frame frame) (type unsigned-byte stack-slot) (type sb!c:sc-offset loc)) @@ -748,9 +746,10 @@ (#.ocfp-save-offset (stack-ref pointer stack-slot)) (#.lra-save-offset - (sap-ref-sap pointer (- (* (1+ stack-slot) 4)))))))) + (sap-ref-sap pointer (- (* (1+ stack-slot) + sb!vm::n-word-bytes)))))))) -#!-x86 +#!-(or x86 x86-64) (defun (setf get-context-value) (value frame stack-slot loc) (declare (type compiled-frame frame) (type unsigned-byte stack-slot) (type sb!c:sc-offset loc)) @@ -760,7 +759,7 @@ (sub-set-debug-var-slot pointer loc value escaped) (setf (stack-ref pointer stack-slot) value)))) -#!+x86 +#!+(or x86 x86-64) (defun (setf get-context-value) (value frame stack-slot loc) (declare (type compiled-frame frame) (type unsigned-byte stack-slot) (type sb!c:sc-offset loc)) @@ -772,13 +771,20 @@ (#.ocfp-save-offset (setf (stack-ref pointer stack-slot) value)) (#.lra-save-offset - (setf (sap-ref-sap pointer (- (* (1+ stack-slot) 4))) value)))))) + (setf (sap-ref-sap pointer (- (* (1+ stack-slot) + sb!vm::n-word-bytes))) value)))))) + +(defun foreign-function-backtrace-name (sap) + (let ((name (foreign-symbol-in-address sap))) + (if name + (format nil "foreign function: ~A" name) + (format nil "foreign function: #x~X" (sap-int sap))))) ;;; This returns a frame for the one existing in time immediately ;;; prior to the frame referenced by current-fp. This is current-fp's ;;; caller or the next frame down the control stack. If there is no -;;; down frame, this returns nil for the bottom of the stack. Up-frame -;;; is the up link for the resulting frame object, and it is nil when +;;; down frame, this returns NIL for the bottom of the stack. UP-FRAME +;;; is the up link for the resulting frame object, and it is null when ;;; we call this to get the top of the stack. ;;; ;;; The current frame contains the pointer to the temporally previous @@ -788,10 +794,10 @@ ;;; Note: Sometimes LRA is actually a fixnum. This happens when lisp ;;; calls into C. In this case, the code object is stored on the stack ;;; after the LRA, and the LRA is the word offset. -#!-x86 +#!-(or x86 x86-64) (defun compute-calling-frame (caller lra up-frame) (declare (type system-area-pointer caller)) - (when (cstack-pointer-valid-p caller) + (when (control-stack-pointer-valid-p caller) (multiple-value-bind (code pc-offset escaped) (if lra (multiple-value-bind (word-offset code) @@ -820,7 +826,8 @@ "undefined function")) (:foreign-function (make-bogus-debug-fun - "foreign function call land")) + (foreign-function-backtrace-name + (int-sap (get-lisp-obj-address lra))))) ((nil) (make-bogus-debug-fun "bogus stack frame")) @@ -831,18 +838,16 @@ escaped) (if up-frame (1+ (frame-number up-frame)) 0) escaped)))))) - -#!+x86 +#!+(or x86 x86-64) (defun compute-calling-frame (caller ra up-frame) (declare (type system-area-pointer caller ra)) - (/show0 "entering COMPUTE-CALLING-FRAME") - (when (cstack-pointer-valid-p caller) - (/show0 "in WHEN") + (/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) - (/show0 "at COND") + (/noshow0 "at COND") (cond (code - (/show0 "in CODE clause") ;; If it's escaped it may be a function end breakpoint trap. (when (and (code-component-p code) (eq (%code-debug-info code) :bogus-lra)) @@ -851,54 +856,55 @@ code (1+ real-lra-slot))) (setq code (code-header-ref code real-lra-slot)) (aver code))) - (t - (/show0 "in T clause") - ;; not escaped + ((not escaped) (multiple-value-setq (pc-offset code) (compute-lra-data-from-pc ra)) (unless code (setf code :foreign-function - pc-offset 0 - escaped nil)))) - + pc-offset 0)))) (let ((d-fun (case code (:undefined-function (make-bogus-debug-fun "undefined function")) (:foreign-function (make-bogus-debug-fun - "foreign function call land")) + (foreign-function-backtrace-name ra))) ((nil) (make-bogus-debug-fun "bogus stack frame")) (t (debug-fun-from-pc code pc-offset))))) - (/show0 "returning MAKE-COMPILED-FRAME from COMPUTE-CALLING-FRAME") + (/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) (if up-frame (1+ (frame-number up-frame)) 0) escaped))))) -#!+x86 +(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)) + (* os-context-t))) + +#!+(or x86 x86-64) (defun find-escaped-frame (frame-pointer) (declare (type system-area-pointer frame-pointer)) - (/show0 "entering FIND-ESCAPED-FRAME") + (/noshow0 "entering FIND-ESCAPED-FRAME") (dotimes (index *free-interrupt-context-index* (values nil 0 nil)) - (sb!alien:with-alien - ((lisp-interrupt-contexts (array (* os-context-t) nil) :extern)) - (/show0 "at head of WITH-ALIEN") - (let ((context (sb!alien:deref lisp-interrupt-contexts index))) - (/show0 "got CONTEXT") + (/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 - (/show0 "in 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)))) - (/show0 "got CODE") + (/noshow0 "got CODE") (when (null code) (return (values code 0 context))) (let* ((code-header-len (* (get-header-data code) @@ -908,7 +914,7 @@ (- (get-lisp-obj-address code) sb!vm:other-pointer-lowtag) code-header-len))) - (/show "got PC-OFFSET") + (/noshow "got PC-OFFSET") (unless (<= 0 pc-offset (* (code-header-ref code sb!vm:code-code-size-slot) sb!vm:n-word-bytes)) @@ -918,53 +924,82 @@ ;; FIXME: Should this be WARN or ERROR or what? (format t "** pc-offset ~S not in code obj ~S?~%" pc-offset code)) - (/show0 "returning from FIND-ESCAPED-FRAME") + (/noshow0 "returning from FIND-ESCAPED-FRAME") (return - (values code pc-offset context)))))))))) + (values code pc-offset context))))))))) -#!-x86 +#!-(or x86 x86-64) (defun find-escaped-frame (frame-pointer) (declare (type system-area-pointer frame-pointer)) (dotimes (index *free-interrupt-context-index* (values nil 0 nil)) - (sb!alien:with-alien - ((lisp-interrupt-contexts (array (* os-context-t) nil) :extern)) - (let ((scp (sb!alien:deref lisp-interrupt-contexts index))) - (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))) - ;; Check to see whether we were executing in a branch - ;; delay slot. - #!+(or pmax sgi) ; pmax only (and broken anyway) - (when (logbitp 31 (sb!alien:slot scp '%mips::sc-cause)) - (incf pc-offset sb!vm:n-word-bytes)) - (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. - (setf pc-offset - (- (sb!vm:context-register scp sb!vm::lra-offset) - (get-lisp-obj-address code) - code-header-len))) - (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))))))))))) + (let ((scp (nth-interrupt-context index))) + (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))) + ;; Check to see whether we were executing in a branch + ;; delay slot. + #!+(or pmax sgi) ; pmax only (and broken anyway) + (when (logbitp 31 (sb!alien:slot scp '%mips::sc-cause)) + (incf pc-offset sb!vm:n-word-bytes)) + (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)))))))))) + +#!-(or x86 x86-64) +(defun find-pc-from-assembly-fun (code scp) + "Finds the PC for the return from an assembly routine properly. +For some architectures (such as PPC) this will not be the $LRA +register." + (let ((return-machine-address (sb!vm::return-machine-address scp)) + (code-header-len (* (get-header-data code) sb!vm:n-word-bytes))) + (values (- return-machine-address + (- (get-lisp-obj-address code) + sb!vm:other-pointer-lowtag) + code-header-len) + return-machine-address))) ;;; Find the code object corresponding to the object represented by ;;; bits and return it. We assume bogus functions correspond to the @@ -975,32 +1010,35 @@ (if (functionp object) (or (fun-code-header object) :undefined-function) - (let ((lowtag (get-lowtag object))) + (let ((lowtag (lowtag-of object))) (if (= lowtag sb!vm:other-pointer-lowtag) - (let ((type (get-type object))) - (cond ((= type sb!vm:code-header-widetag) + (let ((widetag (widetag-of object))) + (cond ((= widetag sb!vm:code-header-widetag) object) - ((= type sb!vm:return-pc-header-widetag) + ((= widetag sb!vm:return-pc-header-widetag) (lra-code-header object)) (t nil)))))))) ;;;; frame utilities -;;; This returns a COMPILED-DEBUG-FUN for code and pc. We fetch the +;;; This returns a COMPILED-DEBUG-FUN for COMPONENT and PC. We fetch the ;;; SB!C::DEBUG-INFO and run down its FUN-MAP to get a -;;; SB!C::COMPILED-DEBUG-FUN from the pc. The result only needs to -;;; reference the component, for function constants, and the +;;; SB!C::COMPILED-DEBUG-FUN from the PC. The result only needs to +;;; reference the COMPONENT, for function constants, and the ;;; SB!C::COMPILED-DEBUG-FUN. (defun debug-fun-from-pc (component pc) (let ((info (%code-debug-info component))) (cond - ((not info) - (debug-signal 'no-debug-info :code-component component)) + ((not info) + ;; FIXME: It seems that most of these (at least on x86) are + ;; actually assembler routines, and could be named by looking + ;; at the sb-fasl:*assembler-routines*. + (make-bogus-debug-fun "no debug information for frame")) ((eq info :bogus-lra) (make-bogus-debug-fun "function end breakpoint")) (t - (let* ((fun-map (get-debug-info-fun-map info)) + (let* ((fun-map (sb!c::compiled-debug-info-fun-map info)) (len (length fun-map))) (declare (type simple-vector fun-map)) (if (= len 1) @@ -1043,62 +1081,63 @@ ;;; CODE-LOCATIONs at which execution would continue with frame as the ;;; top frame if someone threw to the corresponding tag. (defun frame-catches (frame) - (let ((catch (descriptor-sap *current-catch-block*)) - (res nil) + (let ((catch (descriptor-sap sb!vm:*current-catch-block*)) + (reversed-result nil) (fp (frame-pointer frame))) - (loop - (when (zerop (sap-int catch)) (return (nreverse res))) - (when (sap= fp - #!-alpha - (sap-ref-sap catch - (* sb!vm:catch-block-current-cont-slot - sb!vm:n-word-bytes)) - #!+alpha - (:int-sap - (sap-ref-32 catch - (* sb!vm:catch-block-current-cont-slot - sb!vm:n-word-bytes)))) - (let* (#!-x86 - (lra (stack-ref catch sb!vm:catch-block-entry-pc-slot)) - #!+x86 - (ra (sap-ref-sap - catch (* sb!vm:catch-block-entry-pc-slot - sb!vm:n-word-bytes))) - #!-x86 - (component - (stack-ref catch sb!vm:catch-block-current-code-slot)) - #!+x86 - (component (component-from-component-ptr - (component-ptr-from-pc ra))) - (offset - #!-x86 - (* (- (1+ (get-header-data lra)) - (get-header-data component)) - sb!vm:n-word-bytes) - #!+x86 - (- (sap-int ra) - (- (get-lisp-obj-address component) - sb!vm:other-pointer-lowtag) - (* (get-header-data component) sb!vm:n-word-bytes)))) - (push (cons #!-x86 - (stack-ref catch sb!vm:catch-block-tag-slot) - #!+x86 - (make-lisp-obj - (sap-ref-32 catch (* sb!vm:catch-block-tag-slot - sb!vm:n-word-bytes))) - (make-compiled-code-location - offset (frame-debug-fun frame))) - res))) - (setf catch - #!-alpha - (sap-ref-sap catch - (* sb!vm:catch-block-previous-catch-slot - sb!vm:n-word-bytes)) - #!+alpha - (:int-sap - (sap-ref-32 catch - (* sb!vm:catch-block-previous-catch-slot - sb!vm:n-word-bytes))))))) + (loop until (zerop (sap-int catch)) + finally (return (nreverse reversed-result)) + do + (when (sap= fp + #!-alpha + (sap-ref-sap catch + (* sb!vm:catch-block-current-cont-slot + sb!vm:n-word-bytes)) + #!+alpha + (int-sap + (sap-ref-32 catch + (* sb!vm:catch-block-current-cont-slot + sb!vm:n-word-bytes)))) + (let* (#!-(or x86 x86-64) + (lra (stack-ref catch sb!vm:catch-block-entry-pc-slot)) + #!+(or x86 x86-64) + (ra (sap-ref-sap + catch (* sb!vm:catch-block-entry-pc-slot + sb!vm:n-word-bytes))) + #!-(or x86 x86-64) + (component + (stack-ref catch sb!vm:catch-block-current-code-slot)) + #!+(or x86 x86-64) + (component (component-from-component-ptr + (component-ptr-from-pc ra))) + (offset + #!-(or x86 x86-64) + (* (- (1+ (get-header-data lra)) + (get-header-data component)) + sb!vm:n-word-bytes) + #!+(or x86 x86-64) + (- (sap-int ra) + (- (get-lisp-obj-address component) + sb!vm:other-pointer-lowtag) + (* (get-header-data component) sb!vm:n-word-bytes)))) + (push (cons #!-(or x86 x86-64) + (stack-ref catch sb!vm:catch-block-tag-slot) + #!+(or x86 x86-64) + (make-lisp-obj + (sap-ref-word catch (* sb!vm:catch-block-tag-slot + sb!vm:n-word-bytes))) + (make-compiled-code-location + offset (frame-debug-fun frame))) + reversed-result))) + (setf catch + #!-alpha + (sap-ref-sap catch + (* sb!vm:catch-block-previous-catch-slot + sb!vm:n-word-bytes)) + #!+alpha + (int-sap + (sap-ref-32 catch + (* sb!vm:catch-block-previous-catch-slot + sb!vm:n-word-bytes))))))) ;;;; operations on DEBUG-FUNs @@ -1123,8 +1162,7 @@ ;;; nil). This may iterate over only some of DEBUG-FUN's variables or ;;; none depending on debug policy; for example, possibly the ;;; compilation only preserved argument information. -(defmacro do-debug-fun-variables ((var debug-fun &optional result) - &body body) +(defmacro do-debug-fun-vars ((var debug-fun &optional result) &body body) (let ((vars (gensym)) (i (gensym))) `(let ((,vars (debug-fun-debug-vars ,debug-fun))) @@ -1163,6 +1201,7 @@ ;;; Return the name of the function represented by DEBUG-FUN. This may ;;; be a string or a cons; do not assume it is a symbol. (defun debug-fun-name (debug-fun) + (declare (type debug-fun debug-fun)) (etypecase debug-fun (compiled-debug-fun (sb!c::compiled-debug-fun-name @@ -1173,13 +1212,12 @@ ;;; Return a DEBUG-FUN that represents debug information for FUN. (defun fun-debug-fun (fun) (declare (type function fun)) - (ecase (get-type 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 - #.sb!vm:closure-fun-header-widetag) + (#.sb!vm:simple-fun-header-widetag (let* ((name (%simple-fun-name fun)) (component (fun-code-header fun)) (res (find-if @@ -1187,7 +1225,7 @@ (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))) - (get-debug-info-fun-map + (sb!c::compiled-debug-info-fun-map (%code-debug-info component))))) (if res (make-compiled-debug-fun res component) @@ -1205,7 +1243,7 @@ sb!vm:n-word-bytes))))))) ;;; Return the kind of the function, which is one of :OPTIONAL, -;;; :EXTERNAL, TOP-level, :CLEANUP, or NIL. +;;; :EXTERNAL, :TOPLEVEL, :CLEANUP, or NIL. (defun debug-fun-kind (debug-fun) ;; FIXME: This "is one of" information should become part of the function ;; declamation, not just a doc string @@ -1226,7 +1264,7 @@ ;;; as symbol. The result of this function is limited to the ;;; availability of variable information in DEBUG-FUN; for ;;; example, possibly DEBUG-FUN only knows about its arguments. -(defun debug-fun-symbol-variables (debug-fun symbol) +(defun debug-fun-symbol-vars (debug-fun symbol) (let ((vars (ambiguous-debug-vars debug-fun (symbol-name symbol))) (package (and (symbol-package symbol) (package-name (symbol-package symbol))))) @@ -1251,7 +1289,7 @@ (if variables (let* ((len (length variables)) (prefix-len (length name-prefix-string)) - (pos (find-variable name-prefix-string variables len)) + (pos (find-var name-prefix-string variables len)) (res nil)) (when pos ;; Find names from pos to variable's len that contain prefix. @@ -1270,19 +1308,19 @@ (setq res (nreverse res))) res)))) -;;; This returns a position in variables for one containing name as an -;;; initial substring. End is the length of variables if supplied. -(defun find-variable (name variables &optional end) +;;; This returns a position in VARIABLES for one containing NAME as an +;;; initial substring. END is the length of VARIABLES if supplied. +(defun find-var (name variables &optional end) (declare (simple-vector variables) (simple-string name)) (let ((name-len (length name))) (position name variables - :test #'(lambda (x y) - (let* ((y (debug-var-symbol-name y)) - (y-len (length y))) - (declare (simple-string y)) - (and (>= y-len name-len) - (string= x y :end1 name-len :end2 name-len)))) + :test (lambda (x y) + (let* ((y (debug-var-symbol-name y)) + (y-len (length y))) + (declare (simple-string y)) + (and (>= y-len name-len) + (string= x y :end1 name-len :end2 name-len)))) :end (or end (length variables))))) ;;; Return a list representing the lambda-list for DEBUG-FUN. The @@ -1370,6 +1408,9 @@ ;; optional. Stick the extra var in the result ;; element representing the keyword or optional, ;; which is the previous one. + ;; + ;; FIXME: NCONC used for side-effect: the effect is defined, + ;; but this is bad style no matter what. (nconc (car res) (list (compiled-debug-fun-lambda-list-var args (incf i) vars)))) @@ -1510,19 +1551,18 @@ (list successors)) (dotimes (k (ldb sb!c::compiled-debug-block-nsucc-byte succ-and-flags)) - (push (sb!c::read-var-integer blocks i) successors)) + (push (sb!c:read-var-integer blocks i) successors)) (let* ((locations - (dotimes (k (sb!c::read-var-integer blocks i) + (dotimes (k (sb!c:read-var-integer blocks i) (result locations-buffer)) (let ((kind (svref sb!c::*compiled-code-location-kinds* (aref+ blocks i))) (pc (+ last-pc - (sb!c::read-var-integer blocks i))) + (sb!c:read-var-integer blocks i))) (tlf-offset (or tlf-number - (sb!c::read-var-integer blocks - i))) - (form-number (sb!c::read-var-integer blocks i)) - (live-set (sb!c::read-packed-bit-vector + (sb!c:read-var-integer blocks i))) + (form-number (sb!c:read-var-integer blocks i)) + (live-set (sb!c:read-packed-bit-vector live-set-len blocks i))) (vector-push-extend (make-known-code-location pc debug-fun tlf-offset @@ -1568,26 +1608,27 @@ (defun assign-minimal-var-names (vars) (declare (simple-vector vars)) (let* ((len (length vars)) - (width (length (format nil "~D" (1- len))))) + (width (length (format nil "~W" (1- len))))) (dotimes (i len) - (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"))))))) + (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")))))))) ;;; Parse the packed representation of DEBUG-VARs from ;;; DEBUG-FUN's SB!C::COMPILED-DEBUG-FUN, returning a vector @@ -1595,7 +1636,7 @@ (defun parse-compiled-debug-vars (debug-fun) (let* ((cdebug-fun (compiled-debug-fun-compiler-debug-fun debug-fun)) - (packed-vars (sb!c::compiled-debug-fun-variables cdebug-fun)) + (packed-vars (sb!c::compiled-debug-fun-vars cdebug-fun)) (args-minimal (eq (sb!c::compiled-debug-fun-arguments cdebug-fun) :minimal))) (when packed-vars @@ -1627,18 +1668,6 @@ save-sc-offset) buffer))))))) -;;;; unpacking minimal debug functions - -;;; Return a FUN-MAP for a given COMPILED-DEBUG-INFO object. -(defun get-debug-info-fun-map (info) - (declare (type sb!c::compiled-debug-info info)) - (let ((map (sb!c::compiled-debug-info-fun-map info))) - ;; The old CMU CL had various hairy possibilities here, but in - ;; SBCL we only use this one, right? - (aver (simple-vector-p map)) - ;; So it's easy.. - map)) - ;;;; CODE-LOCATIONs ;;; If we're sure of whether code-location is known, return T or NIL. @@ -1721,33 +1750,17 @@ ;;; Return the CODE-LOCATION's DEBUG-SOURCE. (defun code-location-debug-source (code-location) - (etypecase code-location - (compiled-code-location - (let* ((info (compiled-debug-fun-debug-info - (code-location-debug-fun code-location))) - (sources (sb!c::compiled-debug-info-source info)) - (len (length sources))) - (declare (list sources)) - (when (zerop len) - (debug-signal 'no-debug-blocks :debug-fun - (code-location-debug-fun code-location))) - (if (= len 1) - (car sources) - (do ((prev sources src) - (src (cdr sources) (cdr src)) - (offset (code-location-top-level-form-offset code-location))) - ((null src) (car prev)) - (when (< offset (sb!c::debug-source-source-root (car src))) - (return (car prev))))))) - ;; (There used to be more cases back before sbcl-0.7.0, when we - ;; did special tricks to debug the IR1 interpreter.) - )) + (let ((info (compiled-debug-fun-debug-info + (code-location-debug-fun code-location)))) + (or (sb!c::debug-info-source info) + (debug-signal 'no-debug-blocks :debug-fun + (code-location-debug-fun code-location))))) -;;; Returns the number of top-level forms before the one containing +;;; Returns the number of top level forms before the one containing ;;; CODE-LOCATION as seen by the compiler in some compilation unit. (A ;;; compilation unit is not necessarily a single file, see the section ;;; on debug-sources.) -(defun code-location-top-level-form-offset (code-location) +(defun code-location-toplevel-form-offset (code-location) (when (code-location-unknown-p code-location) (error 'unknown-code-location :code-location code-location)) (let ((tlf-offset (code-location-%tlf-offset code-location))) @@ -1757,7 +1770,7 @@ (unless (fill-in-code-location code-location) ;; This check should be unnecessary. We're missing ;; debug info the compiler should have dumped. - (error "internal error: unknown code location")) + (bug "unknown code location")) (code-location-%tlf-offset code-location)) ;; (There used to be more cases back before sbcl-0.7.0,, ;; when we did special tricks to debug the IR1 @@ -1766,7 +1779,7 @@ (t tlf-offset)))) ;;; Return the number of the form corresponding to CODE-LOCATION. The -;;; form number is derived by a walking the subforms of a top-level +;;; form number is derived by a walking the subforms of a top level ;;; form in depth-first order. (defun code-location-form-number (code-location) (when (code-location-unknown-p code-location) @@ -1778,7 +1791,7 @@ (unless (fill-in-code-location code-location) ;; This check should be unnecessary. We're missing ;; debug info the compiler should have dumped. - (error "internal error: unknown code location")) + (bug "unknown code location")) (code-location-%form-number code-location)) ;; (There used to be more cases back before sbcl-0.7.0,, ;; when we did special tricks to debug the IR1 @@ -1800,7 +1813,7 @@ ((not (fill-in-code-location code-location)) ;; This check should be unnecessary. We're missing ;; debug info the compiler should have dumped. - (error "internal error: unknown code location")) + (bug "unknown code location")) (t (compiled-code-location-kind code-location))))) ;; (There used to be more cases back before sbcl-0.7.0,, @@ -1821,7 +1834,7 @@ ;; ;; FIXME: This error and comment happen over and over again. ;; Make them a shared function. - (error "internal error: unknown code location")) + (bug "unknown code location")) (compiled-code-location-%live-set code-location)) (t live-set))))) @@ -1839,8 +1852,7 @@ ;; interpreter.) )) ;; (There used to be more cases back before sbcl-0.7.0,, - ;; when we did special tricks to debug the IR1 - ;; interpreter.) + ;; when we did special tricks to debug IR1-interpreted code.) )) (defun sub-compiled-code-location= (obj1 obj2) (= (compiled-code-location-pc obj1) @@ -1962,18 +1974,19 @@ ;;; GC, and might also arise in debug variable locations when ;;; those variables are invalid.) (defun make-valid-lisp-obj (val) - (/show0 "entering MAKE-VALID-LISP-OBJ, VAL=..") - #!+sb-show (/hexstr val) (if (or ;; fixnum - (zerop (logand val 3)) + (zerop (logand val sb!vm:fixnum-tag-mask)) + ;; immediate single float, 64-bit only + #!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or)) + (= (logand val #xff) sb!vm:single-float-widetag) ;; character - (and (zerop (logand val #xffff0000)) ; Top bits zero - (= (logand val #xff) sb!vm:base-char-widetag)) ; char tag + (and (zerop (logandc2 val #x1fffffff)) ; Top bits zero + (= (logand val #xff) sb!vm:character-widetag)) ; char tag ;; unbound marker (= val sb!vm:unbound-marker-widetag) ;; pointer - (and (logand val 1) + (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 @@ -1983,12 +1996,12 @@ (< sb!vm:static-space-start val (* sb!vm:*static-space-free-pointer* sb!vm:n-word-bytes)) - (< sb!vm:dynamic-space-start val + (< (current-dynamic-space-start) val (sap-int (dynamic-space-free-pointer)))))) (make-lisp-obj val) :invalid-object)) -#!-x86 +#!-(or x86 x86-64) (defun sub-access-debug-var-slot (fp sc-offset &optional escaped) (macrolet ((with-escaped-value ((var) &body forms) `(if escaped @@ -2024,7 +2037,7 @@ (sb!sys:without-gcing (with-escaped-value (val) (sb!kernel:make-lisp-obj val)))) - (#.sb!vm:base-char-reg-sc-number + (#.sb!vm:character-reg-sc-number (with-escaped-value (val) (code-char val))) (#.sb!vm:sap-reg-sc-number @@ -2063,7 +2076,7 @@ (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) + escaped (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 2 #!-sparc 1) 'double-float)) :invalid-value-for-unescaped-register-storage)) #!+long-float @@ -2114,7 +2127,7 @@ sb!vm:n-word-bytes))))) (#.sb!vm:control-stack-sc-number (sb!kernel:stack-ref fp (sb!c:sc-offset-offset sc-offset))) - (#.sb!vm:base-char-stack-sc-number + (#.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))))) @@ -2131,18 +2144,14 @@ (sb!sys:sap-ref-sap nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes))))))) -#!+x86 +#!+(or x86 x86-64) (defun sub-access-debug-var-slot (fp sc-offset &optional escaped) (declare (type system-area-pointer fp)) - (/show0 "entering SUB-ACCESS-DEBUG-VAR-SLOT, FP,SC-OFFSET,ESCAPED=..") - (/hexstr fp) (/hexstr sc-offset) (/hexstr escaped) (macrolet ((with-escaped-value ((var) &body forms) `(if escaped (let ((,var (sb!vm:context-register escaped (sb!c:sc-offset-offset sc-offset)))) - (/show0 "in escaped case, ,VAR value=..") - (/hexstr ,var) ,@forms) :invalid-value-for-unescaped-register-storage)) (escaped-float-value (format) @@ -2160,72 +2169,54 @@ :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) - (/show0 "case of ANY-REG-SC-NUMBER or DESCRIPTOR-REG-SC-NUMBER") (without-gcing (with-escaped-value (val) - (/show0 "VAL=..") - (/hexstr val) (make-valid-lisp-obj val)))) - (#.sb!vm:base-char-reg-sc-number - (/show0 "case of BASE-CHAR-REG-SC-NUMBER") + (#.sb!vm:character-reg-sc-number (with-escaped-value (val) (code-char val))) (#.sb!vm:sap-reg-sc-number - (/show0 "case of SAP-REG-SC-NUMBER") (with-escaped-value (val) (int-sap val))) (#.sb!vm:signed-reg-sc-number - (/show0 "case of 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 - (/show0 "case of UNSIGNED-REG-SC-NUMBER") (with-escaped-value (val) val)) (#.sb!vm:single-reg-sc-number - (/show0 "case of SINGLE-REG-SC-NUMBER") (escaped-float-value single-float)) (#.sb!vm:double-reg-sc-number - (/show0 "case of DOUBLE-REG-SC-NUMBER") (escaped-float-value double-float)) #!+long-float (#.sb!vm:long-reg-sc-number - (/show0 "case of LONG-REG-SC-NUMBER") (escaped-float-value long-float)) (#.sb!vm:complex-single-reg-sc-number - (/show0 "case of COMPLEX-SINGLE-REG-SC-NUMBER") (escaped-complex-float-value single-float)) (#.sb!vm:complex-double-reg-sc-number - (/show0 "case of COMPLEX-DOUBLE-REG-SC-NUMBER") (escaped-complex-float-value double-float)) #!+long-float (#.sb!vm:complex-long-reg-sc-number - (/show0 "case of COMPLEX-LONG-REG-SC-NUMBER") (escaped-complex-float-value long-float)) (#.sb!vm:single-stack-sc-number - (/show0 "case of 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 - (/show0 "case of 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 - (/show0 "case of 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 - (/show0 "case of COMPLEX-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 - (/show0 "case of COMPLEX-DOUBLE-STACK-SC-NUMBER") (complex (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2) sb!vm:n-word-bytes))) @@ -2233,30 +2224,24 @@ sb!vm:n-word-bytes))))) #!+long-float (#.sb!vm:complex-long-stack-sc-number - (/show0 "case of 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 - (/show0 "case of CONTROL-STACK-SC-NUMBER") (stack-ref fp (sb!c:sc-offset-offset sc-offset))) - (#.sb!vm:base-char-stack-sc-number - (/show0 "case of BASE-CHAR-STACK-SC-NUMBER") + (#.sb!vm:character-stack-sc-number (code-char - (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes))))) + (sap-ref-word fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) + sb!vm:n-word-bytes))))) (#.sb!vm:unsigned-stack-sc-number - (/show0 "case of UNSIGNED-STACK-SC-NUMBER") - (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes)))) + (sap-ref-word fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) + sb!vm:n-word-bytes)))) (#.sb!vm:signed-stack-sc-number - (/show0 "case of SIGNED-STACK-SC-NUMBER") - (signed-sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes)))) + (signed-sap-ref-word fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) + sb!vm:n-word-bytes)))) (#.sb!vm:sap-stack-sc-number - (/show0 "case of SAP-STACK-SC-NUMBER") (sap-ref-sap fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) sb!vm:n-word-bytes))))))) @@ -2288,7 +2273,7 @@ (compiled-debug-var-sc-offset debug-var)) value)))) -#!-x86 +#!-(or x86 x86-64) (defun sub-set-debug-var-slot (fp sc-offset value &optional escaped) (macrolet ((set-escaped-value (val) `(if escaped @@ -2327,7 +2312,7 @@ (without-gcing (set-escaped-value (get-lisp-obj-address value)))) - (#.sb!vm:base-char-reg-sc-number + (#.sb!vm:character-reg-sc-number (set-escaped-value (char-code value))) (#.sb!vm:sap-reg-sc-number (set-escaped-value (sap-int value))) @@ -2426,7 +2411,7 @@ (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:base-char-stack-sc-number + (#.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)) @@ -2447,7 +2432,7 @@ sb!vm:n-word-bytes)) (the system-area-pointer value))))))) -#!+x86 +#!+(or x86 x86-64) (defun sub-set-debug-var-slot (fp sc-offset value &optional escaped) (macrolet ((set-escaped-value (val) `(if escaped @@ -2461,7 +2446,7 @@ (without-gcing (set-escaped-value (get-lisp-obj-address value)))) - (#.sb!vm:base-char-reg-sc-number + (#.sb!vm:character-reg-sc-number (set-escaped-value (char-code value))) (#.sb!vm:sap-reg-sc-number (set-escaped-value (sap-int value))) @@ -2525,19 +2510,19 @@ (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:base-char-stack-sc-number - (setf (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes))) + (#.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-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes))) - (the (unsigned-byte 32) value))) + (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-32 + (setf (signed-sap-ref-word fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) sb!vm:n-word-bytes))) - (the (signed-byte 32) value))) + (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))) @@ -2547,8 +2532,8 @@ ;;; this to determine if the value stored is the actual value or an ;;; indirection cell. (defun indirect-value-cell-p (x) - (and (= (get-lowtag x) sb!vm:other-pointer-lowtag) - (= (get-type x) sb!vm:value-cell-header-widetag))) + (and (= (lowtag-of x) sb!vm:other-pointer-lowtag) + (= (widetag-of x) sb!vm:value-cell-header-widetag))) ;;; Return three values reflecting the validity of DEBUG-VAR's value ;;; at BASIC-CODE-LOCATION: @@ -2602,15 +2587,15 @@ ;;; This code produces and uses what we call source-paths. A ;;; source-path is a list whose first element is a form number as ;;; returned by CODE-LOCATION-FORM-NUMBER and whose last element is a -;;; top-level-form number as returned by -;;; CODE-LOCATION-TOP-LEVEL-FORM-NUMBER. The elements from the last to +;;; top level form number as returned by +;;; CODE-LOCATION-TOPLEVEL-FORM-NUMBER. The elements from the last to ;;; the first, exclusively, are the numbered subforms into which to ;;; descend. For example: ;;; (defun foo (x) ;;; (let ((a (aref x 3))) ;;; (cons a 3))) ;;; The call to AREF in this example is form number 5. Assuming this -;;; DEFUN is the 11'th top-level-form, the source-path for the AREF +;;; DEFUN is the 11'th top level form, the source-path for the AREF ;;; call is as follows: ;;; (5 1 0 1 3 11) ;;; Given the DEFUN, 3 gets you the LET, 1 gets you the bindings, 0 @@ -2623,13 +2608,13 @@ ;;; 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 top-level-form form, going directly to the -;;; subform corressponding to the form number. +;;; 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. ;;; ;;; The vector elements are in the same format as the compiler's ;;; NODE-SOURCE-PATH; that is, the first element is the form number and -;;; the last is the top-level-form number. +;;; 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) @@ -2658,7 +2643,7 @@ (frob) (setq trail (cdr trail))))))) -;;; FORM is a top-level form, and path is a source-path into it. This +;;; 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 ;;; number of enclosing forms to return instead of directly returning ;;; the source-path form. When context is non-zero, the form returned @@ -2704,7 +2689,7 @@ ;;; The returned function takes the frame to get values from as its ;;; argument, and it returns the values of FORM. The returned function ;;; can signal the following conditions: INVALID-VALUE, -;;; AMBIGUOUS-VARIABLE-NAME, and FRAME-FUN-MISMATCH. +;;; AMBIGUOUS-VAR-NAME, and FRAME-FUN-MISMATCH. (defun preprocess-for-eval (form loc) (declare (type code-location loc)) (let ((n-frame (gensym)) @@ -2713,7 +2698,7 @@ (debug-signal 'no-debug-vars :debug-fun fun)) (sb!int:collect ((binds) (specs)) - (do-debug-fun-variables (var fun) + (do-debug-fun-vars (var fun) (let ((validity (debug-var-validity var loc))) (unless (eq validity :invalid) (let* ((sym (debug-var-symbol var)) @@ -2728,44 +2713,45 @@ (:valid (specs `(,name (debug-var-value ',var ,n-frame)))) (:unknown - (specs `(,name (debug-signal 'invalid-value :debug-var ',var + (specs `(,name (debug-signal 'invalid-value + :debug-var ',var :frame ,n-frame)))) (:ambiguous - (specs `(,name (debug-signal 'ambiguous-variable-name :name ',name + (specs `(,name (debug-signal 'ambiguous-var-name + :name ',name :frame ,n-frame))))))) (let ((res (coerce `(lambda (,n-frame) (declare (ignorable ,n-frame)) (symbol-macrolet ,(specs) ,form)) 'function))) - #'(lambda (frame) - ;; This prevents these functions from being used in any - ;; location other than a function return location, so - ;; maybe this should only check whether frame's - ;; DEBUG-FUN is the same as loc's. - (unless (code-location= (frame-code-location frame) loc) - (debug-signal 'frame-fun-mismatch - :code-location loc :form form :frame frame)) - (funcall res frame)))))) + (lambda (frame) + ;; This prevents these functions from being used in any + ;; location other than a function return location, so maybe + ;; this should only check whether FRAME's DEBUG-FUN is the + ;; same as LOC's. + (unless (code-location= (frame-code-location frame) loc) + (debug-signal 'frame-fun-mismatch + :code-location loc :form form :frame frame)) + (funcall res frame)))))) ;;;; breakpoints ;;;; user-visible interface ;;; Create and return a breakpoint. When program execution encounters -;;; the breakpoint, the system calls HOOK-FUNCTION. HOOK-FUNCTION takes the -;;; current frame for the function in which the program is running and the -;;; breakpoint object. +;;; the breakpoint, the system calls HOOK-FUN. HOOK-FUN takes the +;;; current frame for the function in which the program is running and +;;; the breakpoint object. ;;; ;;; WHAT and KIND determine where in a function the system invokes -;;; HOOK-FUNCTION. WHAT is either a code-location or a DEBUG-FUN. -;;; KIND is one of :CODE-LOCATION, :FUN-START, or :FUN-END. -;;; Since the starts and ends of functions may not have code-locations -;;; representing them, designate these places by supplying WHAT as a -;;; DEBUG-FUN and KIND indicating the :FUN-START or -;;; :FUN-END. When WHAT is a DEBUG-FUN and kind is -;;; :FUN-END, then hook-function must take two additional -;;; arguments, a list of values returned by the function and a -;;; FUN-END-COOKIE. +;;; HOOK-FUN. WHAT is either a code-location or a DEBUG-FUN. KIND is +;;; one of :CODE-LOCATION, :FUN-START, or :FUN-END. Since the starts +;;; and ends of functions may not have code-locations representing +;;; them, designate these places by supplying WHAT as a DEBUG-FUN and +;;; KIND indicating the :FUN-START or :FUN-END. When WHAT is a +;;; DEBUG-FUN and kind is :FUN-END, then HOOK-FUN must take two +;;; additional arguments, a list of values returned by the function +;;; and a FUN-END-COOKIE. ;;; ;;; INFO is information supplied by and used by the user. ;;; @@ -2780,7 +2766,7 @@ ;;; function. ;;; ;;; Signal an error if WHAT is an unknown code-location. -(defun make-breakpoint (hook-function what +(defun make-breakpoint (hook-fun what &key (kind :code-location) info fun-end-cookie) (etypecase what (code-location @@ -2788,12 +2774,12 @@ (error "cannot make a breakpoint at an unknown code location: ~S" what)) (aver (eq kind :code-location)) - (let ((bpt (%make-breakpoint hook-function what kind info))) + (let ((bpt (%make-breakpoint hook-fun what kind info))) (etypecase what (compiled-code-location ;; This slot is filled in due to calling CODE-LOCATION-UNKNOWN-P. (when (eq (compiled-code-location-kind what) :unknown-return) - (let ((other-bpt (%make-breakpoint hook-function what + (let ((other-bpt (%make-breakpoint hook-fun what :unknown-return-partner info))) (setf (breakpoint-unknown-return-partner bpt) other-bpt) @@ -2806,19 +2792,19 @@ (compiled-debug-fun (ecase kind (:fun-start - (%make-breakpoint hook-function what kind info)) + (%make-breakpoint hook-fun what kind info)) (:fun-end (unless (eq (sb!c::compiled-debug-fun-returns (compiled-debug-fun-compiler-debug-fun what)) :standard) (error ":FUN-END breakpoints are currently unsupported ~ - for the known return convention.")) + for the known return convention.")) - (let* ((bpt (%make-breakpoint hook-function what kind info)) + (let* ((bpt (%make-breakpoint hook-fun what kind info)) (starter (compiled-debug-fun-end-starter what))) (unless starter (setf starter (%make-breakpoint #'list what :fun-start nil)) - (setf (breakpoint-hook-function starter) + (setf (breakpoint-hook-fun starter) (fun-end-starter-hook starter what)) (setf (compiled-debug-fun-end-starter what) starter)) (setf (breakpoint-start-helper bpt) starter) @@ -2856,31 +2842,31 @@ (defun fun-end-starter-hook (starter-bpt debug-fun) (declare (type breakpoint starter-bpt) (type compiled-debug-fun debug-fun)) - #'(lambda (frame breakpoint) - (declare (ignore breakpoint) - (type frame frame)) - (let ((lra-sc-offset - (sb!c::compiled-debug-fun-return-pc - (compiled-debug-fun-compiler-debug-fun debug-fun)))) - (multiple-value-bind (lra component offset) - (make-bogus-lra - (get-context-value frame - lra-save-offset - lra-sc-offset)) - (setf (get-context-value frame - lra-save-offset - lra-sc-offset) - lra) - (let ((end-bpts (breakpoint-%info starter-bpt))) - (let ((data (breakpoint-data component offset))) - (setf (breakpoint-data-breakpoints data) end-bpts) - (dolist (bpt end-bpts) - (setf (breakpoint-internal-data bpt) data))) - (let ((cookie (make-fun-end-cookie lra debug-fun))) - (setf (gethash component *fun-end-cookies*) cookie) - (dolist (bpt end-bpts) - (let ((fun (breakpoint-cookie-fun bpt))) - (when fun (funcall fun frame cookie)))))))))) + (lambda (frame breakpoint) + (declare (ignore breakpoint) + (type frame frame)) + (let ((lra-sc-offset + (sb!c::compiled-debug-fun-return-pc + (compiled-debug-fun-compiler-debug-fun debug-fun)))) + (multiple-value-bind (lra component offset) + (make-bogus-lra + (get-context-value frame + lra-save-offset + lra-sc-offset)) + (setf (get-context-value frame + lra-save-offset + lra-sc-offset) + lra) + (let ((end-bpts (breakpoint-%info starter-bpt))) + (let ((data (breakpoint-data component offset))) + (setf (breakpoint-data-breakpoints data) end-bpts) + (dolist (bpt end-bpts) + (setf (breakpoint-internal-data bpt) data))) + (let ((cookie (make-fun-end-cookie lra debug-fun))) + (setf (gethash component *fun-end-cookies*) cookie) + (dolist (bpt end-bpts) + (let ((fun (breakpoint-cookie-fun bpt))) + (when fun (funcall fun frame cookie)))))))))) ;;; This takes a FUN-END-COOKIE and a frame, and it returns ;;; whether the cookie is still valid. A cookie becomes invalid when @@ -2900,13 +2886,14 @@ (do ((frame frame (frame-down frame))) ((not frame) nil) (when (and (compiled-frame-p frame) - (eq lra - (get-context-value frame lra-save-offset lra-sc-offset))) + (#!-(or x86 x86-64) eq #!+(or x86 x86-64) sap= + lra + (get-context-value frame lra-save-offset lra-sc-offset))) (return t))))) ;;;; ACTIVATE-BREAKPOINT -;;; Cause the system to invoke the breakpoint's hook-function until +;;; Cause the system to invoke the breakpoint's hook function until ;;; the next call to DEACTIVATE-BREAKPOINT or DELETE-BREAKPOINT. The ;;; system invokes breakpoint hook functions in the opposite order ;;; that you activate them. @@ -2989,7 +2976,7 @@ ;;;; DEACTIVATE-BREAKPOINT -;;; Stop the system from invoking the breakpoint's hook-function. +;;; Stop the system from invoking the breakpoint's hook function. (defun deactivate-breakpoint (breakpoint) (when (eq (breakpoint-status breakpoint) :active) (without-interrupts @@ -3008,9 +2995,9 @@ (defun deactivate-compiled-breakpoint (breakpoint) (if (eq (breakpoint-kind breakpoint) :fun-end) (let ((starter (breakpoint-start-helper breakpoint))) - (unless (find-if #'(lambda (bpt) - (and (not (eq bpt breakpoint)) - (eq (breakpoint-status bpt) :active))) + (unless (find-if (lambda (bpt) + (and (not (eq bpt breakpoint)) + (eq (breakpoint-status bpt) :active))) (breakpoint-%info starter)) (deactivate-compiled-breakpoint starter))) (let* ((data (breakpoint-internal-data breakpoint)) @@ -3076,28 +3063,28 @@ ;;; returns the overwritten bits. You must call this in a context in ;;; which GC is disabled, so that Lisp doesn't move objects around ;;; that C is pointing to. -(sb!alien:def-alien-routine "breakpoint_install" sb!c-call:unsigned-long - (code-obj sb!c-call:unsigned-long) - (pc-offset sb!c-call:int)) +(sb!alien:define-alien-routine "breakpoint_install" sb!alien:unsigned-long + (code-obj sb!alien:unsigned-long) + (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:def-alien-routine "breakpoint_remove" sb!c-call:void - (code-obj sb!c-call:unsigned-long) - (pc-offset sb!c-call:int) - (old-inst sb!c-call:unsigned-long)) +(sb!alien:define-alien-routine "breakpoint_remove" sb!alien:void + (code-obj sb!alien:unsigned-long) + (pc-offset sb!alien:int) + (old-inst sb!alien:unsigned-long)) -(sb!alien:def-alien-routine "breakpoint_do_displaced_inst" sb!c-call:void +(sb!alien:define-alien-routine "breakpoint_do_displaced_inst" sb!alien:void (scp (* os-context-t)) - (orig-inst sb!c-call:unsigned-long)) + (orig-inst sb!alien:unsigned-long)) ;;;; breakpoint handlers (layer between C and exported interface) -;;; This maps components to a mapping of offsets to breakpoint-datas. +;;; This maps components to a mapping of offsets to BREAKPOINT-DATAs. (defvar *component-breakpoint-offsets* (make-hash-table :test 'eq)) -;;; This returns the breakpoint-data associated with component cross +;;; This returns the BREAKPOINT-DATA object associated with component cross ;;; offset. If none exists, this makes one, installs it, and returns it. (defun breakpoint-data (component offset &optional (create t)) (flet ((install-breakpoint-data () @@ -3115,7 +3102,7 @@ (install-breakpoint-data))))) ;;; We use this when there are no longer any active breakpoints -;;; corresponding to data. +;;; corresponding to DATA. (defun delete-breakpoint-data (data) (let* ((component (breakpoint-data-component data)) (offsets (delete (breakpoint-data-offset data) @@ -3127,10 +3114,10 @@ (values)) ;;; The C handler for interrupts calls this when it has a -;;; debugging-tool break instruction. This does NOT handle all breaks; -;;; for example, it does not handle breaks for internal errors. +;;; debugging-tool break instruction. This does *not* handle all +;;; breaks; for example, it does not handle breaks for internal +;;; errors. (defun handle-breakpoint (offset component signal-context) - (/show0 "entering HANDLE-BREAKPOINT") (let ((data (breakpoint-data component offset nil))) (unless data (error "unknown breakpoint in ~S at offset ~S" @@ -3154,9 +3141,8 @@ ;;; This handles code-location and DEBUG-FUN :FUN-START ;;; breakpoints. (defun handle-breakpoint-aux (breakpoints data offset component signal-context) - (/show0 "entering HANDLE-BREAKPOINT-AUX") (unless breakpoints - (error "internal error: breakpoint that nobody wants")) + (bug "breakpoint that nobody wants")) (unless (member data *executing-breakpoint-hooks*) (let ((*executing-breakpoint-hooks* (cons data *executing-breakpoint-hooks*))) @@ -3178,9 +3164,9 @@ (breakpoint-do-displaced-inst signal-context (breakpoint-data-instruction data)) ;; Some platforms have no usable sigreturn() call. If your - ;; implementation of arch_do_displaced_inst() doesn't sigreturn(), - ;; add it to this list. - #!-(or hpux irix x86 alpha) + ;; implementation of arch_do_displaced_inst() _does_ sigreturn(), + ;; it's polite to warn here + #!+(and sparc solaris) (error "BREAKPOINT-DO-DISPLACED-INST returned?")))) (defun invoke-breakpoint-hooks (breakpoints component offset) @@ -3188,7 +3174,7 @@ (frame (do ((f (top-frame) (frame-down f))) ((eq debug-fun (frame-debug-fun f)) f)))) (dolist (bpt breakpoints) - (funcall (breakpoint-hook-function bpt) + (funcall (breakpoint-hook-fun bpt) frame ;; If this is an :UNKNOWN-RETURN-PARTNER, then pass the ;; hook function the original breakpoint, so that users @@ -3199,7 +3185,6 @@ bpt))))) (defun handle-fun-end-breakpoint (offset component context) - (/show0 "entering HANDLE-FUN-END-BREAKPOINT") (let ((data (breakpoint-data component offset nil))) (unless data (error "unknown breakpoint in ~S at offset ~S" @@ -3214,7 +3199,6 @@ ;;; [old C code] or HANDLE-FUN-END-BREAKPOINT calls this directly ;;; [new C code]. (defun handle-fun-end-breakpoint-aux (breakpoints data signal-context) - (/show0 "entering HANDLE-FUN-END-BREAKPOINT-AUX") (delete-breakpoint-data data) (let* ((scp (locally @@ -3228,7 +3212,7 @@ (cookie (gethash component *fun-end-cookies*))) (remhash component *fun-end-cookies*) (dolist (bpt breakpoints) - (funcall (breakpoint-hook-function bpt) + (funcall (breakpoint-hook-fun bpt) frame bpt (get-fun-end-breakpoint-values scp) cookie)))) @@ -3236,8 +3220,8 @@ (defun get-fun-end-breakpoint-values (scp) (let ((ocfp (int-sap (sb!vm:context-register scp - #!-x86 sb!vm::ocfp-offset - #!+x86 sb!vm::ebx-offset))) + #!-(or x86 x86-64) sb!vm::ocfp-offset + #!+(or x86 x86-64) sb!vm::ebx-offset))) (nargs (make-lisp-obj (sb!vm:context-register scp sb!vm::nargs-offset))) (reg-arg-offsets '#.sb!vm::*register-arg-offsets*) @@ -3254,9 +3238,9 @@ ;;;; MAKE-BOGUS-LRA (used for :FUN-END breakpoints) (defconstant bogus-lra-constants - #!-x86 2 #!+x86 3) + #!-(or x86 x86-64) 2 #!+(or x86 x86-64) 3) (defconstant known-return-p-slot - (+ sb!vm:code-constants-offset #!-x86 1 #!+x86 2)) + (+ sb!vm:code-constants-offset #!-(or x86 x86-64) 1 #!+(or x86 x86-64) 2)) ;;; Make a bogus LRA object that signals a breakpoint trap when ;;; returned to. If the breakpoint trap handler returns, REAL-LRA is @@ -3265,16 +3249,15 @@ ;;; instruction. (defun make-bogus-lra (real-lra &optional known-return-p) (without-gcing + ;; These are really code labels, not variables: but this way we get + ;; their addresses. (let* ((src-start (foreign-symbol-address "fun_end_breakpoint_guts")) (src-end (foreign-symbol-address "fun_end_breakpoint_end")) (trap-loc (foreign-symbol-address "fun_end_breakpoint_trap")) (length (sap- src-end src-start)) (code-object - (%primitive - #!-(and x86 gencgc) sb!c:allocate-code-object - #!+(and x86 gencgc) sb!c::allocate-dynamic-code-object - (1+ bogus-lra-constants) - length)) + (%primitive 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) @@ -3282,19 +3265,19 @@ (setf (%code-debug-info code-object) :bogus-lra) (setf (code-header-ref code-object sb!vm:code-trace-table-offset-slot) length) - #!-x86 + #!-(or x86 x86-64) (setf (code-header-ref code-object real-lra-slot) real-lra) - #!+x86 + #!+(or x86 x86-64) (multiple-value-bind (offset code) (compute-lra-data-from-pc real-lra) (setf (code-header-ref code-object real-lra-slot) code) (setf (code-header-ref code-object (1+ real-lra-slot)) offset)) (setf (code-header-ref code-object known-return-p-slot) known-return-p) - (system-area-copy src-start 0 dst-start 0 (* length sb!vm:n-byte-bits)) + (system-area-ub8-copy src-start 0 dst-start 0 length) (sb!vm:sanctify-for-execution code-object) - #!+x86 + #!+(or x86 x86-64) (values dst-start code-object (sap- trap-loc src-start)) - #!-x86 + #!-(or x86 x86-64) (let ((new-lra (make-lisp-obj (+ (sap-int dst-start) sb!vm:other-pointer-lowtag)))) (set-header-data @@ -3324,14 +3307,3 @@ ;; (There used to be more cases back before sbcl-0.7.0, when ;; we did special tricks to debug the IR1 interpreter.) )) - -(defun print-code-locations (function) - (let ((debug-fun (fun-debug-fun function))) - (do-debug-fun-blocks (block debug-fun) - (do-debug-block-locations (loc block) - (fill-in-code-location loc) - (format t "~S code location at ~D" - (compiled-code-location-kind loc) - (compiled-code-location-pc loc)) - (sb!debug::print-code-location-source-form loc 0) - (terpri)))))