X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=7424749b82e73c7b2bc44958300d7d342e7f7f7e;hb=f61bddabbb69f1347b81b8ab76e709635a7a0739;hp=0e745e0ea9fe785d564c2c33e656b328aedda95b;hpb=022201adb9c68ed4f509457bb6e7d62a5c6a4d4c;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 0e745e0..7424749 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -268,20 +268,13 @@ (:include frame) (:constructor make-compiled-frame (pointer up debug-function code-location number - #!+gengc saved-state-chain &optional escaped)) (:copier nil)) ;; This indicates whether someone interrupted the frame. ;; (unexported). If escaped, this is a pointer to the state that was - ;; saved when we were interrupted. On the non-gengc system, this is - ;; a pointer to an os_context_t, i.e. the third argument to an - ;; SA_SIGACTION-style signal handler. On the gengc system, this is a - ;; state pointer from SAVED-STATE-CHAIN. - escaped - ;; a list of SAPs to saved states. Each time we unwind past an - ;; exception, we pop the next entry off this list. When we get to - ;; the end of the list, there is nothing else on the stack. - #!+gengc (saved-state-chain nil :type list)) + ;; saved when we were interrupted, an os_context_t, i.e. the third + ;; argument to an SA_SIGACTION-style signal handler. + escaped) (def!method print-object ((obj compiled-frame) str) (print-unreadable-object (obj str :type t) (format str @@ -581,8 +574,7 @@ (declare (type system-area-pointer x)) #!-x86 ; stack grows toward high address values (and (sap< x (current-sp)) - (sap<= #!-gengc (int-sap control-stack-start) - #!+gengc (mutator-control-stack-base) + (sap<= (int-sap control-stack-start) x) (zerop (logand (sap-int x) #b11))) #!+x86 ; stack grows toward low address values @@ -719,11 +711,10 @@ ;;; Return the top frame of the control stack as it was before calling ;;; this function. (defun top-frame () + (/show0 "entering TOP-FRAME") (multiple-value-bind (fp pc) (%caller-frame-and-pc) (possibly-an-interpreted-frame - (compute-calling-frame (descriptor-sap fp) - #!-gengc pc #!+gengc (descriptor-sap pc) - nil) + (compute-calling-frame (descriptor-sap fp) pc nil) nil))) ;;; Flush all of the frames above FRAME, and renumber all the frames @@ -738,12 +729,14 @@ ;;; 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") ;; 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* ((real (frame-real-frame frame)) (debug-fun (frame-debug-function real))) + (/show0 "in DOWN :UNPARSED case") (setf (frame-%down frame) (etypecase debug-fun (compiled-debug-function @@ -755,15 +748,9 @@ (get-context-value real sb!vm::ocfp-save-offset (sb!c::compiled-debug-function-old-fp c-d-f))) - #!-gengc (get-context-value real sb!vm::lra-save-offset (sb!c::compiled-debug-function-return-pc c-d-f)) - #!+gengc - (descriptor-sap - (get-context-value - real sb!vm::ra-save-offset - (sb!c::compiled-debug-function-return-pc c-d-f))) frame) frame))) (bogus-debug-function @@ -782,11 +769,8 @@ (sap-ref-32 fp (* sb!vm::ocfp-save-offset sb!vm:word-bytes))) - #!-gengc (stack-ref fp sb!vm::lra-save-offset) - #!+gengc - (sap-ref-sap fp (* sb!vm::ra-save-offset - sb!vm:word-bytes)) + frame))))))) down))) @@ -872,9 +856,10 @@ ;; new SBCL code, not ambitious enough to do anything tricky like ;; hiding the byte interpreter when debugging (declare (ignore up-frame)) + (/show "doing trivial POSSIBLY-AN-INTERPRETED-FRAME") frame - ;; old CMU CL code to hide IR1 interpreter when debugging + ;; old CMU CL code to hide IR1 interpreter when debugging: ;; ;;(if (or (not frame) ;; (not (eq (debug-function-name (frame-debug-function @@ -974,60 +959,70 @@ #!+x86 (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") ;; First check for an escaped frame. (multiple-value-bind (code pc-offset escaped) (find-escaped-frame caller) - (cond (code - ;; 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)) - ;; If :bogus-lra grab the real lra. - (setq pc-offset (code-header-ref - code (1+ real-lra-slot))) - (setq code (code-header-ref code real-lra-slot)) - (aver code))) - (t - ;; 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)))) - - (let ((d-fun (case code - (:undefined-function - (make-bogus-debug-function - "undefined function")) - (:foreign-function - (make-bogus-debug-function - "foreign function call land")) - ((nil) - (make-bogus-debug-function - "bogus stack frame")) - (t - (debug-function-from-pc code pc-offset))))) - (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))))) + (/show0 "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)) + ;; If :bogus-lra grab the real lra. + (setq pc-offset (code-header-ref + code (1+ real-lra-slot))) + (setq code (code-header-ref code real-lra-slot)) + (aver code))) + (t + (/show0 "in T clause") + ;; 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)))) + + (let ((d-fun (case code + (:undefined-function + (make-bogus-debug-function + "undefined function")) + (:foreign-function + (make-bogus-debug-function + "foreign function call land")) + ((nil) + (make-bogus-debug-function + "bogus stack frame")) + (t + (debug-function-from-pc code pc-offset))))) + (/show0 "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 find-escaped-frame (frame-pointer) (declare (type system-area-pointer frame-pointer)) + (/show0 "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)) + ((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") (when (= (sap-int frame-pointer) (sb!vm:context-register context sb!vm::cfp-offset)) (without-gcing + (/show0 "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") (when (null code) (return (values code 0 context))) (let* ((code-header-len (* (get-header-data code) @@ -1037,6 +1032,7 @@ (- (get-lisp-obj-address code) sb!vm:other-pointer-type) code-header-len))) + (/show "got PC-OFFSET") (unless (<= 0 pc-offset (* (code-header-ref code sb!vm:code-code-size-slot) sb!vm:word-bytes)) @@ -1046,6 +1042,7 @@ ;; 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") (return (values code pc-offset context)))))))))) @@ -1112,32 +1109,6 @@ (lra-code-header object)) (t nil)))))))) - -;;; SB!KERNEL:*SAVED-STATE-CHAIN* -- maintained by the C code as a -;;; list of SAPs, each SAP pointing to a saved exception state. -#!+gengc -(declaim (special *saved-state-chain*)) - -;;; CMU CL had -;;; (DEFUN LOOKUP-TRACE-TABLE-ENTRY (COMPONENT PC) ..) -;;; for this case, but it hasn't been maintained in SBCL. -#!+gengc -(eval-when (:compile-toplevel :load-toplevel :execute) - (error "hopelessly stale")) - -;;; CMU CL had -;;; (DEFUN EXTRACT-INFO-FROM-STATE (STATE) ..) -;;; for this case, but it hasn't been maintained in SBCL. -#!+gengc -(eval-when (:compile-toplevel :load-toplevel :execute) - (error "hopelessly stale")) - -;;; CMU CL had -;;; (DEFUN COMPUTE-CALLING-FRAME (OCFP RA UP-FRAME) ..) -;;; for this case, but it hasn't been maintained in SBCL. -#!+gengc -(eval-when (:compile-toplevel :load-toplevel :execute) - (error "hopelessly stale")) ;;;; frame utilities @@ -1197,9 +1168,7 @@ ;;; 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 - #!-gengc (descriptor-sap *current-catch-block*) - #!+gengc (mutator-current-catch-block)) + (let ((catch (descriptor-sap *current-catch-block*)) (res nil) (fp (frame-pointer (frame-real-frame frame)))) (loop @@ -1227,15 +1196,10 @@ (component (component-from-component-ptr (component-ptr-from-pc ra))) (offset - #!-(or gengc x86) + #!-x86 (* (- (1+ (get-header-data lra)) (get-header-data component)) sb!vm:word-bytes) - #!+gengc - (+ (- (sap-int ra) - (get-lisp-obj-address component) - (get-header-data component)) - sb!vm:other-pointer-type) #!+x86 (- (sap-int ra) (- (get-lisp-obj-address component) @@ -1743,8 +1707,8 @@ (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 probably be - ;; better to have #.(FIND-PACKAGE "SB!DEBUG") + ;; 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.. @@ -1756,13 +1720,15 @@ ;; 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. - "SB-DEBUG"))))) + (or (find-package "SB-DEBUG") + (find-package "SB!DEBUG"))))))) ;;; Parse the packed representation of DEBUG-VARs from ;;; DEBUG-FUNCTION's SB!C::COMPILED-DEBUG-FUNCTION, returning a vector ;;; of DEBUG-VARs, or NIL if there was no information to parse. (defun parse-compiled-debug-vars (debug-function) - (let* ((cdebug-fun (compiled-debug-function-compiler-debug-fun debug-function)) + (let* ((cdebug-fun (compiled-debug-function-compiler-debug-fun + debug-function)) (packed-vars (sb!c::compiled-debug-function-variables cdebug-fun)) (args-minimal (eq (sb!c::compiled-debug-function-arguments cdebug-fun) :minimal))) @@ -1778,7 +1744,8 @@ (let* ((flags (geti)) (minimal (logtest sb!c::compiled-debug-var-minimal-p flags)) (deleted (logtest sb!c::compiled-debug-var-deleted-p flags)) - (live (logtest sb!c::compiled-debug-var-environment-live flags)) + (live (logtest sb!c::compiled-debug-var-environment-live + flags)) (save (logtest sb!c::compiled-debug-var-save-loc-p flags)) (symbol (if minimal nil (geti))) (id (if (logtest sb!c::compiled-debug-var-id-p flags) @@ -2201,7 +2168,7 @@ (aver (typep frame 'compiled-frame)) (let ((res (access-compiled-debug-var-slot debug-var frame))) (if (indirect-value-cell-p res) - (sb!c:value-cell-ref res) + (value-cell-ref res) res))) ;; (This function used to be more interesting, with more type ;; cases here, before the IR1 interpreter went away. It might @@ -2542,7 +2509,7 @@ (aver (typep frame 'compiled-frame)) (let ((current-value (access-compiled-debug-var-slot debug-var frame))) (if (indirect-value-cell-p current-value) - (sb!c:value-cell-set current-value value) + (value-cell-set current-value value) (set-compiled-debug-var-slot debug-var frame value)))) ;; (This function used to be more interesting, with more type ;; cases here, before the IR1 interpreter went away. It might @@ -2834,7 +2801,7 @@ ;;; at BASIC-CODE-LOCATION: ;;; :VALID The value is known to be available. ;;; :INVALID The value is known to be unavailable. -;;; :UNKNOWN The value's availability is unknown." +;;; :UNKNOWN The value's availability is unknown. ;;; ;;; If the variable is always alive, then it is valid. If the ;;; code-location is unknown, then the variable's validity is @@ -2974,7 +2941,7 @@ (cons res (nthcdr (1+ n) form)))))))) (frob form path context)))) -;;;; PREPROCESS-FOR-EVAL and EVAL-IN-FRAME +;;;; PREPROCESS-FOR-EVAL ;;; Return a function of one argument that evaluates form in the ;;; lexical context of the BASIC-CODE-LOCATION LOC, or signal a @@ -3026,12 +2993,6 @@ (debug-signal 'frame-function-mismatch :code-location loc :form form :frame frame)) (funcall res frame)))))) - -;;; Evaluate FORM in the lexical context of FRAME's current code -;;; location, returning the results of the evaluation. -(defun eval-in-frame (frame form) - (declare (type frame frame)) - (funcall (preprocess-for-eval form (frame-code-location frame)) frame)) ;;;; breakpoints @@ -3151,12 +3112,10 @@ (multiple-value-bind (lra component offset) (make-bogus-lra (get-context-value frame - #!-gengc sb!vm::lra-save-offset - #!+gengc sb!vm::ra-save-offset + sb!vm::lra-save-offset lra-sc-offset)) (setf (get-context-value frame - #!-gengc sb!vm::lra-save-offset - #!+gengc sb!vm::ra-save-offset + sb!vm::lra-save-offset lra-sc-offset) lra) (let ((end-bpts (breakpoint-%info starter-bpt))) @@ -3190,8 +3149,7 @@ (when (and (compiled-frame-p frame) (eq lra (get-context-value frame - #!-gengc sb!vm::lra-save-offset - #!+gengc sb!vm::ra-save-offset + sb!vm::lra-save-offset lra-sc-offset))) (return t)))))