X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=d05a3dab8a10234ffdc0eeebc138915fce58ace7;hb=cd13034f9415f64cdaa05893a4ac5ff1e95c97bd;hp=698732871c05ad0fbdc2bdee88f81e8ff89786bb;hpb=b0b168c08b31a748150f404398af754f26fd4813;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 6987328..d05a3da 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -507,7 +507,7 @@ ;;;; 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,18 +524,23 @@ (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)))) + (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))))) #!+x86 (sb!alien:define-alien-routine component-ptr-from-pc (system-area-pointer) @@ -575,10 +580,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 @@ -594,7 +602,7 @@ (fixnum 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 @@ -604,9 +612,9 @@ 4)))) (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) + (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 +629,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 +648,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) @@ -705,10 +713,10 @@ frame))) (bogus-debug-fun (let ((fp (frame-pointer frame))) - (when (cstack-pointer-valid-p fp) + (when (control-stack-pointer-valid-p fp) #!+x86 (multiple-value-bind (ra ofp) (x86-call-context fp) - (compute-calling-frame ofp ra frame)) + (and ra (compute-calling-frame ofp ra frame))) #!-x86 (compute-calling-frame #!-alpha @@ -791,7 +799,7 @@ #!-x86 (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 +828,7 @@ "undefined function")) (:foreign-function (make-bogus-debug-fun - "foreign function call land")) + (format nil "foreign function call land:"))) ((nil) (make-bogus-debug-fun "bogus stack frame")) @@ -835,7 +843,7 @@ (defun compute-calling-frame (caller ra up-frame) (declare (type system-area-pointer caller ra)) (/noshow0 "entering COMPUTE-CALLING-FRAME") - (when (cstack-pointer-valid-p caller) + (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) @@ -866,7 +874,8 @@ "undefined function")) (:foreign-function (make-bogus-debug-fun - "foreign function call land")) + (format nil "foreign function call land: ra=#x~X" + (sap-int ra)))) ((nil) (make-bogus-debug-fun "bogus stack frame")) @@ -879,15 +888,20 @@ (if up-frame (1+ (frame-number up-frame)) 0) escaped))))) +(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))) + #!+x86 (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)) - (sb!alien:with-alien - ((lisp-interrupt-contexts (array (* os-context-t) nil) :extern)) (/noshow0 "at head of WITH-ALIEN") - (let ((context (sb!alien:deref lisp-interrupt-contexts index))) + (let ((context (nth-interrupt-context index))) (/noshow0 "got CONTEXT") (when (= (sap-int frame-pointer) (sb!vm:context-register context sb!vm::cfp-offset)) @@ -919,51 +933,49 @@ pc-offset code)) (/noshow0 "returning from FIND-ESCAPED-FRAME") (return - (values code pc-offset context)))))))))) + (values code pc-offset context))))))))) #!-x86 (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 + (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)) - (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))))))))))) + ;; 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)))))))))) ;;; Find the code object corresponding to the object represented by ;;; bits and return it. We assume bogus functions correspond to the @@ -1178,8 +1190,7 @@ (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 @@ -1510,19 +1521,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 @@ -1745,7 +1755,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 +1776,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 @@ -1788,7 +1798,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,, @@ -1809,7 +1819,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))))) @@ -2048,7 +2058,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 @@ -2858,7 +2868,7 @@ (do ((frame frame (frame-down frame))) ((not frame) nil) (when (and (compiled-frame-p frame) - (#-x86 eq #+x86 sap= + (#!-x86 eq #!+x86 sap= lra (get-context-value frame lra-save-offset lra-sc-offset))) (return t))))) @@ -3035,21 +3045,21 @@ ;;; 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:define-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:define-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:define-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) @@ -3114,7 +3124,7 @@ ;;; breakpoints. (defun handle-breakpoint-aux (breakpoints data offset component signal-context) (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*))) @@ -3136,9 +3146,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) @@ -3280,14 +3290,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 ~W" - (compiled-code-location-kind loc) - (compiled-code-location-pc loc)) - (sb!debug::print-code-location-source-form loc 0) - (terpri)))))