X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=ea6149bdde346fad8c333769331294ff2ea5af2a;hb=95f5ac2fa70b3f14d052e20f4250166f219dcc39;hp=42ab7e87f6972887a8b1c56e634d6460ac9a6088;hpb=5f338d314224411587a7cac218ea320bc982f19f;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 42ab7e8..ea6149b 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -12,9 +12,6 @@ (in-package "SB!DI") -(file-comment - "$Header$") - ;;; FIXME: There are an awful lot of package prefixes in this code. ;;; Couldn't we have SB-DI use the SB-C and SB-VM packages? @@ -41,24 +38,26 @@ () #!+sb-doc (:documentation - "All debug-conditions inherit from this type. These are serious conditions + "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 absolutely no debugging information available.") + (:documentation "There is no usable debugging information available.") (:report (lambda (condition stream) - (declare (ignore condition)) (fresh-line stream) - (write-line "No debugging information available." stream)))) + (format stream + "no debug information available for ~S~%" + (no-debug-info-code-component condition))))) (define-condition no-debug-function-returns (debug-condition) ((debug-function :reader no-debug-function-returns-debug-function :initarg :debug-function)) #!+sb-doc (:documentation - "The system could not return values from a frame with debug-function since + "The system could not return values from a frame with DEBUG-FUNCTION since it lacked information about returning values.") (:report (lambda (condition stream) (let ((fun (debug-function-function @@ -130,11 +129,11 @@ "All programmer errors from using the interface for building debugging tools inherit from this type.")) -(define-condition unhandled-condition (debug-error) - ((condition :reader unhandled-condition-condition :initarg :condition)) +(define-condition unhandled-debug-condition (debug-error) + ((condition :reader unhandled-debug-condition-condition :initarg :condition)) (:report (lambda (condition stream) (format stream "~&unhandled DEBUG-CONDITION:~%~A" - (unhandled-condition-condition condition))))) + (unhandled-debug-condition-condition condition))))) (define-condition unknown-code-location (debug-error) ((code-location :reader unknown-code-location-code-location @@ -165,20 +164,21 @@ (frame :reader frame-function-mismatch-frame :initarg :frame) (form :reader frame-function-mismatch-form :initarg :form)) (:report (lambda (condition stream) - (format stream - "~&Form was preprocessed for ~S,~% but called on ~S:~% ~S" - (frame-function-mismatch-code-location condition) - (frame-function-mismatch-frame condition) - (frame-function-mismatch-form condition))))) - -;;; This signals debug-conditions. If they go unhandled, then signal an -;;; unhandled-condition error. + (format + stream + "~&Form was preprocessed for ~S,~% but called on ~S:~% ~S" + (frame-function-mismatch-code-location condition) + (frame-function-mismatch-frame condition) + (frame-function-mismatch-form condition))))) + +;;; This signals debug-conditions. If they go unhandled, then signal +;;; an UNHANDLED-DEBUG-CONDITION error. ;;; ;;; ??? Get SIGNAL in the right package! (defmacro debug-signal (datum &rest arguments) `(let ((condition (make-condition ,datum ,@arguments))) (signal condition) - (error 'unhandled-condition :condition condition))) + (error 'unhandled-debug-condition :condition condition))) ;;;; structures ;;;; @@ -186,13 +186,14 @@ ;;;; data structures created by the compiler. Whenever comments ;;;; preface an object or type with "compiler", they refer to the ;;;; internal compiler thing, not to the object or type with the same -;;;; name in the "DI" package. +;;;; name in the "SB-DI" package. ;;;; DEBUG-VARs ;;; These exist for caching data stored in packed binary form in ;;; compiler debug-functions. Debug-functions store these. -(defstruct (debug-var (:constructor nil)) +(defstruct (debug-var (:constructor nil) + (:copier nil)) ;; the name of the variable (symbol (required-argument) :type symbol) ;; a unique integer identification relative to other variables with the same @@ -215,7 +216,8 @@ (defstruct (compiled-debug-var (:include debug-var) (:constructor make-compiled-debug-var - (symbol id alive-p sc-offset save-sc-offset))) + (symbol id alive-p sc-offset save-sc-offset)) + (:copier nil)) ;; Storage class and offset. (unexported). (sc-offset nil :type sb!c::sc-offset) ;; Storage class and offset when saved somewhere. @@ -223,14 +225,16 @@ (defstruct (interpreted-debug-var (:include debug-var (alive-p t)) - (:constructor make-interpreted-debug-var (symbol ir1-var))) + (:constructor make-interpreted-debug-var (symbol ir1-var)) + (:copier nil)) ;; This is the IR1 structure that holds information about interpreted vars. (ir1-var nil :type sb!c::lambda-var)) ;;;; frames ;;; These represent call-frames on the stack. -(defstruct (frame (:constructor nil)) +(defstruct (frame (:constructor nil) + (:copier nil)) ;; the next frame up, or NIL when top frame (up nil :type (or frame null)) ;; the previous frame down, or NIL when the bottom frame. Before @@ -272,7 +276,8 @@ (:constructor make-compiled-frame (pointer up debug-function code-location number #!+gengc saved-state-chain - &optional escaped))) + &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 @@ -295,7 +300,8 @@ (:include frame) (:constructor make-interpreted-frame (pointer up debug-function code-location number - real-frame closure))) + real-frame closure)) + (:copier nil)) ;; This points to the compiled-frame for SB!EVAL:INTERNAL-APPLY-LOOP. (real-frame nil :type compiled-frame) ;; This is the closed over data used by the interpreter. @@ -313,7 +319,7 @@ ;;; code-locations and other objects that reference DEBUG-FUNCTIONs ;;; point to unique objects. This is due to the overhead in cached ;;; information. -(defstruct debug-function +(defstruct (debug-function (:copier nil)) ;; Some representation of the function arguments. See ;; DEBUG-FUNCTION-LAMBDA-LIST. ;; NOTE: must parse vars before parsing arg list stuff. @@ -333,7 +339,8 @@ (defstruct (compiled-debug-function (:include debug-function) (:constructor %make-compiled-debug-function - (compiler-debug-fun component))) + (compiler-debug-fun component)) + (:copier nil)) ;; Compiler's dumped debug-function information. (unexported). (compiler-debug-fun nil :type sb!c::compiled-debug-function) ;; Code object. (unexported). @@ -359,7 +366,8 @@ (defstruct (interpreted-debug-function (:include debug-function) - (:constructor %make-interpreted-debug-function (ir1-lambda))) + (:constructor %make-interpreted-debug-function (ir1-lambda)) + (:copier nil)) ;; This is the IR1 lambda that this debug-function represents. (ir1-lambda nil :type sb!c::clambda)) @@ -367,7 +375,8 @@ (:include debug-function) (:constructor make-bogus-debug-function (%name &aux (%lambda-list nil) (%debug-vars nil) - (blocks nil) (%function nil)))) + (blocks nil) (%function nil))) + (:copier nil)) %name) (defvar *ir1-lambda-debug-function* (make-hash-table :test 'eq)) @@ -381,8 +390,9 @@ ;;;; DEBUG-BLOCKs ;;; These exist for caching data stored in packed binary form in compiler -;;; debug-blocks. -(defstruct (debug-block (:constructor nil)) +;;; DEBUG-BLOCKs. +(defstruct (debug-block (:constructor nil) + (:copier nil)) ;; Code-locations where execution continues after this block. (successors nil :type list) ;; This indicates whether the block is a special glob of code shared by @@ -407,14 +417,16 @@ (defstruct (compiled-debug-block (:include debug-block) (:constructor make-compiled-debug-block - (code-locations successors elsewhere-p))) - ;; Code-location information for the block. + (code-locations successors elsewhere-p)) + (:copier nil)) + ;; code-location information for the block (code-locations nil :type simple-vector)) (defstruct (interpreted-debug-block (:include debug-block (elsewhere-p nil)) (:constructor %make-interpreted-debug-block - (ir1-block))) + (ir1-block)) + (:copier nil)) ;; This is the IR1 block this debug-block represents. (ir1-block nil :type sb!c::cblock) ;; Code-location information for the block. @@ -433,7 +445,7 @@ ;;; lists of DEBUG-BLOCKs. Then look up our argument IR1-BLOCK to find ;;; its DEBUG-BLOCK since we know we have it now. (defun make-interpreted-debug-block (ir1-block) - (check-type ir1-block sb!c::cblock) + (declare (type sb!c::cblock ir1-block)) (let ((res (gethash ir1-block *ir1-block-debug-block*))) (or res (let ((lambda (sb!c::block-home-lambda ir1-block))) @@ -465,7 +477,8 @@ ;;; This is an internal structure that manages information about a ;;; breakpoint locations. See *COMPONENT-BREAKPOINT-OFFSETS*. (defstruct (breakpoint-data (:constructor make-breakpoint-data - (component offset))) + (component offset)) + (:copier nil)) ;; This is the component in which the breakpoint lies. component ;; This is the byte offset into the component. @@ -483,7 +496,8 @@ (breakpoint-data-offset obj)))) (defstruct (breakpoint (:constructor %make-breakpoint - (hook-function what kind %info))) + (hook-function 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 :FUNCTION-END breakpoints @@ -550,7 +564,8 @@ ;;;; CODE-LOCATIONs -(defstruct (code-location (:constructor nil)) +(defstruct (code-location (:constructor nil) + (:copier nil)) ;; This is the debug-function containing code-location. (debug-function nil :type debug-function) ;; This is initially :UNSURE. Upon first trying to access an @@ -586,7 +601,8 @@ (:constructor make-known-code-location (pc debug-function %tlf-offset %form-number %live-set kind &aux (%unknown-p nil))) - (:constructor make-compiled-code-location (pc debug-function))) + (:constructor make-compiled-code-location (pc debug-function)) + (:copier nil)) ;; This is an index into debug-function's component slot. (pc nil :type sb!c::index) ;; This is a bit-vector indexed by a variable's position in @@ -601,7 +617,8 @@ (:include code-location (%unknown-p nil)) (:constructor make-interpreted-code-location - (ir1-node debug-function))) + (ir1-node debug-function)) + (:copier nil)) ;; This is an index into debug-function's component slot. (ir1-node nil :type sb!c::node)) @@ -653,7 +670,7 @@ ;;;; frames -;;; This is used in FIND-ESCAPE-FRAME and with the bogus components +;;; This is used in FIND-ESCAPED-FRAME and with the bogus components ;;; and LRAs used for :function-end breakpoints. When a components ;;; debug-info slot is :bogus-lra, then the real-lra-slot contains the ;;; real component to continue executing, as opposed to the bogus @@ -735,9 +752,9 @@ ;;; XXX Should probably check whether it has reached the bottom of the ;;; stack. ;;; -;;; XXX Should handle interrupted frames, both Lisp and C. At present it -;;; manages to find a fp trail, see linux hack below. -(defun x86-call-context (fp &key (depth 8)) +;;; XXX Should handle interrupted frames, both Lisp and C. At present +;;; it manages to find a fp trail, see linux hack below. +(defun x86-call-context (fp &key (depth 0)) (declare (type system-area-pointer fp) (fixnum depth)) ;;(format t "*CC ~S ~S~%" fp depth) @@ -761,15 +778,20 @@ lisp-ocfp lisp-ra c-ocfp c-ra) ;; Look forward another step to check their validity. (let ((lisp-path-fp (x86-call-context lisp-ocfp - :depth (- depth 1))) - (c-path-fp (x86-call-context c-ocfp :depth (- depth 1)))) + :depth (1+ depth))) + (c-path-fp (x86-call-context c-ocfp :depth (1+ depth)))) (cond ((and lisp-path-fp c-path-fp) - ;; Both still seem valid - choose the smallest. - #+nil (format t "debug: both still valid ~S ~S ~S ~S~%" - lisp-ocfp lisp-ra c-ocfp c-ra) - (if (sap< lisp-ocfp c-ocfp) - (values lisp-ra lisp-ocfp) - (values c-ra c-ocfp))) + ;; Both still seem valid - choose the lisp frame. + #+nil (when (zerop depth) + (format t + "debug: both still valid ~S ~S ~S ~S~%" + lisp-ocfp lisp-ra c-ocfp c-ra)) + #+freebsd + (if (sap> lisp-ocfp c-ocfp) + (values lisp-ra lisp-ocfp) + (values c-ra c-ocfp)) + #-freebsd + (values lisp-ra lisp-ocfp)) (lisp-path-fp ;; The lisp convention is looking good. #+nil (format t "*C lisp-ocfp ~S ~S~%" lisp-ocfp lisp-ra) @@ -945,8 +967,10 @@ ;;; to replace FRAME. The interpreted frame points to FRAME. (defun possibly-an-interpreted-frame (frame up-frame) (if (or (not frame) - (not (eq (debug-function-name (frame-debug-function frame)) - 'sb!eval::internal-apply-loop)) + #!+sb-interpreter (not (eq (debug-function-name (frame-debug-function + frame)) + 'sb!eval::internal-apply-loop)) + #!-sb-interpreter t *debugging-interpreter* (compiled-frame-escaped frame)) frame @@ -1040,27 +1064,22 @@ #!+x86 (defun compute-calling-frame (caller ra up-frame) (declare (type system-area-pointer caller ra)) -; (format t "ccf: ~A ~A ~A~%" caller ra up-frame) (when (cstack-pointer-valid-p caller) -; (format t "ccf2~%") ;; 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. -; (format t "ccf2: escaped ~S ~S~%" code pc-offset) (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)) -; (format t "ccf3 :bogus-lra ~S ~S~%" code pc-offset) - (assert code))) + (aver code))) (t - ;; Not escaped + ;; not escaped (multiple-value-setq (pc-offset code) (compute-lra-data-from-pc ra)) -; (format t "ccf4 ~S ~S~%" code pc-offset) (unless code (setf code :foreign-function pc-offset 0 @@ -1084,24 +1103,17 @@ (if up-frame (1+ (frame-number up-frame)) 0) escaped))))) -#!-(or gengc x86) -;;; FIXME: The original CMU CL code had support for this case, but it -;;; must have been fairly stale even in CMU CL, since it had -;;; references to the MIPS package, and there have been enough -;;; relevant changes in SBCL (particularly using -;;; POSIX/SIGACTION0-style signal context instead of BSD-style -;;; sigcontext) that this code is unmaintainable (since as of -;;; sbcl-0.6.7, and for the foreseeable future, we can't test it, -;;; since we only support X86 and its gencgc). -;;; -;;; If we restore this case, the best approach would be to go back to -;;; the original CMU CL code and start from there. -(eval-when (:compile-toplevel :load-toplevel :execute) - (error "hopelessly stale")) #!+x86 (defun find-escaped-frame (frame-pointer) (declare (type system-area-pointer frame-pointer)) - (dotimes (index sb!impl::*free-interrupt-context-index* (values nil 0 nil)) + + ;; FIXME: These conditionals are a hack to get the system to + ;; bootstrap itself despite a byte interpreter/compiler bug. Without + ;; it, the byte interpreter blows up when trying to cross-compile + ;; this function, hitting #:UNINITIALIZED-EVAL-STACK-ELEMENT while + ;; executing (SB-XC:MACRO-FUNCTION 'SB!EXT:WITH-ALIEN). + #+sb-xc (values nil 0 nil) #-sb-xc ; REMOVEME + (dotimes (index *free-interrupt-context-index* (values nil 0 nil)) (sb!alien:with-alien ((lisp-interrupt-contexts (array (* os-context-t) nil) :extern)) @@ -1111,9 +1123,8 @@ (without-gcing (let* ((component-ptr (component-ptr-from-pc (sb!vm:context-pc context))) - (code (if (sap= component-ptr (int-sap #x0)) - nil ; FIXME: UNLESS might be clearer than IF. - (component-from-component-ptr component-ptr)))) + (code (unless (sap= component-ptr (int-sap #x0)) + (component-from-component-ptr component-ptr)))) (when (null code) (return (values code 0 context))) (let* ((code-header-len (* (get-header-data code) @@ -1126,13 +1137,59 @@ (unless (<= 0 pc-offset (* (code-header-ref code sb!vm:code-code-size-slot) sb!vm:word-bytes)) - ;; We were in an assembly routine. Therefore, use the LRA as - ;; the pc. + ;; We were in an assembly routine. Therefore, use the + ;; LRA as the pc. + ;; + ;; FIXME: Should this be WARN or ERROR or what? (format t "** pc-offset ~S not in code obj ~S?~%" pc-offset code)) (return (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:word-bytes)) + (pc-offset + (- (sap-int (sb!vm:context-pc scp)) + (- (get-lisp-obj-address code) + sb!vm:other-pointer-type) + 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:word-bytes)) + (unless (<= 0 pc-offset + (* (code-header-ref code sb!vm:code-code-size-slot) + sb!vm: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 ;;; undefined-function. @@ -1190,7 +1247,7 @@ (let ((info (%code-debug-info component))) (cond ((not info) - (debug-signal 'no-debug-info)) + (debug-signal 'no-debug-info :code-component component)) ((eq info :bogus-lra) (make-bogus-debug-function "function end breakpoint")) (t @@ -1203,8 +1260,7 @@ (elsewhere-p (>= pc (sb!c::compiled-debug-function-elsewhere-pc (svref function-map 0))))) - ;; FIXME: I don't think SB!C is the home package of INDEX. - (declare (type sb!c::index i)) + (declare (type sb!int:index i)) (loop (when (or (= i len) (< pc (if elsewhere-p @@ -1240,7 +1296,7 @@ code-locations at which execution would continue with frame as the top frame if someone threw to the corresponding tag." (let ((catch - #!-gengc (descriptor-sap sb!impl::*current-catch-block*) + #!-gengc (descriptor-sap *current-catch-block*) #!+gengc (mutator-current-catch-block)) (res nil) (fp (frame-pointer (frame-real-frame frame)))) @@ -1311,14 +1367,14 @@ ;;;; operations on DEBUG-FUNCTIONs +;;; Execute the forms in a context with block-var bound to each +;;; debug-block in debug-function successively. Result is an optional +;;; form to execute for return values, and DO-DEBUG-FUNCTION-BLOCKS +;;; returns nil if there is no result form. This signals a +;;; no-debug-blocks condition when the debug-function lacks +;;; debug-block information. (defmacro do-debug-function-blocks ((block-var debug-function &optional result) &body body) - #!+sb-doc - "Executes the forms in a context with block-var bound to each debug-block in - debug-function successively. Result is an optional form to execute for - return values, and DO-DEBUG-FUNCTION-BLOCKS returns nil if there is no - result form. This signals a no-debug-blocks condition when the - debug-function lacks debug-block information." (let ((blocks (gensym)) (i (gensym))) `(let ((,blocks (debug-function-debug-blocks ,debug-function))) @@ -1327,14 +1383,13 @@ (let ((,block-var (svref ,blocks ,i))) ,@body))))) +;;; Execute body in a context with var bound to each debug-var in +;;; debug-function. This returns the value of executing result (defaults to +;;; nil). This may iterate over only some of debug-function's variables or none +;;; depending on debug policy; for example, possibly the compilation only +;;; preserved argument information. (defmacro do-debug-function-variables ((var debug-function &optional result) &body body) - #!+sb-doc - "Executes body in a context with var bound to each debug-var in - debug-function. This returns the value of executing result (defaults to - nil). This may iterate over only some of debug-function's variables or none - depending on debug policy; for example, possibly the compilation only - preserved argument information." (let ((vars (gensym)) (i (gensym))) `(let ((,vars (debug-function-debug-vars ,debug-function))) @@ -1345,11 +1400,10 @@ ,@body)) ,result)))) +;;; Return the Common Lisp function associated with the debug-function. This +;;; returns nil if the function is unavailable or is non-existent as a user +;;; callable function object. (defun debug-function-function (debug-function) - #!+sb-doc - "Returns the Common Lisp function associated with the debug-function. This - returns nil if the function is unavailable or is non-existent as a user - callable function object." (let ((cached-value (debug-function-%function debug-function))) (if (eq cached-value :unparsed) (setf (debug-function-%function debug-function) @@ -1376,10 +1430,9 @@ (bogus-debug-function nil))) cached-value))) +;;; Return the name of the function represented by debug-function. This may +;;; be a string or a cons; do not assume it is a symbol. (defun debug-function-name (debug-function) - #!+sb-doc - "Returns the name of the function represented by debug-function. This may - be a string or a cons; do not assume it is a symbol." (etypecase debug-function (compiled-debug-function (sb!c::compiled-debug-function-name @@ -1390,14 +1443,14 @@ (bogus-debug-function (bogus-debug-function-%name debug-function)))) +;;; Return a debug-function that represents debug information for function. (defun function-debug-function (fun) - #!+sb-doc - "Returns a debug-function that represents debug information for function." (case (get-type fun) (#.sb!vm:closure-header-type (function-debug-function (%closure-function fun))) (#.sb!vm:funcallable-instance-header-type - (cond ((sb!eval:interpreted-function-p fun) + (cond #!+sb-interpreter + ((sb!eval:interpreted-function-p fun) (make-interpreted-debug-function (or (sb!eval::interpreted-function-definition fun) (sb!eval::convert-interpreted-fun fun)))) @@ -1428,10 +1481,9 @@ (get-header-data component)) sb!vm:word-bytes))))))) +;;; Return the kind of the function, which is one of :OPTIONAL, +;;; :EXTERNAL, TOP-level, :CLEANUP, or NIL. (defun debug-function-kind (debug-function) - #!+sb-doc - "Returns the kind of the function which is one of :OPTIONAL, :EXTERNAL, - :TOP-level, :CLEANUP, or NIL." ;; FIXME: This "is one of" information should become part of the function ;; declamation, not just a doc string (etypecase debug-function @@ -1444,19 +1496,17 @@ (bogus-debug-function nil))) +;;; Is there any variable information for DEBUG-FUNCTION? (defun debug-var-info-available (debug-function) - #!+sb-doc - "Is there any variable information for DEBUG-FUNCTION?" (not (not (debug-function-debug-vars debug-function)))) +;;; Return a list of debug-vars in debug-function having the same name +;;; and package as symbol. If symbol is uninterned, then this returns +;;; a list of debug-vars without package names and with the same name +;;; as symbol. The result of this function is limited to the +;;; availability of variable information in debug-function; for +;;; example, possibly DEBUG-FUNCTION only knows about its arguments. (defun debug-function-symbol-variables (debug-function symbol) - #!+sb-doc - "Returns a list of debug-vars in debug-function having the same name - and package as symbol. If symbol is uninterned, then this returns a list of - debug-vars without package names and with the same name as symbol. The - result of this function is limited to the availability of variable - information in debug-function; for example, possibly debug-function only - knows about its arguments." (let ((vars (ambiguous-debug-vars debug-function (symbol-name symbol))) (package (and (symbol-package symbol) (package-name (symbol-package symbol))))) @@ -1469,11 +1519,12 @@ (stringp (debug-var-package-name var)))) vars))) +;;; Return a list of debug-vars in debug-function whose names contain +;;; name-prefix-string as an intial substring. The result of this +;;; function is limited to the availability of variable information in +;;; debug-function; for example, possibly debug-function only knows +;;; about its arguments. (defun ambiguous-debug-vars (debug-function name-prefix-string) - "Returns a list of debug-vars in debug-function whose names contain - name-prefix-string as an intial substring. The result of this function is - limited to the availability of variable information in debug-function; for - example, possibly debug-function only knows about its arguments." (declare (simple-string name-prefix-string)) (let ((variables (debug-function-debug-vars debug-function))) (declare (type (or null simple-vector) variables)) @@ -1514,24 +1565,25 @@ (string= x y :end1 name-len :end2 name-len)))) :end (or end (length variables))))) +;;; Return a list representing the lambda-list for DEBUG-FUNCTION. The +;;; list has the following structure: +;;; (required-var1 required-var2 +;;; ... +;;; (:optional var3 suppliedp-var4) +;;; (:optional var5) +;;; ... +;;; (:rest var6) (:rest var7) +;;; ... +;;; (:keyword keyword-symbol var8 suppliedp-var9) +;;; (:keyword keyword-symbol var10) +;;; ... +;;; ) +;;; Each VARi is a DEBUG-VAR; however it may be the symbol :DELETED if +;;; it is unreferenced in DEBUG-FUNCTION. This signals a +;;; LAMBDA-LIST-UNAVAILABLE condition when there is no argument list +;;; information. (defun debug-function-lambda-list (debug-function) #!+sb-doc - "Returns a list representing the lambda-list for debug-function. The list - has the following structure: - (required-var1 required-var2 - ... - (:optional var3 suppliedp-var4) - (:optional var5) - ... - (:rest var6) (:rest var7) - ... - (:keyword keyword-symbol var8 suppliedp-var9) - (:keyword keyword-symbol var10) - ... - ) - Each VARi is a DEBUG-VAR; however it may be the symbol :deleted it - is unreferenced in debug-function. This signals a lambda-list-unavailable - condition when there is no argument list information." (etypecase debug-function (compiled-debug-function (compiled-debug-function-lambda-list debug-function)) @@ -1576,7 +1628,7 @@ (push (frob final-arg debug-vars) res)) (:keyword (push (list :keyword - (sb!c::arg-info-keyword info) + (sb!c::arg-info-key info) (frob final-arg debug-vars)) res)) (:rest @@ -1677,11 +1729,11 @@ res)) (sb!c::more-arg ;; Just ignore the fact that the next two args are - ;; the more arg context and count, and act like they + ;; the &MORE arg context and count, and act like they ;; are regular arguments. nil) (t - ;; keyword arg + ;; &KEY arg (push (list :keyword ele (compiled-debug-function-lambda-list-var @@ -1812,7 +1864,7 @@ (let* ((locations (dotimes (k (sb!c::read-var-integer blocks i) (result locations-buffer)) - (let ((kind (svref sb!c::compiled-code-location-kinds + (let ((kind (svref sb!c::*compiled-code-location-kinds* (aref+ blocks i))) (pc (+ last-pc (sb!c::read-var-integer blocks i))) @@ -1971,7 +2023,7 @@ 0)) (sc-offset (if deleted 0 (geti))) (save-sc-offset (if save (geti) nil))) - (assert (not (and args-minimal (not minimal)))) + (aver (not (and args-minimal (not minimal)))) (vector-push-extend (make-compiled-debug-var symbol id live @@ -2002,7 +2054,7 @@ (if (logtest flags sb!c::minimal-debug-function-setf-bit) `(setf ,base) base)) - :kind (svref sb!c::minimal-debug-function-kinds + :kind (svref sb!c::*minimal-debug-function-kinds* (ldb sb!c::minimal-debug-function-kind-byte options)) :variables (when vars-p @@ -2066,14 +2118,14 @@ (coerce (cdr (res)) 'simple-vector)))) -;;; This variable maps minimal debug-info function maps to an unpacked -;;; version thereof. +;;; a map from minimal DEBUG-INFO function maps to unpacked +;;; versions thereof (defvar *uncompacted-function-maps* (make-hash-table :test 'eq)) -;;; Return a function-map for a given compiled-debug-info object. If +;;; Return a FUNCTION-MAP for a given COMPILED-DEBUG-info object. If ;;; the info is minimal, and has not been parsed, then parse it. ;;; -;;; FIXME: Now that we no longer use the minimal-debug-function +;;; FIXME: Now that we no longer use the MINIMAL-DEBUG-FUNCTION ;;; representation, calls to this function can be replaced by calls to ;;; the bare COMPILED-DEBUG-INFO-FUNCTION-MAP slot accessor function, ;;; and this function and everything it calls become dead code which @@ -2089,17 +2141,14 @@ ;;;; CODE-LOCATIONs -;;; If we're sure of whether code-location is known, return t or nil. -;;; If we're :unsure, then try to fill in the code-location's slots. +;;; If we're sure of whether code-location is known, return T or NIL. +;;; If we're :UNSURE, then try to fill in the code-location's slots. ;;; This determines whether there is any debug-block information, and ;;; if code-location is known. ;;; ;;; ??? IF this conses closures every time it's called, then break off the -;;; :unsure part to get the HANDLER-CASE into another function. +;;; :UNSURE part to get the HANDLER-CASE into another function. (defun code-location-unknown-p (basic-code-location) - #!+sb-doc - "Returns whether basic-code-location is unknown. It returns nil when the - code-location is known." (ecase (code-location-%unknown-p basic-code-location) ((t) t) ((nil) nil) @@ -2108,11 +2157,10 @@ (handler-case (not (fill-in-code-location basic-code-location)) (no-debug-blocks () t)))))) +;;; Return the DEBUG-BLOCK containing code-location if it is available. +;;; Some debug policies inhibit debug-block information, and if none +;;; is available, then this signals a NO-DEBUG-BLOCKS condition. (defun code-location-debug-block (basic-code-location) - #!+sb-doc - "Returns the debug-block containing code-location if it is available. Some - debug policies inhibit debug-block information, and if none is available, - then this signals a no-debug-blocks condition." (let ((block (code-location-%debug-block basic-code-location))) (if (eq block :unparsed) (etypecase basic-code-location @@ -2125,10 +2173,10 @@ (interpreted-code-location-ir1-node basic-code-location)))))) block))) -;;; This stores and returns BASIC-CODE-LOCATION's debug-block. It -;;; determines the correct one using the code-location's pc. This uses +;;; Store and return BASIC-CODE-LOCATION's debug-block. We determines +;;; the correct one using the code-location's pc. We use ;;; DEBUG-FUNCTION-DEBUG-BLOCKS to return the cached block information -;;; or signal a 'no-debug-blocks condition. The blocks are sorted by +;;; or signal a NO-DEBUG-BLOCKS condition. The blocks are sorted by ;;; their first code-location's pc, in ascending order. Therefore, as ;;; soon as we find a block that starts with a pc greater than ;;; basic-code-location's pc, we know the previous block contains the @@ -2279,8 +2327,8 @@ (let ((live-set (compiled-code-location-%live-set code-location))) (cond ((eq live-set :unparsed) (unless (fill-in-code-location code-location) - ;; This check should be unnecessary. We're missing debug info - ;; the compiler should have dumped. + ;; This check should be unnecessary. We're missing + ;; debug info the compiler should have dumped. ;; ;; FIXME: This error and comment happen over and over again. ;; Make them a shared function. @@ -2288,9 +2336,8 @@ (compiled-code-location-%live-set code-location)) (t live-set))))) +;;; true if OBJ1 and OBJ2 are the same place in the code (defun code-location= (obj1 obj2) - #!+sb-doc - "Returns whether obj1 and obj2 are the same place in the code." (etypecase obj1 (compiled-code-location (etypecase obj2 @@ -2311,7 +2358,7 @@ (= (compiled-code-location-pc obj1) (compiled-code-location-pc obj2))) -;;; This fills in CODE-LOCATION's :unparsed slots. It returns t or nil +;;; Fill in CODE-LOCATION's :UNPARSED slots, returning T or NIL ;;; depending on whether the code-location was known in its ;;; debug-function's debug-block information. This may signal a ;;; NO-DEBUG-BLOCKS condition due to DEBUG-FUNCTION-DEBUG-BLOCKS, and @@ -2419,13 +2466,14 @@ invalid. This is SETF'able." (etypecase debug-var (compiled-debug-var - (check-type frame compiled-frame) + (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) res))) + #!+sb-interpreter (interpreted-debug-var - (check-type frame interpreted-frame) + (aver (typep frame 'interpreted-frame)) (sb!eval::leaf-value-lambda-var (interpreted-code-location-ir1-node (frame-code-location frame)) (interpreted-debug-var-ir1-var debug-var) @@ -2436,16 +2484,17 @@ ;;; DEBUG-VAR relative to the FRAME. This may be an indirect value ;;; cell if the variable is both closed over and set. (defun access-compiled-debug-var-slot (debug-var frame) + (declare (optimize (speed 1))) (let ((escaped (compiled-frame-escaped frame))) (if escaped - (sub-access-debug-var-slot - (frame-pointer frame) - (compiled-debug-var-sc-offset debug-var) - escaped) - (sub-access-debug-var-slot - (frame-pointer frame) - (or (compiled-debug-var-save-sc-offset debug-var) - (compiled-debug-var-sc-offset debug-var)))))) + (sub-access-debug-var-slot + (frame-pointer frame) + (compiled-debug-var-sc-offset debug-var) + escaped) + (sub-access-debug-var-slot + (frame-pointer frame) + (or (compiled-debug-var-save-sc-offset debug-var) + (compiled-debug-var-sc-offset debug-var)))))) ;;; a helper function for working with possibly-invalid values: ;;; Do (MAKE-LISP-OBJ VAL) only if the value looks valid. @@ -2455,7 +2504,7 @@ ;;; those variables are invalid.) (defun make-valid-lisp-obj (val) (/show0 "entering MAKE-VALID-LISP-OBJ, VAL=..") - #!+sb-show (%primitive print (sb!impl::hexstr val)) + #!+sb-show (/hexstr val) (if (or ;; fixnum (zerop (logand val 3)) @@ -2480,27 +2529,161 @@ (make-lisp-obj val) :invalid-object)) -;;; CMU CL had -;;; (DEFUN SUB-ACCESS-DEBUG-VAR-SLOT (FP SC-OFFSET &OPTIONAL ESCAPED) ..) -;;; code for this case. #!-x86 -(eval-when (:compile-toplevel :load-toplevel :execute) - (error "hopelessly stale")) +(defun sub-access-debug-var-slot (fp sc-offset &optional escaped) + (macrolet ((with-escaped-value ((var) &body forms) + `(if escaped + (let ((,var (sb!vm:context-register + escaped + (sb!c:sc-offset-offset sc-offset)))) + ,@forms) + :invalid-value-for-unescaped-register-storage)) + (escaped-float-value (format) + `(if escaped + (sb!vm:context-float-register + escaped + (sb!c:sc-offset-offset sc-offset) + ',format) + :invalid-value-for-unescaped-register-storage)) + (with-nfp ((var) &body body) + `(let ((,var (if escaped + (sb!sys:int-sap + (sb!vm:context-register escaped + sb!vm::nfp-offset)) + #!-alpha + (sb!sys:sap-ref-sap fp (* sb!vm::nfp-save-offset + sb!vm:word-bytes)) + #!+alpha + (sb!vm::make-number-stack-pointer + (sb!sys:sap-ref-32 fp (* sb!vm::nfp-save-offset + sb!vm:word-bytes)))))) + ,@body))) + (ecase (sb!c:sc-offset-scn sc-offset) + ((#.sb!vm:any-reg-sc-number + #.sb!vm:descriptor-reg-sc-number + #!+rt #.sb!vm:word-pointer-reg-sc-number) + (sb!sys:without-gcing + (with-escaped-value (val) (sb!kernel:make-lisp-obj val)))) + + (#.sb!vm:base-char-reg-sc-number + (with-escaped-value (val) + (code-char val))) + (#.sb!vm:sap-reg-sc-number + (with-escaped-value (val) + (sb!sys:int-sap val))) + (#.sb!vm:signed-reg-sc-number + (with-escaped-value (val) + (if (logbitp (1- sb!vm:word-bits) val) + (logior val (ash -1 sb!vm:word-bits)) + val))) + (#.sb!vm:unsigned-reg-sc-number + (with-escaped-value (val) + val)) + (#.sb!vm:non-descriptor-reg-sc-number + (error "Local non-descriptor register access?")) + (#.sb!vm:interior-reg-sc-number + (error "Local interior register access?")) + (#.sb!vm:single-reg-sc-number + (escaped-float-value single-float)) + (#.sb!vm:double-reg-sc-number + (escaped-float-value double-float)) + #!+long-float + (#.sb!vm:long-reg-sc-number + (escaped-float-value long-float)) + (#.sb!vm:complex-single-reg-sc-number + (if escaped + (complex + (sb!vm:context-float-register + escaped (sb!c:sc-offset-offset sc-offset) 'single-float) + (sb!vm:context-float-register + escaped (1+ (sb!c:sc-offset-offset sc-offset)) 'single-float)) + :invalid-value-for-unescaped-register-storage)) + (#.sb!vm:complex-double-reg-sc-number + (if escaped + (complex + (sb!vm:context-float-register + escaped (sb!c:sc-offset-offset sc-offset) 'double-float) + (sb!vm:context-float-register + escaped (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 2 #-sparc 1) + 'double-float)) + :invalid-value-for-unescaped-register-storage)) + #!+long-float + (#.sb!vm:complex-long-reg-sc-number + (if escaped + (complex + (sb!vm:context-float-register + escaped (sb!c:sc-offset-offset sc-offset) 'long-float) + (sb!vm:context-float-register + escaped (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4) + 'long-float)) + :invalid-value-for-unescaped-register-storage)) + (#.sb!vm:single-stack-sc-number + (with-nfp (nfp) + (sb!sys:sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset) + sb!vm:word-bytes)))) + (#.sb!vm:double-stack-sc-number + (with-nfp (nfp) + (sb!sys:sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset) + sb!vm:word-bytes)))) + #!+long-float + (#.sb!vm:long-stack-sc-number + (with-nfp (nfp) + (sb!sys:sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset) + sb!vm:word-bytes)))) + (#.sb!vm:complex-single-stack-sc-number + (with-nfp (nfp) + (complex + (sb!sys:sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset) + sb!vm:word-bytes)) + (sb!sys:sap-ref-single nfp (* (1+ (sb!c:sc-offset-offset sc-offset)) + sb!vm:word-bytes))))) + (#.sb!vm:complex-double-stack-sc-number + (with-nfp (nfp) + (complex + (sb!sys:sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset) + sb!vm:word-bytes)) + (sb!sys:sap-ref-double nfp (* (+ (sb!c:sc-offset-offset sc-offset) 2) + sb!vm:word-bytes))))) + #!+long-float + (#.sb!vm:complex-long-stack-sc-number + (with-nfp (nfp) + (complex + (sb!sys:sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset) + sb!vm:word-bytes)) + (sb!sys:sap-ref-long nfp (* (+ (sb!c:sc-offset-offset sc-offset) + #!+sparc 4) + sb!vm: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 + (with-nfp (nfp) + (code-char (sb!sys:sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset) + sb!vm:word-bytes))))) + (#.sb!vm:unsigned-stack-sc-number + (with-nfp (nfp) + (sb!sys:sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset) + sb!vm:word-bytes)))) + (#.sb!vm:signed-stack-sc-number + (with-nfp (nfp) + (sb!sys:signed-sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset) + sb!vm:word-bytes)))) + (#.sb!vm:sap-stack-sc-number + (with-nfp (nfp) + (sb!sys:sap-ref-sap nfp (* (sb!c:sc-offset-offset sc-offset) + sb!vm:word-bytes))))))) #!+x86 (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=..") - #!+sb-show (%primitive print (sb!impl::hexstr fp)) - #!+sb-show (%primitive print (sb!impl::hexstr sc-offset)) - #!+sb-show (%primitive print (sb!impl::hexstr 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=..") - #!+sb-show (%primitive print (sb!impl::hexstr ,var)) + (/hexstr ,var) ,@forms) :invalid-value-for-unescaped-register-storage)) (escaped-float-value (format) @@ -2522,7 +2705,7 @@ (without-gcing (with-escaped-value (val) (/show0 "VAL=..") - #!+sb-show (%primitive print (sb!impl::hexstr val)) + (/hexstr val) (make-valid-lisp-obj val)))) (#.sb!vm:base-char-reg-sc-number (/show0 "case of BASE-CHAR-REG-SC-NUMBER") @@ -2627,13 +2810,14 @@ (defun %set-debug-var-value (debug-var frame value) (etypecase debug-var (compiled-debug-var - (check-type frame compiled-frame) + (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) (set-compiled-debug-var-slot debug-var frame value)))) + #!+sb-interpreter (interpreted-debug-var - (check-type frame interpreted-frame) + (aver (typep frame 'interpreted-frame)) (sb!eval::set-leaf-value-lambda-var (interpreted-code-location-ir1-node (frame-code-location frame)) (interpreted-debug-var-ir1-var debug-var) @@ -2682,13 +2866,13 @@ sb!vm::nfp-offset)) #!-alpha (sap-ref-sap fp - (* sb!vm::nfp-save-offset - sb!vm:word-bytes)) + (* sb!vm::nfp-save-offset + sb!vm:word-bytes)) #!+alpha - (%alpha::make-number-stack-pointer + (sb!vm::make-number-stack-pointer (sap-ref-32 fp - (* sb!vm::nfp-save-offset - sb!vm:word-bytes)))))) + (* sb!vm::nfp-save-offset + sb!vm:word-bytes)))))) ,@body))) (ecase (sb!c:sc-offset-scn sc-offset) ((#.sb!vm:any-reg-sc-number @@ -2934,7 +3118,7 @@ (compiled-debug-var (compiled-debug-var-validity debug-var basic-code-location)) (interpreted-debug-var - (check-type basic-code-location interpreted-code-location) + (aver (typep basic-code-location 'interpreted-code-location)) (let ((validp (rassoc (interpreted-debug-var-ir1-var debug-var) (sb!c::lexenv-variables (sb!c::node-lexenv @@ -2945,7 +3129,7 @@ ;;; This is the method for DEBUG-VAR-VALIDITY for COMPILED-DEBUG-VARs. ;;; For safety, make sure basic-code-location is what we think. (defun compiled-debug-var-validity (debug-var basic-code-location) - (check-type basic-code-location compiled-code-location) + (declare (type compiled-code-location basic-code-location)) (cond ((debug-var-alive-p debug-var) (let ((debug-fun (code-location-debug-function basic-code-location))) (if (>= (compiled-code-location-pc basic-code-location) @@ -2957,14 +3141,16 @@ (t (let ((pos (position debug-var (debug-function-debug-vars - (code-location-debug-function basic-code-location))))) + (code-location-debug-function + basic-code-location))))) (unless pos (error 'unknown-debug-var :debug-var debug-var :debug-function (code-location-debug-function basic-code-location))) ;; There must be live-set info since basic-code-location is known. - (if (zerop (sbit (compiled-code-location-live-set basic-code-location) + (if (zerop (sbit (compiled-code-location-live-set + basic-code-location) pos)) :invalid :valid))))) @@ -2988,21 +3174,21 @@ ;;; Given the DEFUN, 3 gets you the LET, 1 gets you the bindings, 0 ;;; gets the first binding, and 1 gets the AREF form. -;;; Temporary buffer used to build form-number => source-path translation in -;;; FORM-NUMBER-TRANSLATIONS. +;;; temporary buffer used to build form-number => source-path translation in +;;; FORM-NUMBER-TRANSLATIONS (defvar *form-number-temp* (make-array 10 :fill-pointer 0 :adjustable t)) -;;; Table used to detect CAR circularities in FORM-NUMBER-TRANSLATIONS. +;;; 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. +;;; ;;; The vector elements are in the same format as the compiler's -;;; NODE-SOUCE-PATH; that is, the first element is the form number and the last -;;; is the top-level-form number. +;;; NODE-SOURCE-PATH; that is, the first element is the form number and +;;; the last is the top-level-form number. (defun form-number-translations (form tlf-number) - #!+sb-doc - "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." (clrhash *form-number-circularity-table*) (setf (fill-pointer *form-number-temp*) 0) (sub-translate-form-numbers form (list tlf-number)) @@ -3030,13 +3216,13 @@ (frob) (setq trail (cdr trail))))))) +;;; 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 +;;; contains a marker, #:****HERE****, immediately before the form +;;; indicated by path. (defun source-path-context (form path context) - #!+sb-doc - "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 contains a marker, #:****HERE****, - immediately before the form indicated by path." (declare (type unsigned-byte context)) ;; Get to the form indicated by path or the enclosing form indicated ;; by context and path. @@ -3068,17 +3254,15 @@ ;;;; PREPROCESS-FOR-EVAL and EVAL-IN-FRAME -;;; Create a SYMBOL-MACROLET for each variable valid at the location which -;;; accesses that variable from the frame argument. +;;; Return a function of one argument that evaluates form in the +;;; lexical context of the basic-code-location loc. +;;; PREPROCESS-FOR-EVAL signals a no-debug-vars condition when the +;;; loc's debug-function has no debug-var information available. The +;;; returned function takes the frame to get values from as its +;;; argument, and it returns the values of form. The returned function +;;; signals the following conditions: invalid-value, +;;; ambiguous-variable-name, and frame-function-mismatch. (defun preprocess-for-eval (form loc) - #!+sb-doc - "Return a function of one argument that evaluates form in the lexical - context of the basic-code-location loc. PREPROCESS-FOR-EVAL signals a - no-debug-vars condition when the loc's debug-function has no - debug-var information available. The returned function takes the frame - to get values from as its argument, and it returns the values of form. - The returned function signals the following conditions: invalid-value, - ambiguous-variable-name, and frame-function-mismatch" (declare (type code-location loc)) (let ((n-frame (gensym)) (fun (code-location-debug-function loc))) @@ -3120,49 +3304,53 @@ :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)) - #!+sb-doc - "Evaluate Form in the lexical context of Frame's current code location, - returning the results of the evaluation." (funcall (preprocess-for-eval form (frame-code-location frame)) frame)) ;;;; breakpoints ;;;; 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. +;;; +;;; WHAT and KIND determine where in a function the system invokes +;;; HOOK-FUNCTION. WHAT is either a code-location or a debug-function. +;;; KIND is one of :CODE-LOCATION, :FUNCTION-START, or :FUNCTION-END. +;;; Since the starts and ends of functions may not have code-locations +;;; representing them, designate these places by supplying WHAT as a +;;; debug-function and KIND indicating the :FUNCTION-START or +;;; :FUNCTION-END. When WHAT is a debug-function and kind is +;;; :FUNCTION-END, then hook-function must take two additional +;;; arguments, a list of values returned by the function and a +;;; FUNCTION-END-COOKIE. +;;; +;;; INFO is information supplied by and used by the user. +;;; +;;; FUNCTION-END-COOKIE is a function. To implement :FUNCTION-END +;;; breakpoints, the system uses starter breakpoints to establish the +;;; :FUNCTION-END breakpoint for each invocation of the function. Upon +;;; each entry, the system creates a unique cookie to identify the +;;; invocation, and when the user supplies a function for this +;;; argument, the system invokes it on the frame and the cookie. The +;;; system later invokes the :FUNCTION-END breakpoint hook on the same +;;; cookie. The user may save the cookie for comparison in the hook +;;; function. +;;; +;;; Signal an error if WHAT is an unknown code-location. (defun make-breakpoint (hook-function what &key (kind :code-location) info function-end-cookie) - #!+sb-doc - "This creates and returns 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. - What and kind determine where in a function the system invokes - hook-function. What is either a code-location or a debug-function. Kind is - one of :code-location, :function-start, or :function-end. Since the starts - and ends of functions may not have code-locations representing them, - designate these places by supplying what as a debug-function and kind - indicating the :function-start or :function-end. When what is a - debug-function and kind is :function-end, then hook-function must take two - additional arguments, a list of values returned by the function and a - function-end-cookie. - Info is information supplied by and used by the user. - Function-end-cookie is a function. To implement :function-end breakpoints, - the system uses starter breakpoints to establish the :function-end breakpoint - for each invocation of the function. Upon each entry, the system creates a - unique cookie to identify the invocation, and when the user supplies a - function for this argument, the system invokes it on the frame and the - cookie. The system later invokes the :function-end breakpoint hook on the - same cookie. The user may save the cookie for comparison in the hook - function. - This signals an error if what is an unknown code-location." (etypecase what (code-location (when (code-location-unknown-p what) (error "cannot make a breakpoint at an unknown code location: ~S" what)) - (assert (eq kind :code-location)) + (aver (eq kind :code-location)) (let ((bpt (%make-breakpoint hook-function what kind info))) (etypecase what (interpreted-code-location @@ -3210,13 +3398,14 @@ (defstruct (function-end-cookie (:print-object (lambda (obj str) (print-unreadable-object (obj str :type t)))) - (:constructor make-function-end-cookie (bogus-lra debug-fun))) - ;; This is a pointer to the bogus-lra created for :function-end bpts. + (:constructor make-function-end-cookie (bogus-lra debug-fun)) + (:copier nil)) + ;; a pointer to the bogus-lra created for :FUNCTION-END breakpoints bogus-lra - ;; This is the debug-function associated with the cookie. + ;; the debug-function associated with the cookie debug-fun) -;;; This maps bogus-lra-components to cookies, so +;;; This maps bogus-lra-components to cookies, so that ;;; HANDLE-FUNCTION-END-BREAKPOINT can find the appropriate cookie for the ;;; breakpoint hook. (defvar *function-end-cookies* (make-hash-table :test 'eq)) @@ -3259,16 +3448,17 @@ (let ((fun (breakpoint-cookie-fun bpt))) (when fun (funcall fun frame cookie)))))))))) +;;; This takes a FUNCTION-END-COOKIE and a frame, and it returns +;;; whether the cookie is still valid. A cookie becomes invalid when +;;; the frame that established the cookie has exited. Sometimes cookie +;;; holders are unaware of cookie invalidation because their +;;; :FUNCTION-END breakpoint hooks didn't run due to THROW'ing. +;;; +;;; This takes a frame as an efficiency hack since the user probably +;;; has a frame object in hand when using this routine, and it saves +;;; repeated parsing of the stack and consing when asking whether a +;;; series of cookies is valid. (defun function-end-cookie-valid-p (frame cookie) - #!+sb-doc - "This takes a function-end-cookie and a frame, and it returns whether the - cookie is still valid. A cookie becomes invalid when the frame that - established the cookie has exited. Sometimes cookie holders are unaware - of cookie invalidation because their :function-end breakpoint hooks didn't - run due to THROW'ing. This takes a frame as an efficiency hack since the - user probably has a frame object in hand when using this routine, and it - saves repeated parsing of the stack and consing when asking whether a - series of cookies is valid." (let ((lra (function-end-cookie-bogus-lra cookie)) (lra-sc-offset (sb!c::compiled-debug-function-return-pc (compiled-debug-function-compiler-debug-fun @@ -3282,14 +3472,14 @@ #!+gengc sb!vm::ra-save-offset lra-sc-offset))) (return t))))) - + ;;;; ACTIVATE-BREAKPOINT +;;; 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. (defun activate-breakpoint (breakpoint) - #!+sb-doc - "This causes 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." (when (eq (breakpoint-status breakpoint) :deleted) (error "cannot activate a deleted breakpoint: ~S" breakpoint)) (unless (eq (breakpoint-status breakpoint) :active) @@ -3316,7 +3506,7 @@ (compiled-debug-function (let ((starter (breakpoint-start-helper breakpoint))) (unless (eq (breakpoint-status starter) :active) - ;; May already be active by some other :function-end breakpoint. + ;; may already be active by some other :FUNCTION-END breakpoint (activate-compiled-function-start-breakpoint starter))) (setf (breakpoint-status breakpoint) :active)) (interpreted-debug-function @@ -3364,7 +3554,7 @@ (setf (breakpoint-data-breakpoints data) (append (breakpoint-data-breakpoints data) (list breakpoint))) (setf (breakpoint-internal-data breakpoint) data))) - + ;;;; DEACTIVATE-BREAKPOINT (defun deactivate-breakpoint (breakpoint) @@ -3405,7 +3595,7 @@ (delete-breakpoint-data data)))) (setf (breakpoint-status breakpoint) :inactive) breakpoint) - + ;;;; BREAKPOINT-INFO (defun breakpoint-info (breakpoint) @@ -3418,7 +3608,7 @@ (let ((other (breakpoint-unknown-return-partner breakpoint))) (when other (setf (breakpoint-%info other) value)))) - + ;;;; BREAKPOINT-ACTIVE-P and DELETE-BREAKPOINT (defun breakpoint-active-p (breakpoint) @@ -3452,7 +3642,7 @@ (breakpoint-what breakpoint)) nil)))))) breakpoint) - + ;;;; C call out stubs ;;; This actually installs the break instruction in the component. It @@ -3513,6 +3703,7 @@ ;;; 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" @@ -3536,6 +3727,7 @@ ;;; This handles code-location and debug-function :FUNCTION-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")) (unless (member data *executing-breakpoint-hooks*) @@ -3558,8 +3750,10 @@ ;; so we just leave it up to the C code. (breakpoint-do-displaced-inst signal-context (breakpoint-data-instruction data)) - ; Under HPUX we can't sigreturn so bp-do-disp-i has to return. - #!-(or hpux irix x86) + ;; 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) (error "BREAKPOINT-DO-DISPLACED-INST returned?")))) (defun invoke-breakpoint-hooks (breakpoints component offset) @@ -3578,6 +3772,7 @@ bpt))))) (defun handle-function-end-breakpoint (offset component context) + (/show0 "entering HANDLE-FUNCTION-END-BREAKPOINT") (let ((data (breakpoint-data component offset nil))) (unless data (error "unknown breakpoint in ~S at offset ~S" @@ -3585,13 +3780,14 @@ offset)) (let ((breakpoints (breakpoint-data-breakpoints data))) (when breakpoints - (assert (eq (breakpoint-kind (car breakpoints)) :function-end)) + (aver (eq (breakpoint-kind (car breakpoints)) :function-end)) (handle-function-end-breakpoint-aux breakpoints data context))))) ;;; Either HANDLE-BREAKPOINT calls this for :FUNCTION-END breakpoints ;;; [old C code] or HANDLE-FUNCTION-END-BREAKPOINT calls this directly ;;; [new C code]. (defun handle-function-end-breakpoint-aux (breakpoints data signal-context) + (/show0 "entering HANDLE-FUNCTION-END-BREAKPOINT-AUX") (delete-breakpoint-data data) (let* ((scp (locally @@ -3617,7 +3813,7 @@ #!+x86 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) + (reg-arg-offsets '#.sb!vm::*register-arg-offsets*) (results nil)) (without-gcing (dotimes (arg-num nargs) @@ -3627,8 +3823,8 @@ (stack-ref ocfp arg-num)) results))) (nreverse results))) - -;;;; MAKE-BOGUS-LRA (used for :function-end breakpoints) + +;;;; MAKE-BOGUS-LRA (used for :FUNCTION-END breakpoints) (defconstant bogus-lra-constants