1 ;;;; the implementation of the programmer's interface to writing
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
15 ;;; FIXME: There are an awful lot of package prefixes in this code.
16 ;;; Couldn't we have SB-DI use the SB-C and SB-VM packages?
20 ;;;; The interface to building debugging tools signals conditions that
21 ;;;; prevent it from adhering to its contract. These are
22 ;;;; serious-conditions because the program using the interface must
23 ;;;; handle them before it can correctly continue execution. These
24 ;;;; debugging conditions are not errors since it is no fault of the
25 ;;;; programmers that the conditions occur. The interface does not
26 ;;;; provide for programs to detect these situations other than
27 ;;;; calling a routine that detects them and signals a condition. For
28 ;;;; example, programmers call A which may fail to return successfully
29 ;;;; due to a lack of debug information, and there is no B the they
30 ;;;; could have called to realize A would fail. It is not an error to
31 ;;;; have called A, but it is an error for the program to then ignore
32 ;;;; the signal generated by A since it cannot continue without A's
33 ;;;; correctly returning a value or performing some operation.
35 ;;;; Use DEBUG-SIGNAL to signal these conditions.
37 (define-condition debug-condition
(serious-condition)
41 "All DEBUG-CONDITIONs inherit from this type. These are serious conditions
42 that must be handled, but they are not programmer errors."))
44 (define-condition no-debug-info
(debug-condition)
45 ((code-component :reader no-debug-info-code-component
46 :initarg
:code-component
))
48 (:documentation
"There is no usable debugging information available.")
49 (:report
(lambda (condition stream
)
52 "no debug information available for ~S~%"
53 (no-debug-info-code-component condition
)))))
55 (define-condition no-debug-fun-returns
(debug-condition)
56 ((debug-fun :reader no-debug-fun-returns-debug-fun
60 "The system could not return values from a frame with DEBUG-FUN since
61 it lacked information about returning values.")
62 (:report
(lambda (condition stream
)
63 (let ((fun (debug-fun-fun
64 (no-debug-fun-returns-debug-fun condition
))))
66 "~&Cannot return values from ~:[frame~;~:*~S~] since ~
67 the debug information lacks details about returning ~
71 (define-condition no-debug-blocks
(debug-condition)
72 ((debug-fun :reader no-debug-blocks-debug-fun
75 (:documentation
"The debug-fun has no debug-block information.")
76 (:report
(lambda (condition stream
)
77 (format stream
"~&~S has no debug-block information."
78 (no-debug-blocks-debug-fun condition
)))))
80 (define-condition no-debug-vars
(debug-condition)
81 ((debug-fun :reader no-debug-vars-debug-fun
84 (:documentation
"The DEBUG-FUN has no DEBUG-VAR information.")
85 (:report
(lambda (condition stream
)
86 (format stream
"~&~S has no debug variable information."
87 (no-debug-vars-debug-fun condition
)))))
89 (define-condition lambda-list-unavailable
(debug-condition)
90 ((debug-fun :reader lambda-list-unavailable-debug-fun
94 "The DEBUG-FUN has no lambda list since argument DEBUG-VARs are
96 (:report
(lambda (condition stream
)
97 (format stream
"~&~S has no lambda-list information available."
98 (lambda-list-unavailable-debug-fun condition
)))))
100 (define-condition invalid-value
(debug-condition)
101 ((debug-var :reader invalid-value-debug-var
:initarg
:debug-var
)
102 (frame :reader invalid-value-frame
:initarg
:frame
))
103 (:report
(lambda (condition stream
)
104 (format stream
"~&~S has :invalid or :unknown value in ~S."
105 (invalid-value-debug-var condition
)
106 (invalid-value-frame condition
)))))
108 (define-condition ambiguous-var-name
(debug-condition)
109 ((name :reader ambiguous-var-name-name
:initarg
:name
)
110 (frame :reader ambiguous-var-name-frame
:initarg
:frame
))
111 (:report
(lambda (condition stream
)
112 (format stream
"~&~S names more than one valid variable in ~S."
113 (ambiguous-var-name-name condition
)
114 (ambiguous-var-name-frame condition
)))))
116 ;;;; errors and DEBUG-SIGNAL
118 ;;; The debug-internals code tries to signal all programmer errors as
119 ;;; subtypes of DEBUG-ERROR. There are calls to ERROR signalling
120 ;;; SIMPLE-ERRORs, but these dummy checks in the code and shouldn't
123 ;;; While under development, this code also signals errors in code
124 ;;; branches that remain unimplemented.
126 (define-condition debug-error
(error) ()
129 "All programmer errors from using the interface for building debugging
130 tools inherit from this type."))
132 (define-condition unhandled-debug-condition
(debug-error)
133 ((condition :reader unhandled-debug-condition-condition
:initarg
:condition
))
134 (:report
(lambda (condition stream
)
135 (format stream
"~&unhandled DEBUG-CONDITION:~%~A"
136 (unhandled-debug-condition-condition condition
)))))
138 (define-condition unknown-code-location
(debug-error)
139 ((code-location :reader unknown-code-location-code-location
140 :initarg
:code-location
))
141 (:report
(lambda (condition stream
)
142 (format stream
"~&invalid use of an unknown code-location: ~S"
143 (unknown-code-location-code-location condition
)))))
145 (define-condition unknown-debug-var
(debug-error)
146 ((debug-var :reader unknown-debug-var-debug-var
:initarg
:debug-var
)
147 (debug-fun :reader unknown-debug-var-debug-fun
148 :initarg
:debug-fun
))
149 (:report
(lambda (condition stream
)
150 (format stream
"~&~S is not in ~S."
151 (unknown-debug-var-debug-var condition
)
152 (unknown-debug-var-debug-fun condition
)))))
154 (define-condition invalid-control-stack-pointer
(debug-error)
156 (:report
(lambda (condition stream
)
157 (declare (ignore condition
))
159 (write-string "invalid control stack pointer" stream
))))
161 (define-condition frame-fun-mismatch
(debug-error)
162 ((code-location :reader frame-fun-mismatch-code-location
163 :initarg
:code-location
)
164 (frame :reader frame-fun-mismatch-frame
:initarg
:frame
)
165 (form :reader frame-fun-mismatch-form
:initarg
:form
))
166 (:report
(lambda (condition stream
)
169 "~&Form was preprocessed for ~S,~% but called on ~S:~% ~S"
170 (frame-fun-mismatch-code-location condition
)
171 (frame-fun-mismatch-frame condition
)
172 (frame-fun-mismatch-form condition
)))))
174 ;;; This signals debug-conditions. If they go unhandled, then signal
175 ;;; an UNHANDLED-DEBUG-CONDITION error.
177 ;;; ??? Get SIGNAL in the right package!
178 (defmacro debug-signal
(datum &rest arguments
)
179 `(let ((condition (make-condition ,datum
,@arguments
)))
181 (error 'unhandled-debug-condition
:condition condition
)))
185 ;;;; Most of these structures model information stored in internal
186 ;;;; data structures created by the compiler. Whenever comments
187 ;;;; preface an object or type with "compiler", they refer to the
188 ;;;; internal compiler thing, not to the object or type with the same
189 ;;;; name in the "SB-DI" package.
193 ;;; These exist for caching data stored in packed binary form in
194 ;;; compiler DEBUG-FUNs.
195 (defstruct (debug-var (:constructor nil
)
197 ;; the name of the variable
198 (symbol (missing-arg) :type symbol
)
199 ;; a unique integer identification relative to other variables with the same
202 ;; Does the variable always have a valid value?
203 (alive-p nil
:type boolean
))
204 (def!method print-object
((debug-var debug-var
) stream
)
205 (print-unreadable-object (debug-var stream
:type t
:identity t
)
208 (debug-var-symbol debug-var
)
209 (debug-var-id debug-var
))))
212 (setf (fdocumentation 'debug-var-id
'function
)
213 "Return the integer that makes DEBUG-VAR's name and package unique
214 with respect to other DEBUG-VARs in the same function.")
216 (defstruct (compiled-debug-var
218 (:constructor make-compiled-debug-var
219 (symbol id alive-p sc-offset save-sc-offset
))
221 ;; storage class and offset (unexported)
222 (sc-offset nil
:type sb
!c
:sc-offset
)
223 ;; storage class and offset when saved somewhere
224 (save-sc-offset nil
:type
(or sb
!c
:sc-offset null
)))
228 ;;; These represent call frames on the stack.
229 (defstruct (frame (:constructor nil
)
231 ;; the next frame up, or NIL when top frame
232 (up nil
:type
(or frame null
))
233 ;; the previous frame down, or NIL when the bottom frame. Before
234 ;; computing the next frame down, this slot holds the frame pointer
235 ;; to the control stack for the given frame. This lets us get the
236 ;; next frame down and the return-pc for that frame.
237 (%down
:unparsed
:type
(or frame
(member nil
:unparsed
)))
238 ;; the DEBUG-FUN for the function whose call this frame represents
239 (debug-fun nil
:type debug-fun
)
240 ;; the CODE-LOCATION where the frame's DEBUG-FUN will continue
241 ;; running when program execution returns to this frame. If someone
242 ;; interrupted this frame, the result could be an unknown
244 (code-location nil
:type code-location
)
245 ;; an a-list of catch-tags to code-locations
246 (%catches
:unparsed
:type
(or list
(member :unparsed
)))
247 ;; pointer to frame on control stack (unexported)
249 ;; This is the frame's number for prompt printing. Top is zero.
250 (number 0 :type index
))
252 (defstruct (compiled-frame
254 (:constructor make-compiled-frame
255 (pointer up debug-fun code-location number
258 ;; This indicates whether someone interrupted the frame.
259 ;; (unexported). If escaped, this is a pointer to the state that was
260 ;; saved when we were interrupted, an os_context_t, i.e. the third
261 ;; argument to an SA_SIGACTION-style signal handler.
263 (def!method print-object
((obj compiled-frame
) str
)
264 (print-unreadable-object (obj str
:type t
)
266 "~S~:[~;, interrupted~]"
267 (debug-fun-name (frame-debug-fun obj
))
268 (compiled-frame-escaped obj
))))
272 ;;; These exist for caching data stored in packed binary form in
273 ;;; compiler DEBUG-FUNs. *COMPILED-DEBUG-FUNS* maps a SB!C::DEBUG-FUN
274 ;;; to a DEBUG-FUN. There should only be one DEBUG-FUN in existence
275 ;;; for any function; that is, all CODE-LOCATIONs and other objects
276 ;;; that reference DEBUG-FUNs point to unique objects. This is
277 ;;; due to the overhead in cached information.
278 (defstruct (debug-fun (:constructor nil
)
280 ;; some representation of the function arguments. See
281 ;; DEBUG-FUN-LAMBDA-LIST.
282 ;; NOTE: must parse vars before parsing arg list stuff.
283 (%lambda-list
:unparsed
)
284 ;; cached DEBUG-VARS information (unexported).
285 ;; These are sorted by their name.
286 (%debug-vars
:unparsed
:type
(or simple-vector null
(member :unparsed
)))
287 ;; cached debug-block information. This is NIL when we have tried to
288 ;; parse the packed binary info, but none is available.
289 (blocks :unparsed
:type
(or simple-vector null
(member :unparsed
)))
290 ;; the actual function if available
291 (%function
:unparsed
:type
(or null function
(member :unparsed
))))
292 (def!method print-object
((obj debug-fun
) stream
)
293 (print-unreadable-object (obj stream
:type t
)
294 (prin1 (debug-fun-name obj
) stream
)))
296 (defstruct (compiled-debug-fun
298 (:constructor %make-compiled-debug-fun
299 (compiler-debug-fun component
))
301 ;; compiler's dumped DEBUG-FUN information (unexported)
302 (compiler-debug-fun nil
:type sb
!c
::compiled-debug-fun
)
303 ;; code object (unexported).
305 ;; the :FUN-START breakpoint (if any) used to facilitate
306 ;; function end breakpoints
307 (end-starter nil
:type
(or null breakpoint
)))
309 ;;; This maps SB!C::COMPILED-DEBUG-FUNs to
310 ;;; COMPILED-DEBUG-FUNs, so we can get at cached stuff and not
311 ;;; duplicate COMPILED-DEBUG-FUN structures.
312 (defvar *compiled-debug-funs
* (make-hash-table :test
'eq
))
314 ;;; Make a COMPILED-DEBUG-FUN for a SB!C::COMPILER-DEBUG-FUN
315 ;;; and its component. This maps the latter to the former in
316 ;;; *COMPILED-DEBUG-FUNS*. If there already is a
317 ;;; COMPILED-DEBUG-FUN, then this returns it from
318 ;;; *COMPILED-DEBUG-FUNS*.
319 (defun make-compiled-debug-fun (compiler-debug-fun component
)
320 (or (gethash compiler-debug-fun
*compiled-debug-funs
*)
321 (setf (gethash compiler-debug-fun
*compiled-debug-funs
*)
322 (%make-compiled-debug-fun compiler-debug-fun component
))))
324 (defstruct (bogus-debug-fun
326 (:constructor make-bogus-debug-fun
335 (defvar *ir1-lambda-debug-fun
* (make-hash-table :test
'eq
))
339 ;;; These exist for caching data stored in packed binary form in compiler
341 (defstruct (debug-block (:constructor nil
)
343 ;; Code-locations where execution continues after this block.
344 (successors nil
:type list
)
345 ;; This indicates whether the block is a special glob of code shared
346 ;; by various functions and tucked away elsewhere in a component.
347 ;; This kind of block has no start code-location. This slot is in
348 ;; all debug-blocks since it is an exported interface.
349 (elsewhere-p nil
:type boolean
))
350 (def!method print-object
((obj debug-block
) str
)
351 (print-unreadable-object (obj str
:type t
)
352 (prin1 (debug-block-fun-name obj
) str
)))
355 (setf (fdocumentation 'debug-block-successors
'function
)
356 "Return the list of possible code-locations where execution may continue
357 when the basic-block represented by debug-block completes its execution.")
360 (setf (fdocumentation 'debug-block-elsewhere-p
'function
)
361 "Return whether debug-block represents elsewhere code.")
363 (defstruct (compiled-debug-block (:include debug-block
)
365 make-compiled-debug-block
366 (code-locations successors elsewhere-p
))
368 ;; code-location information for the block
369 (code-locations nil
:type simple-vector
))
371 (defvar *ir1-block-debug-block
* (make-hash-table :test
'eq
))
375 ;;; This is an internal structure that manages information about a
376 ;;; breakpoint locations. See *COMPONENT-BREAKPOINT-OFFSETS*.
377 (defstruct (breakpoint-data (:constructor make-breakpoint-data
380 ;; This is the component in which the breakpoint lies.
382 ;; This is the byte offset into the component.
383 (offset nil
:type index
)
384 ;; The original instruction replaced by the breakpoint.
385 (instruction nil
:type
(or null
(unsigned-byte 32)))
386 ;; A list of user breakpoints at this location.
387 (breakpoints nil
:type list
))
388 (def!method print-object
((obj breakpoint-data
) str
)
389 (print-unreadable-object (obj str
:type t
)
390 (format str
"~S at ~S"
392 (debug-fun-from-pc (breakpoint-data-component obj
)
393 (breakpoint-data-offset obj
)))
394 (breakpoint-data-offset obj
))))
396 (defstruct (breakpoint (:constructor %make-breakpoint
397 (hook-fun what kind %info
))
399 ;; This is the function invoked when execution encounters the
400 ;; breakpoint. It takes a frame, the breakpoint, and optionally a
401 ;; list of values. Values are supplied for :FUN-END breakpoints as
402 ;; values to return for the function containing the breakpoint.
403 ;; :FUN-END breakpoint hook functions also take a cookie argument.
404 ;; See the COOKIE-FUN slot.
405 (hook-fun (required-arg) :type function
)
406 ;; CODE-LOCATION or DEBUG-FUN
407 (what nil
:type
(or code-location debug-fun
))
408 ;; :CODE-LOCATION, :FUN-START, or :FUN-END for that kind
409 ;; of breakpoint. :UNKNOWN-RETURN-PARTNER if this is the partner of
410 ;; a :code-location breakpoint at an :UNKNOWN-RETURN code-location.
411 (kind nil
:type
(member :code-location
:fun-start
:fun-end
412 :unknown-return-partner
))
413 ;; Status helps the user and the implementation.
414 (status :inactive
:type
(member :active
:inactive
:deleted
))
415 ;; This is a backpointer to a breakpoint-data.
416 (internal-data nil
:type
(or null breakpoint-data
))
417 ;; With code-locations whose type is :UNKNOWN-RETURN, there are
418 ;; really two breakpoints: one at the multiple-value entry point,
419 ;; and one at the single-value entry point. This slot holds the
420 ;; breakpoint for the other one, or NIL if this isn't at an
421 ;; :UNKNOWN-RETURN code location.
422 (unknown-return-partner nil
:type
(or null breakpoint
))
423 ;; :FUN-END breakpoints use a breakpoint at the :FUN-START
424 ;; to establish the end breakpoint upon function entry. We do this
425 ;; by frobbing the LRA to jump to a special piece of code that
426 ;; breaks and provides the return values for the returnee. This slot
427 ;; points to the start breakpoint, so we can activate, deactivate,
429 (start-helper nil
:type
(or null breakpoint
))
430 ;; This is a hook users supply to get a dynamically unique cookie
431 ;; for identifying :FUN-END breakpoint executions. That is, if
432 ;; there is one :FUN-END breakpoint, but there may be multiple
433 ;; pending calls of its function on the stack. This function takes
434 ;; the cookie, and the hook function takes the cookie too.
435 (cookie-fun nil
:type
(or null function
))
436 ;; This slot users can set with whatever information they find useful.
438 (def!method print-object
((obj breakpoint
) str
)
439 (let ((what (breakpoint-what obj
)))
440 (print-unreadable-object (obj str
:type t
)
445 (debug-fun (debug-fun-name what
)))
448 (debug-fun (breakpoint-kind obj
)))))))
452 (defstruct (code-location (:constructor nil
)
454 ;; the DEBUG-FUN containing this CODE-LOCATION
455 (debug-fun nil
:type debug-fun
)
456 ;; This is initially :UNSURE. Upon first trying to access an
457 ;; :UNPARSED slot, if the data is unavailable, then this becomes T,
458 ;; and the code-location is unknown. If the data is available, this
459 ;; becomes NIL, a known location. We can't use a separate type
460 ;; code-location for this since we must return code-locations before
461 ;; we can tell whether they're known or unknown. For example, when
462 ;; parsing the stack, we don't want to unpack all the variables and
463 ;; blocks just to make frames.
464 (%unknown-p
:unsure
:type
(member t nil
:unsure
))
465 ;; the DEBUG-BLOCK containing CODE-LOCATION. XXX Possibly toss this
466 ;; out and just find it in the blocks cache in DEBUG-FUN.
467 (%debug-block
:unparsed
:type
(or debug-block
(member :unparsed
)))
468 ;; This is the number of forms processed by the compiler or loader
469 ;; before the top level form containing this code-location.
470 (%tlf-offset
:unparsed
:type
(or index
(member :unparsed
)))
471 ;; This is the depth-first number of the node that begins
472 ;; code-location within its top level form.
473 (%form-number
:unparsed
:type
(or index
(member :unparsed
))))
474 (def!method print-object
((obj code-location
) str
)
475 (print-unreadable-object (obj str
:type t
)
476 (prin1 (debug-fun-name (code-location-debug-fun obj
))
479 (defstruct (compiled-code-location
480 (:include code-location
)
481 (:constructor make-known-code-location
482 (pc debug-fun %tlf-offset %form-number
483 %live-set kind
&aux
(%unknown-p nil
)))
484 (:constructor make-compiled-code-location
(pc debug-fun
))
486 ;; an index into DEBUG-FUN's component slot
488 ;; a bit-vector indexed by a variable's position in
489 ;; DEBUG-FUN-DEBUG-VARS indicating whether the variable has a
490 ;; valid value at this code-location. (unexported).
491 (%live-set
:unparsed
:type
(or simple-bit-vector
(member :unparsed
)))
492 ;; (unexported) To see SB!C::LOCATION-KIND, do
493 ;; (SB!KERNEL:TYPE-EXPAND 'SB!C::LOCATION-KIND).
494 (kind :unparsed
:type
(or (member :unparsed
) sb
!c
::location-kind
)))
498 ;;; Return the number of top level forms processed by the compiler
499 ;;; before compiling this source. If this source is uncompiled, this
500 ;;; is zero. This may be zero even if the source is compiled since the
501 ;;; first form in the first file compiled in one compilation, for
502 ;;; example, must have a root number of zero -- the compiler saw no
503 ;;; other top level forms before it.
504 (defun debug-source-root-number (debug-source)
505 (sb!c
::debug-source-source-root debug-source
))
509 ;;; This is used in FIND-ESCAPED-FRAME and with the bogus components
510 ;;; and LRAs used for :FUN-END breakpoints. When a components
511 ;;; debug-info slot is :BOGUS-LRA, then the REAL-LRA-SLOT contains the
512 ;;; real component to continue executing, as opposed to the bogus
513 ;;; component which appeared in some frame's LRA location.
514 (defconstant real-lra-slot sb
!vm
:code-constants-offset
)
516 ;;; These are magically converted by the compiler.
517 (defun current-sp () (current-sp))
518 (defun current-fp () (current-fp))
519 (defun stack-ref (s n
) (stack-ref s n
))
520 (defun %set-stack-ref
(s n value
) (%set-stack-ref s n value
))
521 (defun fun-code-header (fun) (fun-code-header fun
))
522 (defun lra-code-header (lra) (lra-code-header lra
))
523 (defun make-lisp-obj (value) (make-lisp-obj value
))
524 (defun get-lisp-obj-address (thing) (get-lisp-obj-address thing
))
525 (defun fun-word-offset (fun) (fun-word-offset fun
))
527 #!-sb-fluid
(declaim (inline control-stack-pointer-valid-p
))
528 (defun control-stack-pointer-valid-p (x)
529 (declare (type system-area-pointer x
))
530 (let* ((control-stack-start
531 (descriptor-sap sb
!vm
::*control-stack-start
*))
534 (descriptor-sap sb
!vm
::*binding-stack-start
*) -
4)))
535 #!-stack-grows-downward-not-upward
536 (and (sap< x
(current-sp))
537 (sap<= control-stack-start
539 (zerop (logand (sap-int x
) #b11
)))
540 #!+stack-grows-downward-not-upward
541 (and (sap>= x
(current-sp))
542 (sap> control-stack-end x
)
543 (zerop (logand (sap-int x
) #b11
)))))
546 (sb!alien
:define-alien-routine component-ptr-from-pc
(system-area-pointer)
547 (pc system-area-pointer
))
550 (defun component-from-component-ptr (component-ptr)
551 (declare (type system-area-pointer component-ptr
))
552 (make-lisp-obj (logior (sap-int component-ptr
)
553 sb
!vm
:other-pointer-lowtag
)))
560 (defun compute-lra-data-from-pc (pc)
561 (declare (type system-area-pointer pc
))
562 (let ((component-ptr (component-ptr-from-pc pc
)))
563 (unless (sap= component-ptr
(int-sap #x0
))
564 (let* ((code (component-from-component-ptr component-ptr
))
565 (code-header-len (* (get-header-data code
) sb
!vm
:n-word-bytes
))
566 (pc-offset (- (sap-int pc
)
567 (- (get-lisp-obj-address code
)
568 sb
!vm
:other-pointer-lowtag
)
570 ; (format t "c-lra-fpc ~A ~A ~A~%" pc code pc-offset)
571 (values pc-offset code
)))))
573 (defconstant sb
!vm
::nargs-offset
#.sb
!vm
::ecx-offset
)
575 ;;; Check for a valid return address - it could be any valid C/Lisp
578 ;;; XXX Could be a little smarter.
579 #!-sb-fluid
(declaim (inline ra-pointer-valid-p
))
580 (defun ra-pointer-valid-p (ra)
581 (declare (type system-area-pointer ra
))
583 ;; not the first page (which is unmapped)
585 ;; FIXME: Where is this documented? Is it really true of every CPU
586 ;; architecture? Is it even necessarily true in current SBCL?
587 (>= (sap-int ra
) 4096)
588 ;; not a Lisp stack pointer
589 (not (control-stack-pointer-valid-p ra
))))
591 ;;; Try to find a valid previous stack. This is complex on the x86 as
592 ;;; it can jump between C and Lisp frames. To help find a valid frame
593 ;;; it searches backwards.
595 ;;; XXX Should probably check whether it has reached the bottom of the
598 ;;; XXX Should handle interrupted frames, both Lisp and C. At present
599 ;;; it manages to find a fp trail, see linux hack below.
600 (defun x86-call-context (fp &key
(depth 0))
601 (declare (type system-area-pointer fp
)
603 ;;(format t "*CC ~S ~S~%" fp depth)
605 ((not (control-stack-pointer-valid-p fp
))
606 #+nil
(format t
"debug invalid fp ~S~%" fp
)
609 ;; Check the two possible frame pointers.
610 (let ((lisp-ocfp (sap-ref-sap fp
(- (* (1+ ocfp-save-offset
) 4))))
611 (lisp-ra (sap-ref-sap fp
(- (* (1+ return-pc-save-offset
)
613 (c-ocfp (sap-ref-sap fp
(* 0 sb
!vm
:n-word-bytes
)))
614 (c-ra (sap-ref-sap fp
(* 1 sb
!vm
:n-word-bytes
))))
615 (cond ((and (sap> lisp-ocfp fp
) (control-stack-pointer-valid-p lisp-ocfp
)
616 (ra-pointer-valid-p lisp-ra
)
617 (sap> c-ocfp fp
) (control-stack-pointer-valid-p c-ocfp
)
618 (ra-pointer-valid-p c-ra
))
620 "*C Both valid ~S ~S ~S ~S~%"
621 lisp-ocfp lisp-ra c-ocfp c-ra
)
622 ;; Look forward another step to check their validity.
623 (let ((lisp-path-fp (x86-call-context lisp-ocfp
625 (c-path-fp (x86-call-context c-ocfp
:depth
(1+ depth
))))
626 (cond ((and lisp-path-fp c-path-fp
)
627 ;; Both still seem valid - choose the lisp frame.
628 #+nil
(when (zerop depth
)
630 "debug: both still valid ~S ~S ~S ~S~%"
631 lisp-ocfp lisp-ra c-ocfp c-ra
))
633 (if (sap> lisp-ocfp c-ocfp
)
634 (values lisp-ra lisp-ocfp
)
635 (values c-ra c-ocfp
))
637 (values lisp-ra lisp-ocfp
))
639 ;; The lisp convention is looking good.
640 #+nil
(format t
"*C lisp-ocfp ~S ~S~%" lisp-ocfp lisp-ra
)
641 (values lisp-ra lisp-ocfp
))
643 ;; The C convention is looking good.
644 #+nil
(format t
"*C c-ocfp ~S ~S~%" c-ocfp c-ra
)
645 (values c-ra c-ocfp
))
647 ;; Neither seems right?
648 #+nil
(format t
"debug: no valid2 fp found ~S ~S~%"
651 ((and (sap> lisp-ocfp fp
) (control-stack-pointer-valid-p lisp-ocfp
)
652 (ra-pointer-valid-p lisp-ra
))
653 ;; The lisp convention is looking good.
654 #+nil
(format t
"*C lisp-ocfp ~S ~S~%" lisp-ocfp lisp-ra
)
655 (values lisp-ra lisp-ocfp
))
656 ((and (sap> c-ocfp fp
) (control-stack-pointer-valid-p c-ocfp
)
657 #!-linux
(ra-pointer-valid-p c-ra
))
658 ;; The C convention is looking good.
659 #+nil
(format t
"*C c-ocfp ~S ~S~%" c-ocfp c-ra
)
660 (values c-ra c-ocfp
))
662 #+nil
(format t
"debug: no valid fp found ~S ~S~%"
668 ;;; Convert the descriptor into a SAP. The bits all stay the same, we just
669 ;;; change our notion of what we think they are.
670 #!-sb-fluid
(declaim (inline descriptor-sap
))
671 (defun descriptor-sap (x)
672 (int-sap (get-lisp-obj-address x
)))
674 ;;; Return the top frame of the control stack as it was before calling
677 (/noshow0
"entering TOP-FRAME")
678 (multiple-value-bind (fp pc
) (%caller-frame-and-pc
)
679 (compute-calling-frame (descriptor-sap fp
) pc nil
)))
681 ;;; Flush all of the frames above FRAME, and renumber all the frames
683 (defun flush-frames-above (frame)
684 (setf (frame-up frame
) nil
)
685 (do ((number 0 (1+ number
))
686 (frame frame
(frame-%down frame
)))
687 ((not (frame-p frame
)))
688 (setf (frame-number frame
) number
)))
690 ;;; Return the frame immediately below FRAME on the stack; or when
691 ;;; FRAME is the bottom of the stack, return NIL.
692 (defun frame-down (frame)
693 (/noshow0
"entering FRAME-DOWN")
694 ;; We have to access the old-fp and return-pc out of frame and pass
695 ;; them to COMPUTE-CALLING-FRAME.
696 (let ((down (frame-%down frame
)))
697 (if (eq down
:unparsed
)
698 (let ((debug-fun (frame-debug-fun frame
)))
699 (/noshow0
"in DOWN :UNPARSED case")
700 (setf (frame-%down frame
)
703 (let ((c-d-f (compiled-debug-fun-compiler-debug-fun
705 (compute-calling-frame
708 frame ocfp-save-offset
709 (sb!c
::compiled-debug-fun-old-fp c-d-f
)))
711 frame lra-save-offset
712 (sb!c
::compiled-debug-fun-return-pc c-d-f
))
715 (let ((fp (frame-pointer frame
)))
716 (when (control-stack-pointer-valid-p fp
)
718 (multiple-value-bind (ra ofp
) (x86-call-context fp
)
719 (and ra
(compute-calling-frame ofp ra frame
)))
721 (compute-calling-frame
723 (sap-ref-sap fp
(* ocfp-save-offset
727 (sap-ref-32 fp
(* ocfp-save-offset
728 sb
!vm
:n-word-bytes
)))
730 (stack-ref fp lra-save-offset
)
735 ;;; Get the old FP or return PC out of FRAME. STACK-SLOT is the
736 ;;; standard save location offset on the stack. LOC is the saved
737 ;;; SC-OFFSET describing the main location.
739 (defun get-context-value (frame stack-slot loc
)
740 (declare (type compiled-frame frame
) (type unsigned-byte stack-slot
)
741 (type sb
!c
:sc-offset loc
))
742 (let ((pointer (frame-pointer frame
))
743 (escaped (compiled-frame-escaped frame
)))
745 (sub-access-debug-var-slot pointer loc escaped
)
746 (stack-ref pointer stack-slot
))))
748 (defun get-context-value (frame stack-slot loc
)
749 (declare (type compiled-frame frame
) (type unsigned-byte stack-slot
)
750 (type sb
!c
:sc-offset loc
))
751 (let ((pointer (frame-pointer frame
))
752 (escaped (compiled-frame-escaped frame
)))
754 (sub-access-debug-var-slot pointer loc escaped
)
757 (stack-ref pointer stack-slot
))
759 (sap-ref-sap pointer
(- (* (1+ stack-slot
) 4))))))))
762 (defun (setf get-context-value
) (value frame stack-slot loc
)
763 (declare (type compiled-frame frame
) (type unsigned-byte stack-slot
)
764 (type sb
!c
:sc-offset loc
))
765 (let ((pointer (frame-pointer frame
))
766 (escaped (compiled-frame-escaped frame
)))
768 (sub-set-debug-var-slot pointer loc value escaped
)
769 (setf (stack-ref pointer stack-slot
) value
))))
772 (defun (setf get-context-value
) (value frame stack-slot loc
)
773 (declare (type compiled-frame frame
) (type unsigned-byte stack-slot
)
774 (type sb
!c
:sc-offset loc
))
775 (let ((pointer (frame-pointer frame
))
776 (escaped (compiled-frame-escaped frame
)))
778 (sub-set-debug-var-slot pointer loc value escaped
)
781 (setf (stack-ref pointer stack-slot
) value
))
783 (setf (sap-ref-sap pointer
(- (* (1+ stack-slot
) 4))) value
))))))
785 ;;; This returns a frame for the one existing in time immediately
786 ;;; prior to the frame referenced by current-fp. This is current-fp's
787 ;;; caller or the next frame down the control stack. If there is no
788 ;;; down frame, this returns NIL for the bottom of the stack. UP-FRAME
789 ;;; is the up link for the resulting frame object, and it is null when
790 ;;; we call this to get the top of the stack.
792 ;;; The current frame contains the pointer to the temporally previous
793 ;;; frame we want, and the current frame contains the pc at which we
794 ;;; will continue executing upon returning to that previous frame.
796 ;;; Note: Sometimes LRA is actually a fixnum. This happens when lisp
797 ;;; calls into C. In this case, the code object is stored on the stack
798 ;;; after the LRA, and the LRA is the word offset.
800 (defun compute-calling-frame (caller lra up-frame
)
801 (declare (type system-area-pointer caller
))
802 (when (control-stack-pointer-valid-p caller
)
803 (multiple-value-bind (code pc-offset escaped
)
805 (multiple-value-bind (word-offset code
)
807 (let ((fp (frame-pointer up-frame
)))
809 (stack-ref fp
(1+ lra-save-offset
))))
810 (values (get-header-data lra
)
811 (lra-code-header lra
)))
814 (* (1+ (- word-offset
(get-header-data code
)))
817 (values :foreign-function
820 (find-escaped-frame caller
))
821 (if (and (code-component-p code
)
822 (eq (%code-debug-info code
) :bogus-lra
))
823 (let ((real-lra (code-header-ref code real-lra-slot
)))
824 (compute-calling-frame caller real-lra up-frame
))
825 (let ((d-fun (case code
827 (make-bogus-debug-fun
828 "undefined function"))
830 (make-bogus-debug-fun
831 "foreign function call land"))
833 (make-bogus-debug-fun
834 "bogus stack frame"))
836 (debug-fun-from-pc code pc-offset
)))))
837 (make-compiled-frame caller up-frame d-fun
838 (code-location-from-pc d-fun pc-offset
840 (if up-frame
(1+ (frame-number up-frame
)) 0)
843 (defun compute-calling-frame (caller ra up-frame
)
844 (declare (type system-area-pointer caller ra
))
845 (/noshow0
"entering COMPUTE-CALLING-FRAME")
846 (when (control-stack-pointer-valid-p caller
)
848 ;; First check for an escaped frame.
849 (multiple-value-bind (code pc-offset escaped
) (find-escaped-frame caller
)
852 (/noshow0
"in CODE clause")
853 ;; If it's escaped it may be a function end breakpoint trap.
854 (when (and (code-component-p code
)
855 (eq (%code-debug-info code
) :bogus-lra
))
856 ;; If :bogus-lra grab the real lra.
857 (setq pc-offset
(code-header-ref
858 code
(1+ real-lra-slot
)))
859 (setq code
(code-header-ref code real-lra-slot
))
862 (/noshow0
"in T clause")
864 (multiple-value-setq (pc-offset code
)
865 (compute-lra-data-from-pc ra
))
867 (setf code
:foreign-function
871 (let ((d-fun (case code
873 (make-bogus-debug-fun
874 "undefined function"))
876 (make-bogus-debug-fun
877 "foreign function call land"))
879 (make-bogus-debug-fun
880 "bogus stack frame"))
882 (debug-fun-from-pc code pc-offset
)))))
883 (/noshow0
"returning MAKE-COMPILED-FRAME from COMPUTE-CALLING-FRAME")
884 (make-compiled-frame caller up-frame d-fun
885 (code-location-from-pc d-fun pc-offset
887 (if up-frame
(1+ (frame-number up-frame
)) 0)
891 (defun nth-interrupt-context (n)
892 (declare (type (unsigned-byte 32) n
)
893 (optimize (speed 3) (safety 0)))
894 (sb!alien
:sap-alien
(sb!vm
::current-thread-offset-sap
895 (+ sb
!vm
::thread-interrupt-contexts-offset n
))
899 (defun find-escaped-frame (frame-pointer)
900 (declare (type system-area-pointer frame-pointer
))
901 (/noshow0
"entering FIND-ESCAPED-FRAME")
902 (dotimes (index *free-interrupt-context-index
* (values nil
0 nil
))
903 (/noshow0
"at head of WITH-ALIEN")
904 (let ((context (nth-interrupt-context index
)))
905 (/noshow0
"got CONTEXT")
906 (when (= (sap-int frame-pointer
)
907 (sb!vm
:context-register context sb
!vm
::cfp-offset
))
909 (/noshow0
"in WITHOUT-GCING")
910 (let* ((component-ptr (component-ptr-from-pc
911 (sb!vm
:context-pc context
)))
912 (code (unless (sap= component-ptr
(int-sap #x0
))
913 (component-from-component-ptr component-ptr
))))
914 (/noshow0
"got CODE")
916 (return (values code
0 context
)))
917 (let* ((code-header-len (* (get-header-data code
)
920 (- (sap-int (sb!vm
:context-pc context
))
921 (- (get-lisp-obj-address code
)
922 sb
!vm
:other-pointer-lowtag
)
924 (/noshow
"got PC-OFFSET")
925 (unless (<= 0 pc-offset
926 (* (code-header-ref code sb
!vm
:code-code-size-slot
)
928 ;; We were in an assembly routine. Therefore, use the
931 ;; FIXME: Should this be WARN or ERROR or what?
932 (format t
"** pc-offset ~S not in code obj ~S?~%"
934 (/noshow0
"returning from FIND-ESCAPED-FRAME")
936 (values code pc-offset context
)))))))))
939 (defun find-escaped-frame (frame-pointer)
940 (declare (type system-area-pointer frame-pointer
))
941 (dotimes (index *free-interrupt-context-index
* (values nil
0 nil
))
943 ((lisp-interrupt-contexts (array (* os-context-t
) nil
) :extern
))
944 (let ((scp (sb!alien
:deref lisp-interrupt-contexts index
)))
945 (when (= (sap-int frame-pointer
)
946 (sb!vm
:context-register scp sb
!vm
::cfp-offset
))
948 (let ((code (code-object-from-bits
949 (sb!vm
:context-register scp sb
!vm
::code-offset
))))
951 (return (values code
0 scp
)))
952 (let* ((code-header-len (* (get-header-data code
)
955 (- (sap-int (sb!vm
:context-pc scp
))
956 (- (get-lisp-obj-address code
)
957 sb
!vm
:other-pointer-lowtag
)
959 ;; Check to see whether we were executing in a branch
961 #!+(or pmax sgi
) ; pmax only (and broken anyway)
962 (when (logbitp 31 (sb!alien
:slot scp
'%mips
::sc-cause
))
963 (incf pc-offset sb
!vm
:n-word-bytes
))
964 (unless (<= 0 pc-offset
965 (* (code-header-ref code sb
!vm
:code-code-size-slot
)
967 ;; We were in an assembly routine. Therefore, use the
970 (- (sb!vm
:context-register scp sb
!vm
::lra-offset
)
971 (get-lisp-obj-address code
)
974 (if (eq (%code-debug-info code
) :bogus-lra
)
975 (let ((real-lra (code-header-ref code
977 (values (lra-code-header real-lra
)
978 (get-header-data real-lra
)
980 (values code pc-offset scp
)))))))))))
982 ;;; Find the code object corresponding to the object represented by
983 ;;; bits and return it. We assume bogus functions correspond to the
984 ;;; undefined-function.
985 (defun code-object-from-bits (bits)
986 (declare (type (unsigned-byte 32) bits
))
987 (let ((object (make-lisp-obj bits
)))
988 (if (functionp object
)
989 (or (fun-code-header object
)
991 (let ((lowtag (lowtag-of object
)))
992 (if (= lowtag sb
!vm
:other-pointer-lowtag
)
993 (let ((widetag (widetag-of object
)))
994 (cond ((= widetag sb
!vm
:code-header-widetag
)
996 ((= widetag sb
!vm
:return-pc-header-widetag
)
997 (lra-code-header object
))
1001 ;;;; frame utilities
1003 ;;; This returns a COMPILED-DEBUG-FUN for COMPONENT and PC. We fetch the
1004 ;;; SB!C::DEBUG-INFO and run down its FUN-MAP to get a
1005 ;;; SB!C::COMPILED-DEBUG-FUN from the PC. The result only needs to
1006 ;;; reference the COMPONENT, for function constants, and the
1007 ;;; SB!C::COMPILED-DEBUG-FUN.
1008 (defun debug-fun-from-pc (component pc
)
1009 (let ((info (%code-debug-info component
)))
1012 (debug-signal 'no-debug-info
:code-component component
))
1013 ((eq info
:bogus-lra
)
1014 (make-bogus-debug-fun "function end breakpoint"))
1016 (let* ((fun-map (sb!c
::compiled-debug-info-fun-map info
))
1017 (len (length fun-map
)))
1018 (declare (type simple-vector fun-map
))
1020 (make-compiled-debug-fun (svref fun-map
0) component
)
1023 (>= pc
(sb!c
::compiled-debug-fun-elsewhere-pc
1024 (svref fun-map
0)))))
1025 (declare (type sb
!int
:index i
))
1028 (< pc
(if elsewhere-p
1029 (sb!c
::compiled-debug-fun-elsewhere-pc
1030 (svref fun-map
(1+ i
)))
1031 (svref fun-map i
))))
1032 (return (make-compiled-debug-fun
1033 (svref fun-map
(1- i
))
1037 ;;; This returns a code-location for the COMPILED-DEBUG-FUN,
1038 ;;; DEBUG-FUN, and the pc into its code vector. If we stopped at a
1039 ;;; breakpoint, find the CODE-LOCATION for that breakpoint. Otherwise,
1040 ;;; make an :UNSURE code location, so it can be filled in when we
1041 ;;; figure out what is going on.
1042 (defun code-location-from-pc (debug-fun pc escaped
)
1043 (or (and (compiled-debug-fun-p debug-fun
)
1045 (let ((data (breakpoint-data
1046 (compiled-debug-fun-component debug-fun
)
1048 (when (and data
(breakpoint-data-breakpoints data
))
1049 (let ((what (breakpoint-what
1050 (first (breakpoint-data-breakpoints data
)))))
1051 (when (compiled-code-location-p what
)
1053 (make-compiled-code-location pc debug-fun
)))
1055 ;;; Return an alist mapping catch tags to CODE-LOCATIONs. These are
1056 ;;; CODE-LOCATIONs at which execution would continue with frame as the
1057 ;;; top frame if someone threw to the corresponding tag.
1058 (defun frame-catches (frame)
1059 (let ((catch (descriptor-sap sb
!vm
:*current-catch-block
*))
1060 (reversed-result nil
)
1061 (fp (frame-pointer frame
)))
1062 (loop until
(zerop (sap-int catch
))
1063 finally
(return (nreverse reversed-result
))
1068 (* sb
!vm
:catch-block-current-cont-slot
1069 sb
!vm
:n-word-bytes
))
1073 (* sb
!vm
:catch-block-current-cont-slot
1074 sb
!vm
:n-word-bytes
))))
1076 (lra (stack-ref catch sb
!vm
:catch-block-entry-pc-slot
))
1079 catch
(* sb
!vm
:catch-block-entry-pc-slot
1080 sb
!vm
:n-word-bytes
)))
1083 (stack-ref catch sb
!vm
:catch-block-current-code-slot
))
1085 (component (component-from-component-ptr
1086 (component-ptr-from-pc ra
)))
1089 (* (- (1+ (get-header-data lra
))
1090 (get-header-data component
))
1094 (- (get-lisp-obj-address component
)
1095 sb
!vm
:other-pointer-lowtag
)
1096 (* (get-header-data component
) sb
!vm
:n-word-bytes
))))
1098 (stack-ref catch sb
!vm
:catch-block-tag-slot
)
1101 (sap-ref-32 catch
(* sb
!vm
:catch-block-tag-slot
1102 sb
!vm
:n-word-bytes
)))
1103 (make-compiled-code-location
1104 offset
(frame-debug-fun frame
)))
1109 (* sb
!vm
:catch-block-previous-catch-slot
1110 sb
!vm
:n-word-bytes
))
1114 (* sb
!vm
:catch-block-previous-catch-slot
1115 sb
!vm
:n-word-bytes
)))))))
1117 ;;;; operations on DEBUG-FUNs
1119 ;;; Execute the forms in a context with BLOCK-VAR bound to each
1120 ;;; DEBUG-BLOCK in DEBUG-FUN successively. Result is an optional
1121 ;;; form to execute for return values, and DO-DEBUG-FUN-BLOCKS
1122 ;;; returns nil if there is no result form. This signals a
1123 ;;; NO-DEBUG-BLOCKS condition when the DEBUG-FUN lacks
1124 ;;; DEBUG-BLOCK information.
1125 (defmacro do-debug-fun-blocks
((block-var debug-fun
&optional result
)
1127 (let ((blocks (gensym))
1129 `(let ((,blocks
(debug-fun-debug-blocks ,debug-fun
)))
1130 (declare (simple-vector ,blocks
))
1131 (dotimes (,i
(length ,blocks
) ,result
)
1132 (let ((,block-var
(svref ,blocks
,i
)))
1135 ;;; Execute body in a context with VAR bound to each DEBUG-VAR in
1136 ;;; DEBUG-FUN. This returns the value of executing result (defaults to
1137 ;;; nil). This may iterate over only some of DEBUG-FUN's variables or
1138 ;;; none depending on debug policy; for example, possibly the
1139 ;;; compilation only preserved argument information.
1140 (defmacro do-debug-fun-vars
((var debug-fun
&optional result
) &body body
)
1141 (let ((vars (gensym))
1143 `(let ((,vars
(debug-fun-debug-vars ,debug-fun
)))
1144 (declare (type (or null simple-vector
) ,vars
))
1146 (dotimes (,i
(length ,vars
) ,result
)
1147 (let ((,var
(svref ,vars
,i
)))
1151 ;;; Return the object of type FUNCTION associated with the DEBUG-FUN,
1152 ;;; or NIL if the function is unavailable or is non-existent as a user
1153 ;;; callable function object.
1154 (defun debug-fun-fun (debug-fun)
1155 (let ((cached-value (debug-fun-%function debug-fun
)))
1156 (if (eq cached-value
:unparsed
)
1157 (setf (debug-fun-%function debug-fun
)
1158 (etypecase debug-fun
1161 (compiled-debug-fun-component debug-fun
))
1163 (sb!c
::compiled-debug-fun-start-pc
1164 (compiled-debug-fun-compiler-debug-fun debug-fun
))))
1165 (do ((entry (%code-entry-points component
)
1166 (%simple-fun-next entry
)))
1169 (sb!c
::compiled-debug-fun-start-pc
1170 (compiled-debug-fun-compiler-debug-fun
1171 (fun-debug-fun entry
))))
1173 (bogus-debug-fun nil
)))
1176 ;;; Return the name of the function represented by DEBUG-FUN. This may
1177 ;;; be a string or a cons; do not assume it is a symbol.
1178 (defun debug-fun-name (debug-fun)
1179 (declare (type debug-fun debug-fun
))
1180 (etypecase debug-fun
1182 (sb!c
::compiled-debug-fun-name
1183 (compiled-debug-fun-compiler-debug-fun debug-fun
)))
1185 (bogus-debug-fun-%name debug-fun
))))
1187 ;;; Return a DEBUG-FUN that represents debug information for FUN.
1188 (defun fun-debug-fun (fun)
1189 (declare (type function fun
))
1190 (ecase (widetag-of fun
)
1191 (#.sb
!vm
:closure-header-widetag
1192 (fun-debug-fun (%closure-fun fun
)))
1193 (#.sb
!vm
:funcallable-instance-header-widetag
1194 (fun-debug-fun (funcallable-instance-fun fun
)))
1195 ((#.sb
!vm
:simple-fun-header-widetag
1196 #.sb
!vm
:closure-fun-header-widetag
)
1197 (let* ((name (%simple-fun-name fun
))
1198 (component (fun-code-header fun
))
1201 (and (sb!c
::compiled-debug-fun-p x
)
1202 (eq (sb!c
::compiled-debug-fun-name x
) name
)
1203 (eq (sb!c
::compiled-debug-fun-kind x
) nil
)))
1204 (sb!c
::compiled-debug-info-fun-map
1205 (%code-debug-info component
)))))
1207 (make-compiled-debug-fun res component
)
1208 ;; KLUDGE: comment from CMU CL:
1209 ;; This used to be the non-interpreted branch, but
1210 ;; William wrote it to return the debug-fun of fun's XEP
1211 ;; instead of fun's debug-fun. The above code does this
1212 ;; more correctly, but it doesn't get or eliminate all
1213 ;; appropriate cases. It mostly works, and probably
1214 ;; works for all named functions anyway.
1216 (debug-fun-from-pc component
1217 (* (- (fun-word-offset fun
)
1218 (get-header-data component
))
1219 sb
!vm
:n-word-bytes
)))))))
1221 ;;; Return the kind of the function, which is one of :OPTIONAL,
1222 ;;; :EXTERNAL, :TOPLEVEL, :CLEANUP, or NIL.
1223 (defun debug-fun-kind (debug-fun)
1224 ;; FIXME: This "is one of" information should become part of the function
1225 ;; declamation, not just a doc string
1226 (etypecase debug-fun
1228 (sb!c
::compiled-debug-fun-kind
1229 (compiled-debug-fun-compiler-debug-fun debug-fun
)))
1233 ;;; Is there any variable information for DEBUG-FUN?
1234 (defun debug-var-info-available (debug-fun)
1235 (not (not (debug-fun-debug-vars debug-fun
))))
1237 ;;; Return a list of DEBUG-VARs in DEBUG-FUN having the same name
1238 ;;; and package as SYMBOL. If SYMBOL is uninterned, then this returns
1239 ;;; a list of DEBUG-VARs without package names and with the same name
1240 ;;; as symbol. The result of this function is limited to the
1241 ;;; availability of variable information in DEBUG-FUN; for
1242 ;;; example, possibly DEBUG-FUN only knows about its arguments.
1243 (defun debug-fun-symbol-vars (debug-fun symbol
)
1244 (let ((vars (ambiguous-debug-vars debug-fun
(symbol-name symbol
)))
1245 (package (and (symbol-package symbol
)
1246 (package-name (symbol-package symbol
)))))
1247 (delete-if (if (stringp package
)
1249 (let ((p (debug-var-package-name var
)))
1250 (or (not (stringp p
))
1251 (string/= p package
))))
1253 (stringp (debug-var-package-name var
))))
1256 ;;; Return a list of DEBUG-VARs in DEBUG-FUN whose names contain
1257 ;;; NAME-PREFIX-STRING as an initial substring. The result of this
1258 ;;; function is limited to the availability of variable information in
1259 ;;; debug-fun; for example, possibly debug-fun only knows
1260 ;;; about its arguments.
1261 (defun ambiguous-debug-vars (debug-fun name-prefix-string
)
1262 (declare (simple-string name-prefix-string
))
1263 (let ((variables (debug-fun-debug-vars debug-fun
)))
1264 (declare (type (or null simple-vector
) variables
))
1266 (let* ((len (length variables
))
1267 (prefix-len (length name-prefix-string
))
1268 (pos (find-var name-prefix-string variables len
))
1271 ;; Find names from pos to variable's len that contain prefix.
1272 (do ((i pos
(1+ i
)))
1274 (let* ((var (svref variables i
))
1275 (name (debug-var-symbol-name var
))
1276 (name-len (length name
)))
1277 (declare (simple-string name
))
1278 (when (/= (or (string/= name-prefix-string name
1279 :end1 prefix-len
:end2 name-len
)
1284 (setq res
(nreverse res
)))
1287 ;;; This returns a position in VARIABLES for one containing NAME as an
1288 ;;; initial substring. END is the length of VARIABLES if supplied.
1289 (defun find-var (name variables
&optional end
)
1290 (declare (simple-vector variables
)
1291 (simple-string name
))
1292 (let ((name-len (length name
)))
1293 (position name variables
1295 (let* ((y (debug-var-symbol-name y
))
1297 (declare (simple-string y
))
1298 (and (>= y-len name-len
)
1299 (string= x y
:end1 name-len
:end2 name-len
))))
1300 :end
(or end
(length variables
)))))
1302 ;;; Return a list representing the lambda-list for DEBUG-FUN. The
1303 ;;; list has the following structure:
1304 ;;; (required-var1 required-var2
1306 ;;; (:optional var3 suppliedp-var4)
1307 ;;; (:optional var5)
1309 ;;; (:rest var6) (:rest var7)
1311 ;;; (:keyword keyword-symbol var8 suppliedp-var9)
1312 ;;; (:keyword keyword-symbol var10)
1315 ;;; Each VARi is a DEBUG-VAR; however it may be the symbol :DELETED if
1316 ;;; it is unreferenced in DEBUG-FUN. This signals a
1317 ;;; LAMBDA-LIST-UNAVAILABLE condition when there is no argument list
1319 (defun debug-fun-lambda-list (debug-fun)
1320 (etypecase debug-fun
1321 (compiled-debug-fun (compiled-debug-fun-lambda-list debug-fun
))
1322 (bogus-debug-fun nil
)))
1324 ;;; Note: If this has to compute the lambda list, it caches it in DEBUG-FUN.
1325 (defun compiled-debug-fun-lambda-list (debug-fun)
1326 (let ((lambda-list (debug-fun-%lambda-list debug-fun
)))
1327 (cond ((eq lambda-list
:unparsed
)
1328 (multiple-value-bind (args argsp
)
1329 (parse-compiled-debug-fun-lambda-list debug-fun
)
1330 (setf (debug-fun-%lambda-list debug-fun
) args
)
1333 (debug-signal 'lambda-list-unavailable
1334 :debug-fun debug-fun
))))
1336 ((bogus-debug-fun-p debug-fun
)
1338 ((sb!c
::compiled-debug-fun-arguments
1339 (compiled-debug-fun-compiler-debug-fun debug-fun
))
1340 ;; If the packed information is there (whether empty or not) as
1341 ;; opposed to being nil, then returned our cached value (nil).
1344 ;; Our cached value is nil, and the packed lambda-list information
1345 ;; is nil, so we don't have anything available.
1346 (debug-signal 'lambda-list-unavailable
1347 :debug-fun debug-fun
)))))
1349 ;;; COMPILED-DEBUG-FUN-LAMBDA-LIST calls this when a
1350 ;;; COMPILED-DEBUG-FUN has no lambda list information cached. It
1351 ;;; returns the lambda list as the first value and whether there was
1352 ;;; any argument information as the second value. Therefore,
1353 ;;; (VALUES NIL T) means there were no arguments, but (VALUES NIL NIL)
1354 ;;; means there was no argument information.
1355 (defun parse-compiled-debug-fun-lambda-list (debug-fun)
1356 (let ((args (sb!c
::compiled-debug-fun-arguments
1357 (compiled-debug-fun-compiler-debug-fun debug-fun
))))
1362 (values (coerce (debug-fun-debug-vars debug-fun
) 'list
)
1365 (let ((vars (debug-fun-debug-vars debug-fun
))
1370 (declare (type (or null simple-vector
) vars
))
1372 (when (>= i len
) (return))
1373 (let ((ele (aref args i
)))
1378 ;; Deleted required arg at beginning of args array.
1379 (push :deleted res
))
1380 (sb!c
::optional-args
1383 ;; SUPPLIED-P var immediately following keyword or
1384 ;; optional. Stick the extra var in the result
1385 ;; element representing the keyword or optional,
1386 ;; which is the previous one.
1388 (list (compiled-debug-fun-lambda-list-var
1389 args
(incf i
) vars
))))
1392 (compiled-debug-fun-lambda-list-var
1393 args
(incf i
) vars
))
1396 ;; Just ignore the fact that the next two args are
1397 ;; the &MORE arg context and count, and act like they
1398 ;; are regular arguments.
1402 (push (list :keyword
1404 (compiled-debug-fun-lambda-list-var
1405 args
(incf i
) vars
))
1408 ;; We saw an optional marker, so the following
1409 ;; non-symbols are indexes indicating optional
1411 (push (list :optional
(svref vars ele
)) res
))
1413 ;; Required arg at beginning of args array.
1414 (push (svref vars ele
) res
))))
1416 (values (nreverse res
) t
))))))
1418 ;;; This is used in COMPILED-DEBUG-FUN-LAMBDA-LIST.
1419 (defun compiled-debug-fun-lambda-list-var (args i vars
)
1420 (declare (type (simple-array * (*)) args
)
1421 (simple-vector vars
))
1422 (let ((ele (aref args i
)))
1423 (cond ((not (symbolp ele
)) (svref vars ele
))
1424 ((eq ele
'sb
!c
::deleted
) :deleted
)
1425 (t (error "malformed arguments description")))))
1427 (defun compiled-debug-fun-debug-info (debug-fun)
1428 (%code-debug-info
(compiled-debug-fun-component debug-fun
)))
1430 ;;;; unpacking variable and basic block data
1432 (defvar *parsing-buffer
*
1433 (make-array 20 :adjustable t
:fill-pointer t
))
1434 (defvar *other-parsing-buffer
*
1435 (make-array 20 :adjustable t
:fill-pointer t
))
1436 ;;; PARSE-DEBUG-BLOCKS and PARSE-DEBUG-VARS
1437 ;;; use this to unpack binary encoded information. It returns the
1438 ;;; values returned by the last form in body.
1440 ;;; This binds buffer-var to *parsing-buffer*, makes sure it starts at
1441 ;;; element zero, and makes sure if we unwind, we nil out any set
1442 ;;; elements for GC purposes.
1444 ;;; This also binds other-var to *other-parsing-buffer* when it is
1445 ;;; supplied, making sure it starts at element zero and that we nil
1446 ;;; out any elements if we unwind.
1448 ;;; This defines the local macro RESULT that takes a buffer, copies
1449 ;;; its elements to a resulting simple-vector, nil's out elements, and
1450 ;;; restarts the buffer at element zero. RESULT returns the
1452 (eval-when (:compile-toplevel
:execute
)
1453 (sb!xc
:defmacro with-parsing-buffer
((buffer-var &optional other-var
)
1455 (let ((len (gensym))
1458 (let ((,buffer-var
*parsing-buffer
*)
1459 ,@(if other-var
`((,other-var
*other-parsing-buffer
*))))
1460 (setf (fill-pointer ,buffer-var
) 0)
1461 ,@(if other-var
`((setf (fill-pointer ,other-var
) 0)))
1462 (macrolet ((result (buf)
1463 `(let* ((,',len
(length ,buf
))
1464 (,',res
(make-array ,',len
)))
1465 (replace ,',res
,buf
:end1
,',len
:end2
,',len
)
1466 (fill ,buf nil
:end
,',len
)
1467 (setf (fill-pointer ,buf
) 0)
1470 (fill *parsing-buffer
* nil
)
1471 ,@(if other-var
`((fill *other-parsing-buffer
* nil
))))))
1474 ;;; The argument is a debug internals structure. This returns the
1475 ;;; DEBUG-BLOCKs for DEBUG-FUN, regardless of whether we have unpacked
1476 ;;; them yet. It signals a NO-DEBUG-BLOCKS condition if it can't
1477 ;;; return the blocks.
1478 (defun debug-fun-debug-blocks (debug-fun)
1479 (let ((blocks (debug-fun-blocks debug-fun
)))
1480 (cond ((eq blocks
:unparsed
)
1481 (setf (debug-fun-blocks debug-fun
)
1482 (parse-debug-blocks debug-fun
))
1483 (unless (debug-fun-blocks debug-fun
)
1484 (debug-signal 'no-debug-blocks
1485 :debug-fun debug-fun
))
1486 (debug-fun-blocks debug-fun
))
1489 (debug-signal 'no-debug-blocks
1490 :debug-fun debug-fun
)))))
1492 ;;; Return a SIMPLE-VECTOR of DEBUG-BLOCKs or NIL. NIL indicates there
1493 ;;; was no basic block information.
1494 (defun parse-debug-blocks (debug-fun)
1495 (etypecase debug-fun
1497 (parse-compiled-debug-blocks debug-fun
))
1499 (debug-signal 'no-debug-blocks
:debug-fun debug-fun
))))
1501 ;;; This does some of the work of PARSE-DEBUG-BLOCKS.
1502 (defun parse-compiled-debug-blocks (debug-fun)
1503 (let* ((var-count (length (debug-fun-debug-vars debug-fun
)))
1504 (compiler-debug-fun (compiled-debug-fun-compiler-debug-fun
1506 (blocks (sb!c
::compiled-debug-fun-blocks compiler-debug-fun
))
1507 ;; KLUDGE: 8 is a hard-wired constant in the compiler for the
1508 ;; element size of the packed binary representation of the
1510 (live-set-len (ceiling var-count
8))
1511 (tlf-number (sb!c
::compiled-debug-fun-tlf-number compiler-debug-fun
)))
1513 (return-from parse-compiled-debug-blocks nil
))
1514 (macrolet ((aref+ (a i
) `(prog1 (aref ,a
,i
) (incf ,i
))))
1515 (with-parsing-buffer (blocks-buffer locations-buffer
)
1517 (len (length blocks
))
1520 (when (>= i len
) (return))
1521 (let ((succ-and-flags (aref+ blocks i
))
1523 (declare (type (unsigned-byte 8) succ-and-flags
)
1525 (dotimes (k (ldb sb
!c
::compiled-debug-block-nsucc-byte
1527 (push (sb!c
:read-var-integer blocks i
) successors
))
1529 (dotimes (k (sb!c
:read-var-integer blocks i
)
1530 (result locations-buffer
))
1531 (let ((kind (svref sb
!c
::*compiled-code-location-kinds
*
1534 (sb!c
:read-var-integer blocks i
)))
1535 (tlf-offset (or tlf-number
1536 (sb!c
:read-var-integer blocks i
)))
1537 (form-number (sb!c
:read-var-integer blocks i
))
1538 (live-set (sb!c
:read-packed-bit-vector
1539 live-set-len blocks i
)))
1540 (vector-push-extend (make-known-code-location
1541 pc debug-fun tlf-offset
1542 form-number live-set kind
)
1544 (setf last-pc pc
))))
1545 (block (make-compiled-debug-block
1546 locations successors
1548 sb
!c
::compiled-debug-block-elsewhere-p
1549 succ-and-flags
))))))
1550 (vector-push-extend block blocks-buffer
)
1551 (dotimes (k (length locations
))
1552 (setf (code-location-%debug-block
(svref locations k
))
1554 (let ((res (result blocks-buffer
)))
1555 (declare (simple-vector res
))
1556 (dotimes (i (length res
))
1557 (let* ((block (svref res i
))
1559 (dolist (ele (debug-block-successors block
))
1560 (push (svref res ele
) succs
))
1561 (setf (debug-block-successors block
) succs
)))
1564 ;;; The argument is a debug internals structure. This returns NIL if
1565 ;;; there is no variable information. It returns an empty
1566 ;;; simple-vector if there were no locals in the function. Otherwise
1567 ;;; it returns a SIMPLE-VECTOR of DEBUG-VARs.
1568 (defun debug-fun-debug-vars (debug-fun)
1569 (let ((vars (debug-fun-%debug-vars debug-fun
)))
1570 (if (eq vars
:unparsed
)
1571 (setf (debug-fun-%debug-vars debug-fun
)
1572 (etypecase debug-fun
1574 (parse-compiled-debug-vars debug-fun
))
1575 (bogus-debug-fun nil
)))
1578 ;;; VARS is the parsed variables for a minimal debug function. We need
1579 ;;; to assign names of the form ARG-NNN. We must pad with leading
1580 ;;; zeros, since the arguments must be in alphabetical order.
1581 (defun assign-minimal-var-names (vars)
1582 (declare (simple-vector vars
))
1583 (let* ((len (length vars
))
1584 (width (length (format nil
"~W" (1- len
)))))
1586 (setf (compiled-debug-var-symbol (svref vars i
))
1587 (intern (format nil
"ARG-~V,'0D" width i
)
1588 ;; KLUDGE: It's somewhat nasty to have a bare
1589 ;; package name string here. It would be
1590 ;; nicer to have #.(FIND-PACKAGE "SB!DEBUG")
1591 ;; instead, since then at least it would transform
1592 ;; correctly under package renaming and stuff.
1593 ;; However, genesis can't handle dumped packages..
1596 ;; FIXME: Maybe this could be fixed by moving the
1597 ;; whole debug-int.lisp file to warm init? (after
1598 ;; which dumping a #.(FIND-PACKAGE ..) expression
1599 ;; would work fine) If this is possible, it would
1600 ;; probably be a good thing, since minimizing the
1601 ;; amount of stuff in cold init is basically good.
1602 (or (find-package "SB-DEBUG")
1603 (find-package "SB!DEBUG")))))))
1605 ;;; Parse the packed representation of DEBUG-VARs from
1606 ;;; DEBUG-FUN's SB!C::COMPILED-DEBUG-FUN, returning a vector
1607 ;;; of DEBUG-VARs, or NIL if there was no information to parse.
1608 (defun parse-compiled-debug-vars (debug-fun)
1609 (let* ((cdebug-fun (compiled-debug-fun-compiler-debug-fun
1611 (packed-vars (sb!c
::compiled-debug-fun-vars cdebug-fun
))
1612 (args-minimal (eq (sb!c
::compiled-debug-fun-arguments cdebug-fun
)
1616 (buffer (make-array 0 :fill-pointer
0 :adjustable t
)))
1617 ((>= i
(length packed-vars
))
1618 (let ((result (coerce buffer
'simple-vector
)))
1620 (assign-minimal-var-names result
))
1622 (flet ((geti () (prog1 (aref packed-vars i
) (incf i
))))
1623 (let* ((flags (geti))
1624 (minimal (logtest sb
!c
::compiled-debug-var-minimal-p flags
))
1625 (deleted (logtest sb
!c
::compiled-debug-var-deleted-p flags
))
1626 (live (logtest sb
!c
::compiled-debug-var-environment-live
1628 (save (logtest sb
!c
::compiled-debug-var-save-loc-p flags
))
1629 (symbol (if minimal nil
(geti)))
1630 (id (if (logtest sb
!c
::compiled-debug-var-id-p flags
)
1633 (sc-offset (if deleted
0 (geti)))
1634 (save-sc-offset (if save
(geti) nil
)))
1635 (aver (not (and args-minimal
(not minimal
))))
1636 (vector-push-extend (make-compiled-debug-var symbol
1645 ;;; If we're sure of whether code-location is known, return T or NIL.
1646 ;;; If we're :UNSURE, then try to fill in the code-location's slots.
1647 ;;; This determines whether there is any debug-block information, and
1648 ;;; if code-location is known.
1650 ;;; ??? IF this conses closures every time it's called, then break off the
1651 ;;; :UNSURE part to get the HANDLER-CASE into another function.
1652 (defun code-location-unknown-p (basic-code-location)
1653 (ecase (code-location-%unknown-p basic-code-location
)
1657 (setf (code-location-%unknown-p basic-code-location
)
1658 (handler-case (not (fill-in-code-location basic-code-location
))
1659 (no-debug-blocks () t
))))))
1661 ;;; Return the DEBUG-BLOCK containing code-location if it is available.
1662 ;;; Some debug policies inhibit debug-block information, and if none
1663 ;;; is available, then this signals a NO-DEBUG-BLOCKS condition.
1664 (defun code-location-debug-block (basic-code-location)
1665 (let ((block (code-location-%debug-block basic-code-location
)))
1666 (if (eq block
:unparsed
)
1667 (etypecase basic-code-location
1668 (compiled-code-location
1669 (compute-compiled-code-location-debug-block basic-code-location
))
1670 ;; (There used to be more cases back before sbcl-0.7.0, when
1671 ;; we did special tricks to debug the IR1 interpreter.)
1675 ;;; Store and return BASIC-CODE-LOCATION's debug-block. We determines
1676 ;;; the correct one using the code-location's pc. We use
1677 ;;; DEBUG-FUN-DEBUG-BLOCKS to return the cached block information
1678 ;;; or signal a NO-DEBUG-BLOCKS condition. The blocks are sorted by
1679 ;;; their first code-location's pc, in ascending order. Therefore, as
1680 ;;; soon as we find a block that starts with a pc greater than
1681 ;;; basic-code-location's pc, we know the previous block contains the
1682 ;;; pc. If we get to the last block, then the code-location is either
1683 ;;; in the second to last block or the last block, and we have to be
1684 ;;; careful in determining this since the last block could be code at
1685 ;;; the end of the function. We have to check for the last block being
1686 ;;; code first in order to see how to compare the code-location's pc.
1687 (defun compute-compiled-code-location-debug-block (basic-code-location)
1688 (let* ((pc (compiled-code-location-pc basic-code-location
))
1689 (debug-fun (code-location-debug-fun
1690 basic-code-location
))
1691 (blocks (debug-fun-debug-blocks debug-fun
))
1692 (len (length blocks
)))
1693 (declare (simple-vector blocks
))
1694 (setf (code-location-%debug-block basic-code-location
)
1700 (let ((last (svref blocks end
)))
1702 ((debug-block-elsewhere-p last
)
1704 (sb!c
::compiled-debug-fun-elsewhere-pc
1705 (compiled-debug-fun-compiler-debug-fun
1707 (svref blocks
(1- end
))
1710 (compiled-code-location-pc
1711 (svref (compiled-debug-block-code-locations last
)
1713 (svref blocks
(1- end
)))
1715 (declare (type index i end
))
1717 (compiled-code-location-pc
1718 (svref (compiled-debug-block-code-locations
1721 (return (svref blocks
(1- i
)))))))))
1723 ;;; Return the CODE-LOCATION's DEBUG-SOURCE.
1724 (defun code-location-debug-source (code-location)
1725 (etypecase code-location
1726 (compiled-code-location
1727 (let* ((info (compiled-debug-fun-debug-info
1728 (code-location-debug-fun code-location
)))
1729 (sources (sb!c
::compiled-debug-info-source info
))
1730 (len (length sources
)))
1731 (declare (list sources
))
1733 (debug-signal 'no-debug-blocks
:debug-fun
1734 (code-location-debug-fun code-location
)))
1737 (do ((prev sources src
)
1738 (src (cdr sources
) (cdr src
))
1739 (offset (code-location-toplevel-form-offset code-location
)))
1740 ((null src
) (car prev
))
1741 (when (< offset
(sb!c
::debug-source-source-root
(car src
)))
1742 (return (car prev
)))))))
1743 ;; (There used to be more cases back before sbcl-0.7.0, when we
1744 ;; did special tricks to debug the IR1 interpreter.)
1747 ;;; Returns the number of top level forms before the one containing
1748 ;;; CODE-LOCATION as seen by the compiler in some compilation unit. (A
1749 ;;; compilation unit is not necessarily a single file, see the section
1750 ;;; on debug-sources.)
1751 (defun code-location-toplevel-form-offset (code-location)
1752 (when (code-location-unknown-p code-location
)
1753 (error 'unknown-code-location
:code-location code-location
))
1754 (let ((tlf-offset (code-location-%tlf-offset code-location
)))
1755 (cond ((eq tlf-offset
:unparsed
)
1756 (etypecase code-location
1757 (compiled-code-location
1758 (unless (fill-in-code-location code-location
)
1759 ;; This check should be unnecessary. We're missing
1760 ;; debug info the compiler should have dumped.
1761 (bug "unknown code location"))
1762 (code-location-%tlf-offset code-location
))
1763 ;; (There used to be more cases back before sbcl-0.7.0,,
1764 ;; when we did special tricks to debug the IR1
1769 ;;; Return the number of the form corresponding to CODE-LOCATION. The
1770 ;;; form number is derived by a walking the subforms of a top level
1771 ;;; form in depth-first order.
1772 (defun code-location-form-number (code-location)
1773 (when (code-location-unknown-p code-location
)
1774 (error 'unknown-code-location
:code-location code-location
))
1775 (let ((form-num (code-location-%form-number code-location
)))
1776 (cond ((eq form-num
:unparsed
)
1777 (etypecase code-location
1778 (compiled-code-location
1779 (unless (fill-in-code-location code-location
)
1780 ;; This check should be unnecessary. We're missing
1781 ;; debug info the compiler should have dumped.
1782 (bug "unknown code location"))
1783 (code-location-%form-number code-location
))
1784 ;; (There used to be more cases back before sbcl-0.7.0,,
1785 ;; when we did special tricks to debug the IR1
1790 ;;; Return the kind of CODE-LOCATION, one of:
1791 ;;; :INTERPRETED, :UNKNOWN-RETURN, :KNOWN-RETURN, :INTERNAL-ERROR,
1792 ;;; :NON-LOCAL-EXIT, :BLOCK-START, :CALL-SITE, :SINGLE-VALUE-RETURN,
1793 ;;; :NON-LOCAL-ENTRY
1794 (defun code-location-kind (code-location)
1795 (when (code-location-unknown-p code-location
)
1796 (error 'unknown-code-location
:code-location code-location
))
1797 (etypecase code-location
1798 (compiled-code-location
1799 (let ((kind (compiled-code-location-kind code-location
)))
1800 (cond ((not (eq kind
:unparsed
)) kind
)
1801 ((not (fill-in-code-location code-location
))
1802 ;; This check should be unnecessary. We're missing
1803 ;; debug info the compiler should have dumped.
1804 (bug "unknown code location"))
1806 (compiled-code-location-kind code-location
)))))
1807 ;; (There used to be more cases back before sbcl-0.7.0,,
1808 ;; when we did special tricks to debug the IR1
1812 ;;; This returns CODE-LOCATION's live-set if it is available. If
1813 ;;; there is no debug-block information, this returns NIL.
1814 (defun compiled-code-location-live-set (code-location)
1815 (if (code-location-unknown-p code-location
)
1817 (let ((live-set (compiled-code-location-%live-set code-location
)))
1818 (cond ((eq live-set
:unparsed
)
1819 (unless (fill-in-code-location code-location
)
1820 ;; This check should be unnecessary. We're missing
1821 ;; debug info the compiler should have dumped.
1823 ;; FIXME: This error and comment happen over and over again.
1824 ;; Make them a shared function.
1825 (bug "unknown code location"))
1826 (compiled-code-location-%live-set code-location
))
1829 ;;; true if OBJ1 and OBJ2 are the same place in the code
1830 (defun code-location= (obj1 obj2
)
1832 (compiled-code-location
1834 (compiled-code-location
1835 (and (eq (code-location-debug-fun obj1
)
1836 (code-location-debug-fun obj2
))
1837 (sub-compiled-code-location= obj1 obj2
)))
1838 ;; (There used to be more cases back before sbcl-0.7.0,,
1839 ;; when we did special tricks to debug the IR1
1842 ;; (There used to be more cases back before sbcl-0.7.0,,
1843 ;; when we did special tricks to debug IR1-interpreted code.)
1845 (defun sub-compiled-code-location= (obj1 obj2
)
1846 (= (compiled-code-location-pc obj1
)
1847 (compiled-code-location-pc obj2
)))
1849 ;;; Fill in CODE-LOCATION's :UNPARSED slots, returning T or NIL
1850 ;;; depending on whether the code-location was known in its
1851 ;;; DEBUG-FUN's debug-block information. This may signal a
1852 ;;; NO-DEBUG-BLOCKS condition due to DEBUG-FUN-DEBUG-BLOCKS, and
1853 ;;; it assumes the %UNKNOWN-P slot is already set or going to be set.
1854 (defun fill-in-code-location (code-location)
1855 (declare (type compiled-code-location code-location
))
1856 (let* ((debug-fun (code-location-debug-fun code-location
))
1857 (blocks (debug-fun-debug-blocks debug-fun
)))
1858 (declare (simple-vector blocks
))
1859 (dotimes (i (length blocks
) nil
)
1860 (let* ((block (svref blocks i
))
1861 (locations (compiled-debug-block-code-locations block
)))
1862 (declare (simple-vector locations
))
1863 (dotimes (j (length locations
))
1864 (let ((loc (svref locations j
)))
1865 (when (sub-compiled-code-location= code-location loc
)
1866 (setf (code-location-%debug-block code-location
) block
)
1867 (setf (code-location-%tlf-offset code-location
)
1868 (code-location-%tlf-offset loc
))
1869 (setf (code-location-%form-number code-location
)
1870 (code-location-%form-number loc
))
1871 (setf (compiled-code-location-%live-set code-location
)
1872 (compiled-code-location-%live-set loc
))
1873 (setf (compiled-code-location-kind code-location
)
1874 (compiled-code-location-kind loc
))
1875 (return-from fill-in-code-location t
))))))))
1877 ;;;; operations on DEBUG-BLOCKs
1879 ;;; Execute FORMS in a context with CODE-VAR bound to each
1880 ;;; CODE-LOCATION in DEBUG-BLOCK, and return the value of RESULT.
1881 (defmacro do-debug-block-locations
((code-var debug-block
&optional result
)
1883 (let ((code-locations (gensym))
1885 `(let ((,code-locations
(debug-block-code-locations ,debug-block
)))
1886 (declare (simple-vector ,code-locations
))
1887 (dotimes (,i
(length ,code-locations
) ,result
)
1888 (let ((,code-var
(svref ,code-locations
,i
)))
1891 ;;; Return the name of the function represented by DEBUG-FUN.
1892 ;;; This may be a string or a cons; do not assume it is a symbol.
1893 (defun debug-block-fun-name (debug-block)
1894 (etypecase debug-block
1895 (compiled-debug-block
1896 (let ((code-locs (compiled-debug-block-code-locations debug-block
)))
1897 (declare (simple-vector code-locs
))
1898 (if (zerop (length code-locs
))
1899 "??? Can't get name of debug-block's function."
1901 (code-location-debug-fun (svref code-locs
0))))))
1902 ;; (There used to be more cases back before sbcl-0.7.0, when we
1903 ;; did special tricks to debug the IR1 interpreter.)
1906 (defun debug-block-code-locations (debug-block)
1907 (etypecase debug-block
1908 (compiled-debug-block
1909 (compiled-debug-block-code-locations debug-block
))
1910 ;; (There used to be more cases back before sbcl-0.7.0, when we
1911 ;; did special tricks to debug the IR1 interpreter.)
1914 ;;;; operations on debug variables
1916 (defun debug-var-symbol-name (debug-var)
1917 (symbol-name (debug-var-symbol debug-var
)))
1919 ;;; FIXME: Make sure that this isn't called anywhere that it wouldn't
1920 ;;; be acceptable to have NIL returned, or that it's only called on
1921 ;;; DEBUG-VARs whose symbols have non-NIL packages.
1922 (defun debug-var-package-name (debug-var)
1923 (package-name (symbol-package (debug-var-symbol debug-var
))))
1925 ;;; Return the value stored for DEBUG-VAR in frame, or if the value is
1926 ;;; not :VALID, then signal an INVALID-VALUE error.
1927 (defun debug-var-valid-value (debug-var frame
)
1928 (unless (eq (debug-var-validity debug-var
(frame-code-location frame
))
1930 (error 'invalid-value
:debug-var debug-var
:frame frame
))
1931 (debug-var-value debug-var frame
))
1933 ;;; Returns the value stored for DEBUG-VAR in frame. The value may be
1934 ;;; invalid. This is SETFable.
1935 (defun debug-var-value (debug-var frame
)
1936 (aver (typep frame
'compiled-frame
))
1937 (let ((res (access-compiled-debug-var-slot debug-var frame
)))
1938 (if (indirect-value-cell-p res
)
1939 (value-cell-ref res
)
1942 ;;; This returns what is stored for the variable represented by
1943 ;;; DEBUG-VAR relative to the FRAME. This may be an indirect value
1944 ;;; cell if the variable is both closed over and set.
1945 (defun access-compiled-debug-var-slot (debug-var frame
)
1946 (declare (optimize (speed 1)))
1947 (let ((escaped (compiled-frame-escaped frame
)))
1949 (sub-access-debug-var-slot
1950 (frame-pointer frame
)
1951 (compiled-debug-var-sc-offset debug-var
)
1953 (sub-access-debug-var-slot
1954 (frame-pointer frame
)
1955 (or (compiled-debug-var-save-sc-offset debug-var
)
1956 (compiled-debug-var-sc-offset debug-var
))))))
1958 ;;; a helper function for working with possibly-invalid values:
1959 ;;; Do (MAKE-LISP-OBJ VAL) only if the value looks valid.
1961 ;;; (Such values can arise in registers on machines with conservative
1962 ;;; GC, and might also arise in debug variable locations when
1963 ;;; those variables are invalid.)
1964 (defun make-valid-lisp-obj (val)
1967 (zerop (logand val
3))
1969 (and (zerop (logand val
#xffff0000
)) ; Top bits zero
1970 (= (logand val
#xff
) sb
!vm
:base-char-widetag
)) ; char tag
1972 (= val sb
!vm
:unbound-marker-widetag
)
1975 ;; Check that the pointer is valid. XXX Could do a better
1976 ;; job. FIXME: e.g. by calling out to an is_valid_pointer
1977 ;; routine in the C runtime support code
1978 (or (< sb
!vm
:read-only-space-start val
1979 (* sb
!vm
:*read-only-space-free-pointer
*
1980 sb
!vm
:n-word-bytes
))
1981 (< sb
!vm
:static-space-start val
1982 (* sb
!vm
:*static-space-free-pointer
*
1983 sb
!vm
:n-word-bytes
))
1984 (< sb
!vm
:dynamic-space-start val
1985 (sap-int (dynamic-space-free-pointer))))))
1990 (defun sub-access-debug-var-slot (fp sc-offset
&optional escaped
)
1991 (macrolet ((with-escaped-value ((var) &body forms
)
1993 (let ((,var
(sb!vm
:context-register
1995 (sb!c
:sc-offset-offset sc-offset
))))
1997 :invalid-value-for-unescaped-register-storage
))
1998 (escaped-float-value (format)
2000 (sb!vm
:context-float-register
2002 (sb!c
:sc-offset-offset sc-offset
)
2004 :invalid-value-for-unescaped-register-storage
))
2005 (with-nfp ((var) &body body
)
2006 `(let ((,var
(if escaped
2008 (sb!vm
:context-register escaped
2011 (sb!sys
:sap-ref-sap fp
(* nfp-save-offset
2012 sb
!vm
:n-word-bytes
))
2014 (sb!vm
::make-number-stack-pointer
2015 (sb!sys
:sap-ref-32 fp
(* nfp-save-offset
2016 sb
!vm
:n-word-bytes
))))))
2018 (ecase (sb!c
:sc-offset-scn sc-offset
)
2019 ((#.sb
!vm
:any-reg-sc-number
2020 #.sb
!vm
:descriptor-reg-sc-number
2021 #!+rt
#.sb
!vm
:word-pointer-reg-sc-number
)
2022 (sb!sys
:without-gcing
2023 (with-escaped-value (val) (sb!kernel
:make-lisp-obj val
))))
2025 (#.sb
!vm
:base-char-reg-sc-number
2026 (with-escaped-value (val)
2028 (#.sb
!vm
:sap-reg-sc-number
2029 (with-escaped-value (val)
2030 (sb!sys
:int-sap val
)))
2031 (#.sb
!vm
:signed-reg-sc-number
2032 (with-escaped-value (val)
2033 (if (logbitp (1- sb
!vm
:n-word-bits
) val
)
2034 (logior val
(ash -
1 sb
!vm
:n-word-bits
))
2036 (#.sb
!vm
:unsigned-reg-sc-number
2037 (with-escaped-value (val)
2039 (#.sb
!vm
:non-descriptor-reg-sc-number
2040 (error "Local non-descriptor register access?"))
2041 (#.sb
!vm
:interior-reg-sc-number
2042 (error "Local interior register access?"))
2043 (#.sb
!vm
:single-reg-sc-number
2044 (escaped-float-value single-float
))
2045 (#.sb
!vm
:double-reg-sc-number
2046 (escaped-float-value double-float
))
2048 (#.sb
!vm
:long-reg-sc-number
2049 (escaped-float-value long-float
))
2050 (#.sb
!vm
:complex-single-reg-sc-number
2053 (sb!vm
:context-float-register
2054 escaped
(sb!c
:sc-offset-offset sc-offset
) 'single-float
)
2055 (sb!vm
:context-float-register
2056 escaped
(1+ (sb!c
:sc-offset-offset sc-offset
)) 'single-float
))
2057 :invalid-value-for-unescaped-register-storage
))
2058 (#.sb
!vm
:complex-double-reg-sc-number
2061 (sb!vm
:context-float-register
2062 escaped
(sb!c
:sc-offset-offset sc-offset
) 'double-float
)
2063 (sb!vm
:context-float-register
2064 escaped
(+ (sb!c
:sc-offset-offset sc-offset
) #!+sparc
2 #!-sparc
1)
2066 :invalid-value-for-unescaped-register-storage
))
2068 (#.sb
!vm
:complex-long-reg-sc-number
2071 (sb!vm
:context-float-register
2072 escaped
(sb!c
:sc-offset-offset sc-offset
) 'long-float
)
2073 (sb!vm
:context-float-register
2074 escaped
(+ (sb!c
:sc-offset-offset sc-offset
) #!+sparc
4)
2076 :invalid-value-for-unescaped-register-storage
))
2077 (#.sb
!vm
:single-stack-sc-number
2079 (sb!sys
:sap-ref-single nfp
(* (sb!c
:sc-offset-offset sc-offset
)
2080 sb
!vm
:n-word-bytes
))))
2081 (#.sb
!vm
:double-stack-sc-number
2083 (sb!sys
:sap-ref-double nfp
(* (sb!c
:sc-offset-offset sc-offset
)
2084 sb
!vm
:n-word-bytes
))))
2086 (#.sb
!vm
:long-stack-sc-number
2088 (sb!sys
:sap-ref-long nfp
(* (sb!c
:sc-offset-offset sc-offset
)
2089 sb
!vm
:n-word-bytes
))))
2090 (#.sb
!vm
:complex-single-stack-sc-number
2093 (sb!sys
:sap-ref-single nfp
(* (sb!c
:sc-offset-offset sc-offset
)
2094 sb
!vm
:n-word-bytes
))
2095 (sb!sys
:sap-ref-single nfp
(* (1+ (sb!c
:sc-offset-offset sc-offset
))
2096 sb
!vm
:n-word-bytes
)))))
2097 (#.sb
!vm
:complex-double-stack-sc-number
2100 (sb!sys
:sap-ref-double nfp
(* (sb!c
:sc-offset-offset sc-offset
)
2101 sb
!vm
:n-word-bytes
))
2102 (sb!sys
:sap-ref-double nfp
(* (+ (sb!c
:sc-offset-offset sc-offset
) 2)
2103 sb
!vm
:n-word-bytes
)))))
2105 (#.sb
!vm
:complex-long-stack-sc-number
2108 (sb!sys
:sap-ref-long nfp
(* (sb!c
:sc-offset-offset sc-offset
)
2109 sb
!vm
:n-word-bytes
))
2110 (sb!sys
:sap-ref-long nfp
(* (+ (sb!c
:sc-offset-offset sc-offset
)
2112 sb
!vm
:n-word-bytes
)))))
2113 (#.sb
!vm
:control-stack-sc-number
2114 (sb!kernel
:stack-ref fp
(sb!c
:sc-offset-offset sc-offset
)))
2115 (#.sb
!vm
:base-char-stack-sc-number
2117 (code-char (sb!sys
:sap-ref-32 nfp
(* (sb!c
:sc-offset-offset sc-offset
)
2118 sb
!vm
:n-word-bytes
)))))
2119 (#.sb
!vm
:unsigned-stack-sc-number
2121 (sb!sys
:sap-ref-32 nfp
(* (sb!c
:sc-offset-offset sc-offset
)
2122 sb
!vm
:n-word-bytes
))))
2123 (#.sb
!vm
:signed-stack-sc-number
2125 (sb!sys
:signed-sap-ref-32 nfp
(* (sb!c
:sc-offset-offset sc-offset
)
2126 sb
!vm
:n-word-bytes
))))
2127 (#.sb
!vm
:sap-stack-sc-number
2129 (sb!sys
:sap-ref-sap nfp
(* (sb!c
:sc-offset-offset sc-offset
)
2130 sb
!vm
:n-word-bytes
)))))))
2133 (defun sub-access-debug-var-slot (fp sc-offset
&optional escaped
)
2134 (declare (type system-area-pointer fp
))
2135 (macrolet ((with-escaped-value ((var) &body forms
)
2137 (let ((,var
(sb!vm
:context-register
2139 (sb!c
:sc-offset-offset sc-offset
))))
2141 :invalid-value-for-unescaped-register-storage
))
2142 (escaped-float-value (format)
2144 (sb!vm
:context-float-register
2145 escaped
(sb!c
:sc-offset-offset sc-offset
) ',format
)
2146 :invalid-value-for-unescaped-register-storage
))
2147 (escaped-complex-float-value (format)
2150 (sb!vm
:context-float-register
2151 escaped
(sb!c
:sc-offset-offset sc-offset
) ',format
)
2152 (sb!vm
:context-float-register
2153 escaped
(1+ (sb!c
:sc-offset-offset sc-offset
)) ',format
))
2154 :invalid-value-for-unescaped-register-storage
)))
2155 (ecase (sb!c
:sc-offset-scn sc-offset
)
2156 ((#.sb
!vm
:any-reg-sc-number
#.sb
!vm
:descriptor-reg-sc-number
)
2158 (with-escaped-value (val)
2159 (make-valid-lisp-obj val
))))
2160 (#.sb
!vm
:base-char-reg-sc-number
2161 (with-escaped-value (val)
2163 (#.sb
!vm
:sap-reg-sc-number
2164 (with-escaped-value (val)
2166 (#.sb
!vm
:signed-reg-sc-number
2167 (with-escaped-value (val)
2168 (if (logbitp (1- sb
!vm
:n-word-bits
) val
)
2169 (logior val
(ash -
1 sb
!vm
:n-word-bits
))
2171 (#.sb
!vm
:unsigned-reg-sc-number
2172 (with-escaped-value (val)
2174 (#.sb
!vm
:single-reg-sc-number
2175 (escaped-float-value single-float
))
2176 (#.sb
!vm
:double-reg-sc-number
2177 (escaped-float-value double-float
))
2179 (#.sb
!vm
:long-reg-sc-number
2180 (escaped-float-value long-float
))
2181 (#.sb
!vm
:complex-single-reg-sc-number
2182 (escaped-complex-float-value single-float
))
2183 (#.sb
!vm
:complex-double-reg-sc-number
2184 (escaped-complex-float-value double-float
))
2186 (#.sb
!vm
:complex-long-reg-sc-number
2187 (escaped-complex-float-value long-float
))
2188 (#.sb
!vm
:single-stack-sc-number
2189 (sap-ref-single fp
(- (* (1+ (sb!c
:sc-offset-offset sc-offset
))
2190 sb
!vm
:n-word-bytes
))))
2191 (#.sb
!vm
:double-stack-sc-number
2192 (sap-ref-double fp
(- (* (+ (sb!c
:sc-offset-offset sc-offset
) 2)
2193 sb
!vm
:n-word-bytes
))))
2195 (#.sb
!vm
:long-stack-sc-number
2196 (sap-ref-long fp
(- (* (+ (sb!c
:sc-offset-offset sc-offset
) 3)
2197 sb
!vm
:n-word-bytes
))))
2198 (#.sb
!vm
:complex-single-stack-sc-number
2200 (sap-ref-single fp
(- (* (1+ (sb!c
:sc-offset-offset sc-offset
))
2201 sb
!vm
:n-word-bytes
)))
2202 (sap-ref-single fp
(- (* (+ (sb!c
:sc-offset-offset sc-offset
) 2)
2203 sb
!vm
:n-word-bytes
)))))
2204 (#.sb
!vm
:complex-double-stack-sc-number
2206 (sap-ref-double fp
(- (* (+ (sb!c
:sc-offset-offset sc-offset
) 2)
2207 sb
!vm
:n-word-bytes
)))
2208 (sap-ref-double fp
(- (* (+ (sb!c
:sc-offset-offset sc-offset
) 4)
2209 sb
!vm
:n-word-bytes
)))))
2211 (#.sb
!vm
:complex-long-stack-sc-number
2213 (sap-ref-long fp
(- (* (+ (sb!c
:sc-offset-offset sc-offset
) 3)
2214 sb
!vm
:n-word-bytes
)))
2215 (sap-ref-long fp
(- (* (+ (sb!c
:sc-offset-offset sc-offset
) 6)
2216 sb
!vm
:n-word-bytes
)))))
2217 (#.sb
!vm
:control-stack-sc-number
2218 (stack-ref fp
(sb!c
:sc-offset-offset sc-offset
)))
2219 (#.sb
!vm
:base-char-stack-sc-number
2221 (sap-ref-32 fp
(- (* (1+ (sb!c
:sc-offset-offset sc-offset
))
2222 sb
!vm
:n-word-bytes
)))))
2223 (#.sb
!vm
:unsigned-stack-sc-number
2224 (sap-ref-32 fp
(- (* (1+ (sb!c
:sc-offset-offset sc-offset
))
2225 sb
!vm
:n-word-bytes
))))
2226 (#.sb
!vm
:signed-stack-sc-number
2227 (signed-sap-ref-32 fp
(- (* (1+ (sb!c
:sc-offset-offset sc-offset
))
2228 sb
!vm
:n-word-bytes
))))
2229 (#.sb
!vm
:sap-stack-sc-number
2230 (sap-ref-sap fp
(- (* (1+ (sb!c
:sc-offset-offset sc-offset
))
2231 sb
!vm
:n-word-bytes
)))))))
2233 ;;; This stores value as the value of DEBUG-VAR in FRAME. In the
2234 ;;; COMPILED-DEBUG-VAR case, access the current value to determine if
2235 ;;; it is an indirect value cell. This occurs when the variable is
2236 ;;; both closed over and set.
2237 (defun %set-debug-var-value
(debug-var frame new-value
)
2238 (aver (typep frame
'compiled-frame
))
2239 (let ((old-value (access-compiled-debug-var-slot debug-var frame
)))
2240 (if (indirect-value-cell-p old-value
)
2241 (value-cell-set old-value new-value
)
2242 (set-compiled-debug-var-slot debug-var frame new-value
)))
2245 ;;; This stores VALUE for the variable represented by debug-var
2246 ;;; relative to the frame. This assumes the location directly contains
2247 ;;; the variable's value; that is, there is no indirect value cell
2248 ;;; currently there in case the variable is both closed over and set.
2249 (defun set-compiled-debug-var-slot (debug-var frame value
)
2250 (let ((escaped (compiled-frame-escaped frame
)))
2252 (sub-set-debug-var-slot (frame-pointer frame
)
2253 (compiled-debug-var-sc-offset debug-var
)
2255 (sub-set-debug-var-slot
2256 (frame-pointer frame
)
2257 (or (compiled-debug-var-save-sc-offset debug-var
)
2258 (compiled-debug-var-sc-offset debug-var
))
2262 (defun sub-set-debug-var-slot (fp sc-offset value
&optional escaped
)
2263 (macrolet ((set-escaped-value (val)
2265 (setf (sb!vm
:context-register
2267 (sb!c
:sc-offset-offset sc-offset
))
2270 (set-escaped-float-value (format val
)
2272 (setf (sb!vm
:context-float-register
2274 (sb!c
:sc-offset-offset sc-offset
)
2278 (with-nfp ((var) &body body
)
2279 `(let ((,var
(if escaped
2281 (sb!vm
:context-register escaped
2286 sb
!vm
:n-word-bytes
))
2288 (sb!vm
::make-number-stack-pointer
2291 sb
!vm
:n-word-bytes
))))))
2293 (ecase (sb!c
:sc-offset-scn sc-offset
)
2294 ((#.sb
!vm
:any-reg-sc-number
2295 #.sb
!vm
:descriptor-reg-sc-number
2296 #!+rt
#.sb
!vm
:word-pointer-reg-sc-number
)
2299 (get-lisp-obj-address value
))))
2300 (#.sb
!vm
:base-char-reg-sc-number
2301 (set-escaped-value (char-code value
)))
2302 (#.sb
!vm
:sap-reg-sc-number
2303 (set-escaped-value (sap-int value
)))
2304 (#.sb
!vm
:signed-reg-sc-number
2305 (set-escaped-value (logand value
(1- (ash 1 sb
!vm
:n-word-bits
)))))
2306 (#.sb
!vm
:unsigned-reg-sc-number
2307 (set-escaped-value value
))
2308 (#.sb
!vm
:non-descriptor-reg-sc-number
2309 (error "Local non-descriptor register access?"))
2310 (#.sb
!vm
:interior-reg-sc-number
2311 (error "Local interior register access?"))
2312 (#.sb
!vm
:single-reg-sc-number
2313 (set-escaped-float-value single-float value
))
2314 (#.sb
!vm
:double-reg-sc-number
2315 (set-escaped-float-value double-float value
))
2317 (#.sb
!vm
:long-reg-sc-number
2318 (set-escaped-float-value long-float value
))
2319 (#.sb
!vm
:complex-single-reg-sc-number
2321 (setf (sb!vm
:context-float-register escaped
2322 (sb!c
:sc-offset-offset sc-offset
)
2325 (setf (sb!vm
:context-float-register
2326 escaped
(1+ (sb!c
:sc-offset-offset sc-offset
))
2330 (#.sb
!vm
:complex-double-reg-sc-number
2332 (setf (sb!vm
:context-float-register
2333 escaped
(sb!c
:sc-offset-offset sc-offset
) 'double-float
)
2335 (setf (sb!vm
:context-float-register
2337 (+ (sb!c
:sc-offset-offset sc-offset
) #!+sparc
2 #!-sparc
1)
2342 (#.sb
!vm
:complex-long-reg-sc-number
2344 (setf (sb!vm
:context-float-register
2345 escaped
(sb!c
:sc-offset-offset sc-offset
) 'long-float
)
2347 (setf (sb!vm
:context-float-register
2349 (+ (sb!c
:sc-offset-offset sc-offset
) #!+sparc
4)
2353 (#.sb
!vm
:single-stack-sc-number
2355 (setf (sap-ref-single nfp
(* (sb!c
:sc-offset-offset sc-offset
)
2356 sb
!vm
:n-word-bytes
))
2357 (the single-float value
))))
2358 (#.sb
!vm
:double-stack-sc-number
2360 (setf (sap-ref-double nfp
(* (sb!c
:sc-offset-offset sc-offset
)
2361 sb
!vm
:n-word-bytes
))
2362 (the double-float value
))))
2364 (#.sb
!vm
:long-stack-sc-number
2366 (setf (sap-ref-long nfp
(* (sb!c
:sc-offset-offset sc-offset
)
2367 sb
!vm
:n-word-bytes
))
2368 (the long-float value
))))
2369 (#.sb
!vm
:complex-single-stack-sc-number
2371 (setf (sap-ref-single
2372 nfp
(* (sb!c
:sc-offset-offset sc-offset
) sb
!vm
:n-word-bytes
))
2373 (the single-float
(realpart value
)))
2374 (setf (sap-ref-single
2375 nfp
(* (1+ (sb!c
:sc-offset-offset sc-offset
))
2376 sb
!vm
:n-word-bytes
))
2377 (the single-float
(realpart value
)))))
2378 (#.sb
!vm
:complex-double-stack-sc-number
2380 (setf (sap-ref-double
2381 nfp
(* (sb!c
:sc-offset-offset sc-offset
) sb
!vm
:n-word-bytes
))
2382 (the double-float
(realpart value
)))
2383 (setf (sap-ref-double
2384 nfp
(* (+ (sb!c
:sc-offset-offset sc-offset
) 2)
2385 sb
!vm
:n-word-bytes
))
2386 (the double-float
(realpart value
)))))
2388 (#.sb
!vm
:complex-long-stack-sc-number
2391 nfp
(* (sb!c
:sc-offset-offset sc-offset
) sb
!vm
:n-word-bytes
))
2392 (the long-float
(realpart value
)))
2394 nfp
(* (+ (sb!c
:sc-offset-offset sc-offset
) #!+sparc
4)
2395 sb
!vm
:n-word-bytes
))
2396 (the long-float
(realpart value
)))))
2397 (#.sb
!vm
:control-stack-sc-number
2398 (setf (stack-ref fp
(sb!c
:sc-offset-offset sc-offset
)) value
))
2399 (#.sb
!vm
:base-char-stack-sc-number
2401 (setf (sap-ref-32 nfp
(* (sb!c
:sc-offset-offset sc-offset
)
2402 sb
!vm
:n-word-bytes
))
2403 (char-code (the character value
)))))
2404 (#.sb
!vm
:unsigned-stack-sc-number
2406 (setf (sap-ref-32 nfp
(* (sb!c
:sc-offset-offset sc-offset
)
2407 sb
!vm
:n-word-bytes
))
2408 (the (unsigned-byte 32) value
))))
2409 (#.sb
!vm
:signed-stack-sc-number
2411 (setf (signed-sap-ref-32 nfp
(* (sb!c
:sc-offset-offset sc-offset
)
2412 sb
!vm
:n-word-bytes
))
2413 (the (signed-byte 32) value
))))
2414 (#.sb
!vm
:sap-stack-sc-number
2416 (setf (sap-ref-sap nfp
(* (sb!c
:sc-offset-offset sc-offset
)
2417 sb
!vm
:n-word-bytes
))
2418 (the system-area-pointer value
)))))))
2421 (defun sub-set-debug-var-slot (fp sc-offset value
&optional escaped
)
2422 (macrolet ((set-escaped-value (val)
2424 (setf (sb!vm
:context-register
2426 (sb!c
:sc-offset-offset sc-offset
))
2429 (ecase (sb!c
:sc-offset-scn sc-offset
)
2430 ((#.sb
!vm
:any-reg-sc-number
#.sb
!vm
:descriptor-reg-sc-number
)
2433 (get-lisp-obj-address value
))))
2434 (#.sb
!vm
:base-char-reg-sc-number
2435 (set-escaped-value (char-code value
)))
2436 (#.sb
!vm
:sap-reg-sc-number
2437 (set-escaped-value (sap-int value
)))
2438 (#.sb
!vm
:signed-reg-sc-number
2439 (set-escaped-value (logand value
(1- (ash 1 sb
!vm
:n-word-bits
)))))
2440 (#.sb
!vm
:unsigned-reg-sc-number
2441 (set-escaped-value value
))
2442 (#.sb
!vm
:single-reg-sc-number
2443 #+nil
;; don't have escaped floats.
2444 (set-escaped-float-value single-float value
))
2445 (#.sb
!vm
:double-reg-sc-number
2446 #+nil
;; don't have escaped floats -- still in npx?
2447 (set-escaped-float-value double-float value
))
2449 (#.sb
!vm
:long-reg-sc-number
2450 #+nil
;; don't have escaped floats -- still in npx?
2451 (set-escaped-float-value long-float value
))
2452 (#.sb
!vm
:single-stack-sc-number
2453 (setf (sap-ref-single
2454 fp
(- (* (1+ (sb!c
:sc-offset-offset sc-offset
))
2455 sb
!vm
:n-word-bytes
)))
2456 (the single-float value
)))
2457 (#.sb
!vm
:double-stack-sc-number
2458 (setf (sap-ref-double
2459 fp
(- (* (+ (sb!c
:sc-offset-offset sc-offset
) 2)
2460 sb
!vm
:n-word-bytes
)))
2461 (the double-float value
)))
2463 (#.sb
!vm
:long-stack-sc-number
2465 fp
(- (* (+ (sb!c
:sc-offset-offset sc-offset
) 3)
2466 sb
!vm
:n-word-bytes
)))
2467 (the long-float value
)))
2468 (#.sb
!vm
:complex-single-stack-sc-number
2469 (setf (sap-ref-single
2470 fp
(- (* (1+ (sb!c
:sc-offset-offset sc-offset
))
2471 sb
!vm
:n-word-bytes
)))
2472 (realpart (the (complex single-float
) value
)))
2473 (setf (sap-ref-single
2474 fp
(- (* (+ (sb!c
:sc-offset-offset sc-offset
) 2)
2475 sb
!vm
:n-word-bytes
)))
2476 (imagpart (the (complex single-float
) value
))))
2477 (#.sb
!vm
:complex-double-stack-sc-number
2478 (setf (sap-ref-double
2479 fp
(- (* (+ (sb!c
:sc-offset-offset sc-offset
) 2)
2480 sb
!vm
:n-word-bytes
)))
2481 (realpart (the (complex double-float
) value
)))
2482 (setf (sap-ref-double
2483 fp
(- (* (+ (sb!c
:sc-offset-offset sc-offset
) 4)
2484 sb
!vm
:n-word-bytes
)))
2485 (imagpart (the (complex double-float
) value
))))
2487 (#.sb
!vm
:complex-long-stack-sc-number
2489 fp
(- (* (+ (sb!c
:sc-offset-offset sc-offset
) 3)
2490 sb
!vm
:n-word-bytes
)))
2491 (realpart (the (complex long-float
) value
)))
2493 fp
(- (* (+ (sb!c
:sc-offset-offset sc-offset
) 6)
2494 sb
!vm
:n-word-bytes
)))
2495 (imagpart (the (complex long-float
) value
))))
2496 (#.sb
!vm
:control-stack-sc-number
2497 (setf (stack-ref fp
(sb!c
:sc-offset-offset sc-offset
)) value
))
2498 (#.sb
!vm
:base-char-stack-sc-number
2499 (setf (sap-ref-32 fp
(- (* (1+ (sb!c
:sc-offset-offset sc-offset
))
2500 sb
!vm
:n-word-bytes
)))
2501 (char-code (the character value
))))
2502 (#.sb
!vm
:unsigned-stack-sc-number
2503 (setf (sap-ref-32 fp
(- (* (1+ (sb!c
:sc-offset-offset sc-offset
))
2504 sb
!vm
:n-word-bytes
)))
2505 (the (unsigned-byte 32) value
)))
2506 (#.sb
!vm
:signed-stack-sc-number
2507 (setf (signed-sap-ref-32
2508 fp
(- (* (1+ (sb!c
:sc-offset-offset sc-offset
))
2509 sb
!vm
:n-word-bytes
)))
2510 (the (signed-byte 32) value
)))
2511 (#.sb
!vm
:sap-stack-sc-number
2512 (setf (sap-ref-sap fp
(- (* (1+ (sb!c
:sc-offset-offset sc-offset
))
2513 sb
!vm
:n-word-bytes
)))
2514 (the system-area-pointer value
))))))
2516 ;;; The method for setting and accessing COMPILED-DEBUG-VAR values use
2517 ;;; this to determine if the value stored is the actual value or an
2518 ;;; indirection cell.
2519 (defun indirect-value-cell-p (x)
2520 (and (= (lowtag-of x
) sb
!vm
:other-pointer-lowtag
)
2521 (= (widetag-of x
) sb
!vm
:value-cell-header-widetag
)))
2523 ;;; Return three values reflecting the validity of DEBUG-VAR's value
2524 ;;; at BASIC-CODE-LOCATION:
2525 ;;; :VALID The value is known to be available.
2526 ;;; :INVALID The value is known to be unavailable.
2527 ;;; :UNKNOWN The value's availability is unknown.
2529 ;;; If the variable is always alive, then it is valid. If the
2530 ;;; code-location is unknown, then the variable's validity is
2531 ;;; :unknown. Once we've called CODE-LOCATION-UNKNOWN-P, we know the
2532 ;;; live-set information has been cached in the code-location.
2533 (defun debug-var-validity (debug-var basic-code-location
)
2534 (etypecase debug-var
2536 (compiled-debug-var-validity debug-var basic-code-location
))
2537 ;; (There used to be more cases back before sbcl-0.7.0, when
2538 ;; we did special tricks to debug the IR1 interpreter.)
2541 ;;; This is the method for DEBUG-VAR-VALIDITY for COMPILED-DEBUG-VARs.
2542 ;;; For safety, make sure basic-code-location is what we think.
2543 (defun compiled-debug-var-validity (debug-var basic-code-location
)
2544 (declare (type compiled-code-location basic-code-location
))
2545 (cond ((debug-var-alive-p debug-var
)
2546 (let ((debug-fun (code-location-debug-fun basic-code-location
)))
2547 (if (>= (compiled-code-location-pc basic-code-location
)
2548 (sb!c
::compiled-debug-fun-start-pc
2549 (compiled-debug-fun-compiler-debug-fun debug-fun
)))
2552 ((code-location-unknown-p basic-code-location
) :unknown
)
2554 (let ((pos (position debug-var
2555 (debug-fun-debug-vars
2556 (code-location-debug-fun
2557 basic-code-location
)))))
2559 (error 'unknown-debug-var
2560 :debug-var debug-var
2562 (code-location-debug-fun basic-code-location
)))
2563 ;; There must be live-set info since basic-code-location is known.
2564 (if (zerop (sbit (compiled-code-location-live-set
2565 basic-code-location
)
2572 ;;; This code produces and uses what we call source-paths. A
2573 ;;; source-path is a list whose first element is a form number as
2574 ;;; returned by CODE-LOCATION-FORM-NUMBER and whose last element is a
2575 ;;; top level form number as returned by
2576 ;;; CODE-LOCATION-TOPLEVEL-FORM-NUMBER. The elements from the last to
2577 ;;; the first, exclusively, are the numbered subforms into which to
2578 ;;; descend. For example:
2580 ;;; (let ((a (aref x 3)))
2582 ;;; The call to AREF in this example is form number 5. Assuming this
2583 ;;; DEFUN is the 11'th top level form, the source-path for the AREF
2584 ;;; call is as follows:
2586 ;;; Given the DEFUN, 3 gets you the LET, 1 gets you the bindings, 0
2587 ;;; gets the first binding, and 1 gets the AREF form.
2589 ;;; temporary buffer used to build form-number => source-path translation in
2590 ;;; FORM-NUMBER-TRANSLATIONS
2591 (defvar *form-number-temp
* (make-array 10 :fill-pointer
0 :adjustable t
))
2593 ;;; table used to detect CAR circularities in FORM-NUMBER-TRANSLATIONS
2594 (defvar *form-number-circularity-table
* (make-hash-table :test
'eq
))
2596 ;;; This returns a table mapping form numbers to source-paths. A
2597 ;;; source-path indicates a descent into the TOPLEVEL-FORM form,
2598 ;;; going directly to the subform corressponding to the form number.
2600 ;;; The vector elements are in the same format as the compiler's
2601 ;;; NODE-SOURCE-PATH; that is, the first element is the form number and
2602 ;;; the last is the TOPLEVEL-FORM number.
2603 (defun form-number-translations (form tlf-number
)
2604 (clrhash *form-number-circularity-table
*)
2605 (setf (fill-pointer *form-number-temp
*) 0)
2606 (sub-translate-form-numbers form
(list tlf-number
))
2607 (coerce *form-number-temp
* 'simple-vector
))
2608 (defun sub-translate-form-numbers (form path
)
2609 (unless (gethash form
*form-number-circularity-table
*)
2610 (setf (gethash form
*form-number-circularity-table
*) t
)
2611 (vector-push-extend (cons (fill-pointer *form-number-temp
*) path
)
2616 (declare (fixnum pos
))
2619 (when (atom subform
) (return))
2620 (let ((fm (car subform
)))
2622 (sub-translate-form-numbers fm
(cons pos path
)))
2624 (setq subform
(cdr subform
))
2625 (when (eq subform trail
) (return)))))
2629 (setq trail
(cdr trail
)))))))
2631 ;;; FORM is a top level form, and path is a source-path into it. This
2632 ;;; returns the form indicated by the source-path. Context is the
2633 ;;; number of enclosing forms to return instead of directly returning
2634 ;;; the source-path form. When context is non-zero, the form returned
2635 ;;; contains a marker, #:****HERE****, immediately before the form
2636 ;;; indicated by path.
2637 (defun source-path-context (form path context
)
2638 (declare (type unsigned-byte context
))
2639 ;; Get to the form indicated by path or the enclosing form indicated
2640 ;; by context and path.
2641 (let ((path (reverse (butlast (cdr path
)))))
2642 (dotimes (i (- (length path
) context
))
2643 (let ((index (first path
)))
2644 (unless (and (listp form
) (< index
(length form
)))
2645 (error "Source path no longer exists."))
2646 (setq form
(elt form index
))
2647 (setq path
(rest path
))))
2648 ;; Recursively rebuild the source form resulting from the above
2649 ;; descent, copying the beginning of each subform up to the next
2650 ;; subform we descend into according to path. At the bottom of the
2651 ;; recursion, we return the form indicated by path preceded by our
2652 ;; marker, and this gets spliced into the resulting list structure
2653 ;; on the way back up.
2654 (labels ((frob (form path level
)
2655 (if (or (zerop level
) (null path
))
2658 `(#:***here
*** ,form
))
2659 (let ((n (first path
)))
2660 (unless (and (listp form
) (< n
(length form
)))
2661 (error "Source path no longer exists."))
2662 (let ((res (frob (elt form n
) (rest path
) (1- level
))))
2663 (nconc (subseq form
0 n
)
2664 (cons res
(nthcdr (1+ n
) form
))))))))
2665 (frob form path context
))))
2667 ;;;; PREPROCESS-FOR-EVAL
2669 ;;; Return a function of one argument that evaluates form in the
2670 ;;; lexical context of the BASIC-CODE-LOCATION LOC, or signal a
2671 ;;; NO-DEBUG-VARS condition when the LOC's DEBUG-FUN has no
2672 ;;; DEBUG-VAR information available.
2674 ;;; The returned function takes the frame to get values from as its
2675 ;;; argument, and it returns the values of FORM. The returned function
2676 ;;; can signal the following conditions: INVALID-VALUE,
2677 ;;; AMBIGUOUS-VAR-NAME, and FRAME-FUN-MISMATCH.
2678 (defun preprocess-for-eval (form loc
)
2679 (declare (type code-location loc
))
2680 (let ((n-frame (gensym))
2681 (fun (code-location-debug-fun loc
)))
2682 (unless (debug-var-info-available fun
)
2683 (debug-signal 'no-debug-vars
:debug-fun fun
))
2684 (sb!int
:collect
((binds)
2686 (do-debug-fun-vars (var fun
)
2687 (let ((validity (debug-var-validity var loc
)))
2688 (unless (eq validity
:invalid
)
2689 (let* ((sym (debug-var-symbol var
))
2690 (found (assoc sym
(binds))))
2692 (setf (second found
) :ambiguous
)
2693 (binds (list sym validity var
)))))))
2694 (dolist (bind (binds))
2695 (let ((name (first bind
))
2697 (ecase (second bind
)
2699 (specs `(,name
(debug-var-value ',var
,n-frame
))))
2701 (specs `(,name
(debug-signal 'invalid-value
2705 (specs `(,name
(debug-signal 'ambiguous-var-name
2707 :frame
,n-frame
)))))))
2708 (let ((res (coerce `(lambda (,n-frame
)
2709 (declare (ignorable ,n-frame
))
2710 (symbol-macrolet ,(specs) ,form
))
2713 ;; This prevents these functions from being used in any
2714 ;; location other than a function return location, so maybe
2715 ;; this should only check whether FRAME's DEBUG-FUN is the
2717 (unless (code-location= (frame-code-location frame
) loc
)
2718 (debug-signal 'frame-fun-mismatch
2719 :code-location loc
:form form
:frame frame
))
2720 (funcall res frame
))))))
2724 ;;;; user-visible interface
2726 ;;; Create and return a breakpoint. When program execution encounters
2727 ;;; the breakpoint, the system calls HOOK-FUN. HOOK-FUN takes the
2728 ;;; current frame for the function in which the program is running and
2729 ;;; the breakpoint object.
2731 ;;; WHAT and KIND determine where in a function the system invokes
2732 ;;; HOOK-FUN. WHAT is either a code-location or a DEBUG-FUN. KIND is
2733 ;;; one of :CODE-LOCATION, :FUN-START, or :FUN-END. Since the starts
2734 ;;; and ends of functions may not have code-locations representing
2735 ;;; them, designate these places by supplying WHAT as a DEBUG-FUN and
2736 ;;; KIND indicating the :FUN-START or :FUN-END. When WHAT is a
2737 ;;; DEBUG-FUN and kind is :FUN-END, then HOOK-FUN must take two
2738 ;;; additional arguments, a list of values returned by the function
2739 ;;; and a FUN-END-COOKIE.
2741 ;;; INFO is information supplied by and used by the user.
2743 ;;; FUN-END-COOKIE is a function. To implement :FUN-END
2744 ;;; breakpoints, the system uses starter breakpoints to establish the
2745 ;;; :FUN-END breakpoint for each invocation of the function. Upon
2746 ;;; each entry, the system creates a unique cookie to identify the
2747 ;;; invocation, and when the user supplies a function for this
2748 ;;; argument, the system invokes it on the frame and the cookie. The
2749 ;;; system later invokes the :FUN-END breakpoint hook on the same
2750 ;;; cookie. The user may save the cookie for comparison in the hook
2753 ;;; Signal an error if WHAT is an unknown code-location.
2754 (defun make-breakpoint (hook-fun what
2755 &key
(kind :code-location
) info fun-end-cookie
)
2758 (when (code-location-unknown-p what
)
2759 (error "cannot make a breakpoint at an unknown code location: ~S"
2761 (aver (eq kind
:code-location
))
2762 (let ((bpt (%make-breakpoint hook-fun what kind info
)))
2764 (compiled-code-location
2765 ;; This slot is filled in due to calling CODE-LOCATION-UNKNOWN-P.
2766 (when (eq (compiled-code-location-kind what
) :unknown-return
)
2767 (let ((other-bpt (%make-breakpoint hook-fun what
2768 :unknown-return-partner
2770 (setf (breakpoint-unknown-return-partner bpt
) other-bpt
)
2771 (setf (breakpoint-unknown-return-partner other-bpt
) bpt
))))
2772 ;; (There used to be more cases back before sbcl-0.7.0,,
2773 ;; when we did special tricks to debug the IR1
2780 (%make-breakpoint hook-fun what kind info
))
2782 (unless (eq (sb!c
::compiled-debug-fun-returns
2783 (compiled-debug-fun-compiler-debug-fun what
))
2785 (error ":FUN-END breakpoints are currently unsupported ~
2786 for the known return convention."))
2788 (let* ((bpt (%make-breakpoint hook-fun what kind info
))
2789 (starter (compiled-debug-fun-end-starter what
)))
2791 (setf starter
(%make-breakpoint
#'list what
:fun-start nil
))
2792 (setf (breakpoint-hook-fun starter
)
2793 (fun-end-starter-hook starter what
))
2794 (setf (compiled-debug-fun-end-starter what
) starter
))
2795 (setf (breakpoint-start-helper bpt
) starter
)
2796 (push bpt
(breakpoint-%info starter
))
2797 (setf (breakpoint-cookie-fun bpt
) fun-end-cookie
)
2800 ;;; These are unique objects created upon entry into a function by a
2801 ;;; :FUN-END breakpoint's starter hook. These are only created
2802 ;;; when users supply :FUN-END-COOKIE to MAKE-BREAKPOINT. Also,
2803 ;;; the :FUN-END breakpoint's hook is called on the same cookie
2804 ;;; when it is created.
2805 (defstruct (fun-end-cookie
2806 (:print-object
(lambda (obj str
)
2807 (print-unreadable-object (obj str
:type t
))))
2808 (:constructor make-fun-end-cookie
(bogus-lra debug-fun
))
2810 ;; a pointer to the bogus-lra created for :FUN-END breakpoints
2812 ;; the DEBUG-FUN associated with this cookie
2815 ;;; This maps bogus-lra-components to cookies, so that
2816 ;;; HANDLE-FUN-END-BREAKPOINT can find the appropriate cookie for the
2817 ;;; breakpoint hook.
2818 (defvar *fun-end-cookies
* (make-hash-table :test
'eq
))
2820 ;;; This returns a hook function for the start helper breakpoint
2821 ;;; associated with a :FUN-END breakpoint. The returned function
2822 ;;; makes a fake LRA that all returns go through, and this piece of
2823 ;;; fake code actually breaks. Upon return from the break, the code
2824 ;;; provides the returnee with any values. Since the returned function
2825 ;;; effectively activates FUN-END-BPT on each entry to DEBUG-FUN's
2826 ;;; function, we must establish breakpoint-data about FUN-END-BPT.
2827 (defun fun-end-starter-hook (starter-bpt debug-fun
)
2828 (declare (type breakpoint starter-bpt
)
2829 (type compiled-debug-fun debug-fun
))
2830 (lambda (frame breakpoint
)
2831 (declare (ignore breakpoint
)
2833 (let ((lra-sc-offset
2834 (sb!c
::compiled-debug-fun-return-pc
2835 (compiled-debug-fun-compiler-debug-fun debug-fun
))))
2836 (multiple-value-bind (lra component offset
)
2838 (get-context-value frame
2841 (setf (get-context-value frame
2845 (let ((end-bpts (breakpoint-%info starter-bpt
)))
2846 (let ((data (breakpoint-data component offset
)))
2847 (setf (breakpoint-data-breakpoints data
) end-bpts
)
2848 (dolist (bpt end-bpts
)
2849 (setf (breakpoint-internal-data bpt
) data
)))
2850 (let ((cookie (make-fun-end-cookie lra debug-fun
)))
2851 (setf (gethash component
*fun-end-cookies
*) cookie
)
2852 (dolist (bpt end-bpts
)
2853 (let ((fun (breakpoint-cookie-fun bpt
)))
2854 (when fun
(funcall fun frame cookie
))))))))))
2856 ;;; This takes a FUN-END-COOKIE and a frame, and it returns
2857 ;;; whether the cookie is still valid. A cookie becomes invalid when
2858 ;;; the frame that established the cookie has exited. Sometimes cookie
2859 ;;; holders are unaware of cookie invalidation because their
2860 ;;; :FUN-END breakpoint hooks didn't run due to THROW'ing.
2862 ;;; This takes a frame as an efficiency hack since the user probably
2863 ;;; has a frame object in hand when using this routine, and it saves
2864 ;;; repeated parsing of the stack and consing when asking whether a
2865 ;;; series of cookies is valid.
2866 (defun fun-end-cookie-valid-p (frame cookie
)
2867 (let ((lra (fun-end-cookie-bogus-lra cookie
))
2868 (lra-sc-offset (sb!c
::compiled-debug-fun-return-pc
2869 (compiled-debug-fun-compiler-debug-fun
2870 (fun-end-cookie-debug-fun cookie
)))))
2871 (do ((frame frame
(frame-down frame
)))
2873 (when (and (compiled-frame-p frame
)
2874 (#!-x86 eq
#!+x86 sap
=
2876 (get-context-value frame lra-save-offset lra-sc-offset
)))
2879 ;;;; ACTIVATE-BREAKPOINT
2881 ;;; Cause the system to invoke the breakpoint's hook function until
2882 ;;; the next call to DEACTIVATE-BREAKPOINT or DELETE-BREAKPOINT. The
2883 ;;; system invokes breakpoint hook functions in the opposite order
2884 ;;; that you activate them.
2885 (defun activate-breakpoint (breakpoint)
2886 (when (eq (breakpoint-status breakpoint
) :deleted
)
2887 (error "cannot activate a deleted breakpoint: ~S" breakpoint
))
2888 (unless (eq (breakpoint-status breakpoint
) :active
)
2889 (ecase (breakpoint-kind breakpoint
)
2891 (let ((loc (breakpoint-what breakpoint
)))
2893 (compiled-code-location
2894 (activate-compiled-code-location-breakpoint breakpoint
)
2895 (let ((other (breakpoint-unknown-return-partner breakpoint
)))
2897 (activate-compiled-code-location-breakpoint other
))))
2898 ;; (There used to be more cases back before sbcl-0.7.0, when
2899 ;; we did special tricks to debug the IR1 interpreter.)
2902 (etypecase (breakpoint-what breakpoint
)
2904 (activate-compiled-fun-start-breakpoint breakpoint
))
2905 ;; (There used to be more cases back before sbcl-0.7.0, when
2906 ;; we did special tricks to debug the IR1 interpreter.)
2909 (etypecase (breakpoint-what breakpoint
)
2911 (let ((starter (breakpoint-start-helper breakpoint
)))
2912 (unless (eq (breakpoint-status starter
) :active
)
2913 ;; may already be active by some other :FUN-END breakpoint
2914 (activate-compiled-fun-start-breakpoint starter
)))
2915 (setf (breakpoint-status breakpoint
) :active
))
2916 ;; (There used to be more cases back before sbcl-0.7.0, when
2917 ;; we did special tricks to debug the IR1 interpreter.)
2921 (defun activate-compiled-code-location-breakpoint (breakpoint)
2922 (declare (type breakpoint breakpoint
))
2923 (let ((loc (breakpoint-what breakpoint
)))
2924 (declare (type compiled-code-location loc
))
2925 (sub-activate-breakpoint
2927 (breakpoint-data (compiled-debug-fun-component
2928 (code-location-debug-fun loc
))
2929 (+ (compiled-code-location-pc loc
)
2930 (if (or (eq (breakpoint-kind breakpoint
)
2931 :unknown-return-partner
)
2932 (eq (compiled-code-location-kind loc
)
2933 :single-value-return
))
2934 sb
!vm
:single-value-return-byte-offset
2937 (defun activate-compiled-fun-start-breakpoint (breakpoint)
2938 (declare (type breakpoint breakpoint
))
2939 (let ((debug-fun (breakpoint-what breakpoint
)))
2940 (sub-activate-breakpoint
2942 (breakpoint-data (compiled-debug-fun-component debug-fun
)
2943 (sb!c
::compiled-debug-fun-start-pc
2944 (compiled-debug-fun-compiler-debug-fun
2947 (defun sub-activate-breakpoint (breakpoint data
)
2948 (declare (type breakpoint breakpoint
)
2949 (type breakpoint-data data
))
2950 (setf (breakpoint-status breakpoint
) :active
)
2952 (unless (breakpoint-data-breakpoints data
)
2953 (setf (breakpoint-data-instruction data
)
2955 (breakpoint-install (get-lisp-obj-address
2956 (breakpoint-data-component data
))
2957 (breakpoint-data-offset data
)))))
2958 (setf (breakpoint-data-breakpoints data
)
2959 (append (breakpoint-data-breakpoints data
) (list breakpoint
)))
2960 (setf (breakpoint-internal-data breakpoint
) data
)))
2962 ;;;; DEACTIVATE-BREAKPOINT
2964 ;;; Stop the system from invoking the breakpoint's hook function.
2965 (defun deactivate-breakpoint (breakpoint)
2966 (when (eq (breakpoint-status breakpoint
) :active
)
2968 (let ((loc (breakpoint-what breakpoint
)))
2970 ((or compiled-code-location compiled-debug-fun
)
2971 (deactivate-compiled-breakpoint breakpoint
)
2972 (let ((other (breakpoint-unknown-return-partner breakpoint
)))
2974 (deactivate-compiled-breakpoint other
))))
2975 ;; (There used to be more cases back before sbcl-0.7.0, when
2976 ;; we did special tricks to debug the IR1 interpreter.)
2980 (defun deactivate-compiled-breakpoint (breakpoint)
2981 (if (eq (breakpoint-kind breakpoint
) :fun-end
)
2982 (let ((starter (breakpoint-start-helper breakpoint
)))
2983 (unless (find-if (lambda (bpt)
2984 (and (not (eq bpt breakpoint
))
2985 (eq (breakpoint-status bpt
) :active
)))
2986 (breakpoint-%info starter
))
2987 (deactivate-compiled-breakpoint starter
)))
2988 (let* ((data (breakpoint-internal-data breakpoint
))
2989 (bpts (delete breakpoint
(breakpoint-data-breakpoints data
))))
2990 (setf (breakpoint-internal-data breakpoint
) nil
)
2991 (setf (breakpoint-data-breakpoints data
) bpts
)
2994 (breakpoint-remove (get-lisp-obj-address
2995 (breakpoint-data-component data
))
2996 (breakpoint-data-offset data
)
2997 (breakpoint-data-instruction data
)))
2998 (delete-breakpoint-data data
))))
2999 (setf (breakpoint-status breakpoint
) :inactive
)
3002 ;;;; BREAKPOINT-INFO
3004 ;;; Return the user-maintained info associated with breakpoint. This
3006 (defun breakpoint-info (breakpoint)
3007 (breakpoint-%info breakpoint
))
3008 (defun %set-breakpoint-info
(breakpoint value
)
3009 (setf (breakpoint-%info breakpoint
) value
)
3010 (let ((other (breakpoint-unknown-return-partner breakpoint
)))
3012 (setf (breakpoint-%info other
) value
))))
3014 ;;;; BREAKPOINT-ACTIVE-P and DELETE-BREAKPOINT
3016 (defun breakpoint-active-p (breakpoint)
3017 (ecase (breakpoint-status breakpoint
)
3019 ((:inactive
:deleted
) nil
)))
3021 ;;; Free system storage and remove computational overhead associated
3022 ;;; with breakpoint. After calling this, breakpoint is completely
3023 ;;; impotent and can never become active again.
3024 (defun delete-breakpoint (breakpoint)
3025 (let ((status (breakpoint-status breakpoint
)))
3026 (unless (eq status
:deleted
)
3027 (when (eq status
:active
)
3028 (deactivate-breakpoint breakpoint
))
3029 (setf (breakpoint-status breakpoint
) :deleted
)
3030 (let ((other (breakpoint-unknown-return-partner breakpoint
)))
3032 (setf (breakpoint-status other
) :deleted
)))
3033 (when (eq (breakpoint-kind breakpoint
) :fun-end
)
3034 (let* ((starter (breakpoint-start-helper breakpoint
))
3035 (breakpoints (delete breakpoint
3036 (the list
(breakpoint-info starter
)))))
3037 (setf (breakpoint-info starter
) breakpoints
)
3039 (delete-breakpoint starter
)
3040 (setf (compiled-debug-fun-end-starter
3041 (breakpoint-what breakpoint
))
3045 ;;;; C call out stubs
3047 ;;; This actually installs the break instruction in the component. It
3048 ;;; returns the overwritten bits. You must call this in a context in
3049 ;;; which GC is disabled, so that Lisp doesn't move objects around
3050 ;;; that C is pointing to.
3051 (sb!alien
:define-alien-routine
"breakpoint_install" sb
!alien
:unsigned-long
3052 (code-obj sb
!alien
:unsigned-long
)
3053 (pc-offset sb
!alien
:int
))
3055 ;;; This removes the break instruction and replaces the original
3056 ;;; instruction. You must call this in a context in which GC is disabled
3057 ;;; so Lisp doesn't move objects around that C is pointing to.
3058 (sb!alien
:define-alien-routine
"breakpoint_remove" sb
!alien
:void
3059 (code-obj sb
!alien
:unsigned-long
)
3060 (pc-offset sb
!alien
:int
)
3061 (old-inst sb
!alien
:unsigned-long
))
3063 (sb!alien
:define-alien-routine
"breakpoint_do_displaced_inst" sb
!alien
:void
3064 (scp (* os-context-t
))
3065 (orig-inst sb
!alien
:unsigned-long
))
3067 ;;;; breakpoint handlers (layer between C and exported interface)
3069 ;;; This maps components to a mapping of offsets to BREAKPOINT-DATAs.
3070 (defvar *component-breakpoint-offsets
* (make-hash-table :test
'eq
))
3072 ;;; This returns the BREAKPOINT-DATA object associated with component cross
3073 ;;; offset. If none exists, this makes one, installs it, and returns it.
3074 (defun breakpoint-data (component offset
&optional
(create t
))
3075 (flet ((install-breakpoint-data ()
3077 (let ((data (make-breakpoint-data component offset
)))
3078 (push (cons offset data
)
3079 (gethash component
*component-breakpoint-offsets
*))
3081 (let ((offsets (gethash component
*component-breakpoint-offsets
*)))
3083 (let ((data (assoc offset offsets
)))
3086 (install-breakpoint-data)))
3087 (install-breakpoint-data)))))
3089 ;;; We use this when there are no longer any active breakpoints
3090 ;;; corresponding to DATA.
3091 (defun delete-breakpoint-data (data)
3092 (let* ((component (breakpoint-data-component data
))
3093 (offsets (delete (breakpoint-data-offset data
)
3094 (gethash component
*component-breakpoint-offsets
*)
3097 (setf (gethash component
*component-breakpoint-offsets
*) offsets
)
3098 (remhash component
*component-breakpoint-offsets
*)))
3101 ;;; The C handler for interrupts calls this when it has a
3102 ;;; debugging-tool break instruction. This does *not* handle all
3103 ;;; breaks; for example, it does not handle breaks for internal
3105 (defun handle-breakpoint (offset component signal-context
)
3106 (let ((data (breakpoint-data component offset nil
)))
3108 (error "unknown breakpoint in ~S at offset ~S"
3109 (debug-fun-name (debug-fun-from-pc component offset
))
3111 (let ((breakpoints (breakpoint-data-breakpoints data
)))
3112 (if (or (null breakpoints
)
3113 (eq (breakpoint-kind (car breakpoints
)) :fun-end
))
3114 (handle-fun-end-breakpoint-aux breakpoints data signal-context
)
3115 (handle-breakpoint-aux breakpoints data
3116 offset component signal-context
)))))
3118 ;;; This holds breakpoint-datas while invoking the breakpoint hooks
3119 ;;; associated with that particular component and location. While they
3120 ;;; are executing, if we hit the location again, we ignore the
3121 ;;; breakpoint to avoid infinite recursion. fun-end breakpoints
3122 ;;; must work differently since the breakpoint-data is unique for each
3124 (defvar *executing-breakpoint-hooks
* nil
)
3126 ;;; This handles code-location and DEBUG-FUN :FUN-START
3128 (defun handle-breakpoint-aux (breakpoints data offset component signal-context
)
3130 (bug "breakpoint that nobody wants"))
3131 (unless (member data
*executing-breakpoint-hooks
*)
3132 (let ((*executing-breakpoint-hooks
* (cons data
3133 *executing-breakpoint-hooks
*)))
3134 (invoke-breakpoint-hooks breakpoints component offset
)))
3135 ;; At this point breakpoints may not hold the same list as
3136 ;; BREAKPOINT-DATA-BREAKPOINTS since invoking hooks may have allowed
3137 ;; a breakpoint deactivation. In fact, if all breakpoints were
3138 ;; deactivated then data is invalid since it was deleted and so the
3139 ;; correct one must be looked up if it is to be used. If there are
3140 ;; no more breakpoints active at this location, then the normal
3141 ;; instruction has been put back, and we do not need to
3142 ;; DO-DISPLACED-INST.
3143 (let ((data (breakpoint-data component offset nil
)))
3144 (when (and data
(breakpoint-data-breakpoints data
))
3145 ;; The breakpoint is still active, so we need to execute the
3146 ;; displaced instruction and leave the breakpoint instruction
3147 ;; behind. The best way to do this is different on each machine,
3148 ;; so we just leave it up to the C code.
3149 (breakpoint-do-displaced-inst signal-context
3150 (breakpoint-data-instruction data
))
3151 ;; Some platforms have no usable sigreturn() call. If your
3152 ;; implementation of arch_do_displaced_inst() _does_ sigreturn(),
3153 ;; it's polite to warn here
3154 #!+(and sparc solaris
)
3155 (error "BREAKPOINT-DO-DISPLACED-INST returned?"))))
3157 (defun invoke-breakpoint-hooks (breakpoints component offset
)
3158 (let* ((debug-fun (debug-fun-from-pc component offset
))
3159 (frame (do ((f (top-frame) (frame-down f
)))
3160 ((eq debug-fun
(frame-debug-fun f
)) f
))))
3161 (dolist (bpt breakpoints
)
3162 (funcall (breakpoint-hook-fun bpt
)
3164 ;; If this is an :UNKNOWN-RETURN-PARTNER, then pass the
3165 ;; hook function the original breakpoint, so that users
3166 ;; aren't forced to confront the fact that some
3167 ;; breakpoints really are two.
3168 (if (eq (breakpoint-kind bpt
) :unknown-return-partner
)
3169 (breakpoint-unknown-return-partner bpt
)
3172 (defun handle-fun-end-breakpoint (offset component context
)
3173 (let ((data (breakpoint-data component offset nil
)))
3175 (error "unknown breakpoint in ~S at offset ~S"
3176 (debug-fun-name (debug-fun-from-pc component offset
))
3178 (let ((breakpoints (breakpoint-data-breakpoints data
)))
3180 (aver (eq (breakpoint-kind (car breakpoints
)) :fun-end
))
3181 (handle-fun-end-breakpoint-aux breakpoints data context
)))))
3183 ;;; Either HANDLE-BREAKPOINT calls this for :FUN-END breakpoints
3184 ;;; [old C code] or HANDLE-FUN-END-BREAKPOINT calls this directly
3186 (defun handle-fun-end-breakpoint-aux (breakpoints data signal-context
)
3187 (delete-breakpoint-data data
)
3190 (declare (optimize (inhibit-warnings 3)))
3191 (sb!alien
:sap-alien signal-context
(* os-context-t
))))
3192 (frame (do ((cfp (sb!vm
:context-register scp sb
!vm
::cfp-offset
))
3193 (f (top-frame) (frame-down f
)))
3194 ((= cfp
(sap-int (frame-pointer f
))) f
)
3195 (declare (type (unsigned-byte #.sb
!vm
:n-word-bits
) cfp
))))
3196 (component (breakpoint-data-component data
))
3197 (cookie (gethash component
*fun-end-cookies
*)))
3198 (remhash component
*fun-end-cookies
*)
3199 (dolist (bpt breakpoints
)
3200 (funcall (breakpoint-hook-fun bpt
)
3202 (get-fun-end-breakpoint-values scp
)
3205 (defun get-fun-end-breakpoint-values (scp)
3206 (let ((ocfp (int-sap (sb!vm
:context-register
3208 #!-x86 sb
!vm
::ocfp-offset
3209 #!+x86 sb
!vm
::ebx-offset
)))
3210 (nargs (make-lisp-obj
3211 (sb!vm
:context-register scp sb
!vm
::nargs-offset
)))
3212 (reg-arg-offsets '#.sb
!vm
::*register-arg-offsets
*)
3215 (dotimes (arg-num nargs
)
3216 (push (if reg-arg-offsets
3218 (sb!vm
:context-register scp
(pop reg-arg-offsets
)))
3219 (stack-ref ocfp arg-num
))
3221 (nreverse results
)))
3223 ;;;; MAKE-BOGUS-LRA (used for :FUN-END breakpoints)
3225 (defconstant bogus-lra-constants
3227 (defconstant known-return-p-slot
3228 (+ sb
!vm
:code-constants-offset
#!-x86
1 #!+x86
2))
3230 ;;; Make a bogus LRA object that signals a breakpoint trap when
3231 ;;; returned to. If the breakpoint trap handler returns, REAL-LRA is
3232 ;;; returned to. Three values are returned: the bogus LRA object, the
3233 ;;; code component it is part of, and the PC offset for the trap
3235 (defun make-bogus-lra (real-lra &optional known-return-p
)
3237 (let* ((src-start (foreign-symbol-address "fun_end_breakpoint_guts"))
3238 (src-end (foreign-symbol-address "fun_end_breakpoint_end"))
3239 (trap-loc (foreign-symbol-address "fun_end_breakpoint_trap"))
3240 (length (sap- src-end src-start
))
3243 #!-
(and x86 gencgc
) sb
!c
:allocate-code-object
3244 #!+(and x86 gencgc
) sb
!c
::allocate-dynamic-code-object
3245 (1+ bogus-lra-constants
)
3247 (dst-start (code-instructions code-object
)))
3248 (declare (type system-area-pointer
3249 src-start src-end dst-start trap-loc
)
3250 (type index length
))
3251 (setf (%code-debug-info code-object
) :bogus-lra
)
3252 (setf (code-header-ref code-object sb
!vm
:code-trace-table-offset-slot
)
3255 (setf (code-header-ref code-object real-lra-slot
) real-lra
)
3257 (multiple-value-bind (offset code
) (compute-lra-data-from-pc real-lra
)
3258 (setf (code-header-ref code-object real-lra-slot
) code
)
3259 (setf (code-header-ref code-object
(1+ real-lra-slot
)) offset
))
3260 (setf (code-header-ref code-object known-return-p-slot
)
3262 (system-area-copy src-start
0 dst-start
0 (* length sb
!vm
:n-byte-bits
))
3263 (sb!vm
:sanctify-for-execution code-object
)
3265 (values dst-start code-object
(sap- trap-loc src-start
))
3267 (let ((new-lra (make-lisp-obj (+ (sap-int dst-start
)
3268 sb
!vm
:other-pointer-lowtag
))))
3271 (logandc2 (+ sb
!vm
:code-constants-offset bogus-lra-constants
1)
3273 (sb!vm
:sanctify-for-execution code-object
)
3274 (values new-lra code-object
(sap- trap-loc src-start
))))))
3278 ;;; This appears here because it cannot go with the DEBUG-FUN
3279 ;;; interface since DO-DEBUG-BLOCK-LOCATIONS isn't defined until after
3280 ;;; the DEBUG-FUN routines.
3282 ;;; Return a code-location before the body of a function and after all
3283 ;;; the arguments are in place; or if that location can't be
3284 ;;; determined due to a lack of debug information, return NIL.
3285 (defun debug-fun-start-location (debug-fun)
3286 (etypecase debug-fun
3288 (code-location-from-pc debug-fun
3289 (sb!c
::compiled-debug-fun-start-pc
3290 (compiled-debug-fun-compiler-debug-fun
3293 ;; (There used to be more cases back before sbcl-0.7.0, when
3294 ;; we did special tricks to debug the IR1 interpreter.)
3297 (defun print-code-locations (function)
3298 (let ((debug-fun (fun-debug-fun function
)))
3299 (do-debug-fun-blocks (block debug-fun
)
3300 (do-debug-block-locations (loc block
)
3301 (fill-in-code-location loc
)
3302 (format t
"~S code location at ~W"
3303 (compiled-code-location-kind loc
)
3304 (compiled-code-location-pc loc
))
3305 (sb!debug
::print-code-location-source-form loc
0)