()
#!+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
"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
(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)))
\f
;;;; structures
;;;;
;;;; 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
(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.
(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
(: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
(: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.
;;; 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.
(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).
(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))
(: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))
;;;; 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
(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.
;;; 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)))
;;; 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.
(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
;;;; 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
(: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
(: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))
\f
;;;; 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
;;; 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)
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)
;;; 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
#!+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
(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))
(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)
(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.
(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
(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
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))))
\f
;;;; 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)))
(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)))
,@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)
(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
(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))))
(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
(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)))))
(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))
(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))
(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
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
(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)))
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
(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
(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
\f
;;;; 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)
(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
(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
(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.
(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
(= (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
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)
;;; 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.
;;; 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))
(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)
(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")
(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)
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
(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
;;; 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)
(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)))))
;;; 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))
(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.
\f
;;;; 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)))
: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))
\f
;;;; 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
(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))
(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
#!+gengc sb!vm::ra-save-offset
lra-sc-offset)))
(return t)))))
-
+\f
;;;; 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)
(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
(setf (breakpoint-data-breakpoints data)
(append (breakpoint-data-breakpoints data) (list breakpoint)))
(setf (breakpoint-internal-data breakpoint) data)))
-
+\f
;;;; DEACTIVATE-BREAKPOINT
(defun deactivate-breakpoint (breakpoint)
(delete-breakpoint-data data))))
(setf (breakpoint-status breakpoint) :inactive)
breakpoint)
-
+\f
;;;; BREAKPOINT-INFO
(defun breakpoint-info (breakpoint)
(let ((other (breakpoint-unknown-return-partner breakpoint)))
(when other
(setf (breakpoint-%info other) value))))
-
+\f
;;;; BREAKPOINT-ACTIVE-P and DELETE-BREAKPOINT
(defun breakpoint-active-p (breakpoint)
(breakpoint-what breakpoint))
nil))))))
breakpoint)
-
+\f
;;;; C call out stubs
;;; This actually installs the break instruction in the component. It
;;; 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"
;;; 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*)
;; 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)
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"
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
#!+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)
(stack-ref ocfp arg-num))
results)))
(nreverse results)))
-
-;;;; MAKE-BOGUS-LRA (used for :function-end breakpoints)
+\f
+;;;; MAKE-BOGUS-LRA (used for :FUNCTION-END breakpoints)
(defconstant
bogus-lra-constants
projects / sbcl.git / blobdiff