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-fun-returns
(debug-condition)
45 ((debug-fun :reader no-debug-fun-returns-debug-fun
49 "The system could not return values from a frame with DEBUG-FUN since
50 it lacked information about returning values.")
51 (:report
(lambda (condition stream
)
52 (let ((fun (debug-fun-fun
53 (no-debug-fun-returns-debug-fun condition
))))
55 "~&Cannot return values from ~:[frame~;~:*~S~] since ~
56 the debug information lacks details about returning ~
60 (define-condition no-debug-blocks
(debug-condition)
61 ((debug-fun :reader no-debug-blocks-debug-fun
64 (:documentation
"The debug-fun has no debug-block information.")
65 (:report
(lambda (condition stream
)
66 (format stream
"~&~S has no debug-block information."
67 (no-debug-blocks-debug-fun condition
)))))
69 (define-condition no-debug-vars
(debug-condition)
70 ((debug-fun :reader no-debug-vars-debug-fun
73 (:documentation
"The DEBUG-FUN has no DEBUG-VAR information.")
74 (:report
(lambda (condition stream
)
75 (format stream
"~&~S has no debug variable information."
76 (no-debug-vars-debug-fun condition
)))))
78 (define-condition lambda-list-unavailable
(debug-condition)
79 ((debug-fun :reader lambda-list-unavailable-debug-fun
83 "The DEBUG-FUN has no lambda list since argument DEBUG-VARs are
85 (:report
(lambda (condition stream
)
86 (format stream
"~&~S has no lambda-list information available."
87 (lambda-list-unavailable-debug-fun condition
)))))
89 (define-condition invalid-value
(debug-condition)
90 ((debug-var :reader invalid-value-debug-var
:initarg
:debug-var
)
91 (frame :reader invalid-value-frame
:initarg
:frame
))
92 (:report
(lambda (condition stream
)
93 (format stream
"~&~S has :invalid or :unknown value in ~S."
94 (invalid-value-debug-var condition
)
95 (invalid-value-frame condition
)))))
97 (define-condition ambiguous-var-name
(debug-condition)
98 ((name :reader ambiguous-var-name-name
:initarg
:name
)
99 (frame :reader ambiguous-var-name-frame
:initarg
:frame
))
100 (:report
(lambda (condition stream
)
101 (format stream
"~&~S names more than one valid variable in ~S."
102 (ambiguous-var-name-name condition
)
103 (ambiguous-var-name-frame condition
)))))
105 ;;;; errors and DEBUG-SIGNAL
107 ;;; The debug-internals code tries to signal all programmer errors as
108 ;;; subtypes of DEBUG-ERROR. There are calls to ERROR signalling
109 ;;; SIMPLE-ERRORs, but these dummy checks in the code and shouldn't
112 ;;; While under development, this code also signals errors in code
113 ;;; branches that remain unimplemented.
115 (define-condition debug-error
(error) ()
118 "All programmer errors from using the interface for building debugging
119 tools inherit from this type."))
121 (define-condition unhandled-debug-condition
(debug-error)
122 ((condition :reader unhandled-debug-condition-condition
:initarg
:condition
))
123 (:report
(lambda (condition stream
)
124 (format stream
"~&unhandled DEBUG-CONDITION:~%~A"
125 (unhandled-debug-condition-condition condition
)))))
127 (define-condition unknown-code-location
(debug-error)
128 ((code-location :reader unknown-code-location-code-location
129 :initarg
:code-location
))
130 (:report
(lambda (condition stream
)
131 (format stream
"~&invalid use of an unknown code-location: ~S"
132 (unknown-code-location-code-location condition
)))))
134 (define-condition unknown-debug-var
(debug-error)
135 ((debug-var :reader unknown-debug-var-debug-var
:initarg
:debug-var
)
136 (debug-fun :reader unknown-debug-var-debug-fun
137 :initarg
:debug-fun
))
138 (:report
(lambda (condition stream
)
139 (format stream
"~&~S is not in ~S."
140 (unknown-debug-var-debug-var condition
)
141 (unknown-debug-var-debug-fun condition
)))))
143 (define-condition invalid-control-stack-pointer
(debug-error)
145 (:report
(lambda (condition stream
)
146 (declare (ignore condition
))
148 (write-string "invalid control stack pointer" stream
))))
150 (define-condition frame-fun-mismatch
(debug-error)
151 ((code-location :reader frame-fun-mismatch-code-location
152 :initarg
:code-location
)
153 (frame :reader frame-fun-mismatch-frame
:initarg
:frame
)
154 (form :reader frame-fun-mismatch-form
:initarg
:form
))
155 (:report
(lambda (condition stream
)
158 "~&Form was preprocessed for ~S,~% but called on ~S:~% ~S"
159 (frame-fun-mismatch-code-location condition
)
160 (frame-fun-mismatch-frame condition
)
161 (frame-fun-mismatch-form condition
)))))
163 ;;; This signals debug-conditions. If they go unhandled, then signal
164 ;;; an UNHANDLED-DEBUG-CONDITION error.
166 ;;; ??? Get SIGNAL in the right package!
167 (defmacro debug-signal
(datum &rest arguments
)
168 `(let ((condition (make-condition ,datum
,@arguments
)))
170 (error 'unhandled-debug-condition
:condition condition
)))
174 ;;;; Most of these structures model information stored in internal
175 ;;;; data structures created by the compiler. Whenever comments
176 ;;;; preface an object or type with "compiler", they refer to the
177 ;;;; internal compiler thing, not to the object or type with the same
178 ;;;; name in the "SB-DI" package.
182 ;;; These exist for caching data stored in packed binary form in
183 ;;; compiler DEBUG-FUNs.
184 (defstruct (debug-var (:constructor nil
)
186 ;; the name of the variable
187 (symbol (missing-arg) :type symbol
)
188 ;; a unique integer identification relative to other variables with the same
191 ;; Does the variable always have a valid value?
192 (alive-p nil
:type boolean
))
193 (def!method print-object
((debug-var debug-var
) stream
)
194 (print-unreadable-object (debug-var stream
:type t
:identity t
)
197 (debug-var-symbol debug-var
)
198 (debug-var-id debug-var
))))
201 (setf (fdocumentation 'debug-var-id
'function
)
202 "Return the integer that makes DEBUG-VAR's name and package unique
203 with respect to other DEBUG-VARs in the same function.")
205 (defstruct (compiled-debug-var
207 (:constructor make-compiled-debug-var
208 (symbol id alive-p sc-offset save-sc-offset
))
210 ;; storage class and offset (unexported)
211 (sc-offset nil
:type sb
!c
:sc-offset
)
212 ;; storage class and offset when saved somewhere
213 (save-sc-offset nil
:type
(or sb
!c
:sc-offset null
)))
217 ;;; These represent call frames on the stack.
218 (defstruct (frame (:constructor nil
)
220 ;; the next frame up, or NIL when top frame
221 (up nil
:type
(or frame null
))
222 ;; the previous frame down, or NIL when the bottom frame. Before
223 ;; computing the next frame down, this slot holds the frame pointer
224 ;; to the control stack for the given frame. This lets us get the
225 ;; next frame down and the return-pc for that frame.
226 (%down
:unparsed
:type
(or frame
(member nil
:unparsed
)))
227 ;; the DEBUG-FUN for the function whose call this frame represents
228 (debug-fun nil
:type debug-fun
)
229 ;; the CODE-LOCATION where the frame's DEBUG-FUN will continue
230 ;; running when program execution returns to this frame. If someone
231 ;; interrupted this frame, the result could be an unknown
233 (code-location nil
:type code-location
)
234 ;; an a-list of catch-tags to code-locations
235 (%catches
:unparsed
:type
(or list
(member :unparsed
)))
236 ;; pointer to frame on control stack (unexported)
238 ;; This is the frame's number for prompt printing. Top is zero.
239 (number 0 :type index
))
241 (defstruct (compiled-frame
243 (:constructor make-compiled-frame
244 (pointer up debug-fun code-location number
247 ;; This indicates whether someone interrupted the frame.
248 ;; (unexported). If escaped, this is a pointer to the state that was
249 ;; saved when we were interrupted, an os_context_t, i.e. the third
250 ;; argument to an SA_SIGACTION-style signal handler.
252 (def!method print-object
((obj compiled-frame
) str
)
253 (print-unreadable-object (obj str
:type t
)
255 "~S~:[~;, interrupted~]"
256 (debug-fun-name (frame-debug-fun obj
))
257 (compiled-frame-escaped obj
))))
261 ;;; These exist for caching data stored in packed binary form in
262 ;;; compiler DEBUG-FUNs. *COMPILED-DEBUG-FUNS* maps a SB!C::DEBUG-FUN
263 ;;; to a DEBUG-FUN. There should only be one DEBUG-FUN in existence
264 ;;; for any function; that is, all CODE-LOCATIONs and other objects
265 ;;; that reference DEBUG-FUNs point to unique objects. This is
266 ;;; due to the overhead in cached information.
267 (defstruct (debug-fun (:constructor nil
)
269 ;; some representation of the function arguments. See
270 ;; DEBUG-FUN-LAMBDA-LIST.
271 ;; NOTE: must parse vars before parsing arg list stuff.
272 (%lambda-list
:unparsed
)
273 ;; cached DEBUG-VARS information (unexported).
274 ;; These are sorted by their name.
275 (%debug-vars
:unparsed
:type
(or simple-vector null
(member :unparsed
)))
276 ;; cached debug-block information. This is NIL when we have tried to
277 ;; parse the packed binary info, but none is available.
278 (blocks :unparsed
:type
(or simple-vector null
(member :unparsed
)))
279 ;; the actual function if available
280 (%function
:unparsed
:type
(or null function
(member :unparsed
))))
281 (def!method print-object
((obj debug-fun
) stream
)
282 (print-unreadable-object (obj stream
:type t
)
283 (prin1 (debug-fun-name obj
) stream
)))
285 (defstruct (compiled-debug-fun
287 (:constructor %make-compiled-debug-fun
288 (compiler-debug-fun component
))
290 ;; compiler's dumped DEBUG-FUN information (unexported)
291 (compiler-debug-fun nil
:type sb
!c
::compiled-debug-fun
)
292 ;; code object (unexported).
294 ;; the :FUN-START breakpoint (if any) used to facilitate
295 ;; function end breakpoints
296 (end-starter nil
:type
(or null breakpoint
)))
298 ;;; This maps SB!C::COMPILED-DEBUG-FUNs to
299 ;;; COMPILED-DEBUG-FUNs, so we can get at cached stuff and not
300 ;;; duplicate COMPILED-DEBUG-FUN structures.
301 (defvar *compiled-debug-funs
* (make-hash-table :test
'eq
))
303 ;;; Make a COMPILED-DEBUG-FUN for a SB!C::COMPILER-DEBUG-FUN and its
304 ;;; component. This maps the latter to the former in
305 ;;; *COMPILED-DEBUG-FUNS*. If there already is a COMPILED-DEBUG-FUN,
306 ;;; then this returns it from *COMPILED-DEBUG-FUNS*.
308 ;;; FIXME: It seems this table can potentially grow without bounds,
309 ;;; and retains roots to functions that might otherwise be collected.
310 (defun make-compiled-debug-fun (compiler-debug-fun component
)
311 (let ((table *compiled-debug-funs
*))
312 (with-locked-hash-table (table)
313 (or (gethash compiler-debug-fun table
)
314 (setf (gethash compiler-debug-fun table
)
315 (%make-compiled-debug-fun compiler-debug-fun component
))))))
317 (defstruct (bogus-debug-fun
319 (:constructor make-bogus-debug-fun
330 ;;; These exist for caching data stored in packed binary form in compiler
332 (defstruct (debug-block (:constructor nil
)
334 ;; Code-locations where execution continues after this block.
335 (successors nil
:type list
)
336 ;; This indicates whether the block is a special glob of code shared
337 ;; by various functions and tucked away elsewhere in a component.
338 ;; This kind of block has no start code-location. This slot is in
339 ;; all debug-blocks since it is an exported interface.
340 (elsewhere-p nil
:type boolean
))
341 (def!method print-object
((obj debug-block
) str
)
342 (print-unreadable-object (obj str
:type t
)
343 (prin1 (debug-block-fun-name obj
) str
)))
346 (setf (fdocumentation 'debug-block-successors
'function
)
347 "Return the list of possible code-locations where execution may continue
348 when the basic-block represented by debug-block completes its execution.")
351 (setf (fdocumentation 'debug-block-elsewhere-p
'function
)
352 "Return whether debug-block represents elsewhere code.")
354 (defstruct (compiled-debug-block (:include debug-block
)
356 make-compiled-debug-block
357 (code-locations successors elsewhere-p
))
359 ;; code-location information for the block
360 (code-locations nil
:type simple-vector
))
364 ;;; This is an internal structure that manages information about a
365 ;;; breakpoint locations. See *COMPONENT-BREAKPOINT-OFFSETS*.
366 (defstruct (breakpoint-data (:constructor make-breakpoint-data
369 ;; This is the component in which the breakpoint lies.
371 ;; This is the byte offset into the component.
372 (offset nil
:type index
)
373 ;; The original instruction replaced by the breakpoint.
374 (instruction nil
:type
(or null sb
!vm
::word
))
375 ;; A list of user breakpoints at this location.
376 (breakpoints nil
:type list
))
377 (def!method print-object
((obj breakpoint-data
) str
)
378 (print-unreadable-object (obj str
:type t
)
379 (format str
"~S at ~S"
381 (debug-fun-from-pc (breakpoint-data-component obj
)
382 (breakpoint-data-offset obj
)))
383 (breakpoint-data-offset obj
))))
385 (defstruct (breakpoint (:constructor %make-breakpoint
386 (hook-fun what kind %info
))
388 ;; This is the function invoked when execution encounters the
389 ;; breakpoint. It takes a frame, the breakpoint, and optionally a
390 ;; list of values. Values are supplied for :FUN-END breakpoints as
391 ;; values to return for the function containing the breakpoint.
392 ;; :FUN-END breakpoint hook functions also take a cookie argument.
393 ;; See the COOKIE-FUN slot.
394 (hook-fun (required-arg) :type function
)
395 ;; CODE-LOCATION or DEBUG-FUN
396 (what nil
:type
(or code-location debug-fun
))
397 ;; :CODE-LOCATION, :FUN-START, or :FUN-END for that kind
398 ;; of breakpoint. :UNKNOWN-RETURN-PARTNER if this is the partner of
399 ;; a :code-location breakpoint at an :UNKNOWN-RETURN code-location.
400 (kind nil
:type
(member :code-location
:fun-start
:fun-end
401 :unknown-return-partner
))
402 ;; Status helps the user and the implementation.
403 (status :inactive
:type
(member :active
:inactive
:deleted
))
404 ;; This is a backpointer to a breakpoint-data.
405 (internal-data nil
:type
(or null breakpoint-data
))
406 ;; With code-locations whose type is :UNKNOWN-RETURN, there are
407 ;; really two breakpoints: one at the multiple-value entry point,
408 ;; and one at the single-value entry point. This slot holds the
409 ;; breakpoint for the other one, or NIL if this isn't at an
410 ;; :UNKNOWN-RETURN code location.
411 (unknown-return-partner nil
:type
(or null breakpoint
))
412 ;; :FUN-END breakpoints use a breakpoint at the :FUN-START
413 ;; to establish the end breakpoint upon function entry. We do this
414 ;; by frobbing the LRA to jump to a special piece of code that
415 ;; breaks and provides the return values for the returnee. This slot
416 ;; points to the start breakpoint, so we can activate, deactivate,
418 (start-helper nil
:type
(or null breakpoint
))
419 ;; This is a hook users supply to get a dynamically unique cookie
420 ;; for identifying :FUN-END breakpoint executions. That is, if
421 ;; there is one :FUN-END breakpoint, but there may be multiple
422 ;; pending calls of its function on the stack. This function takes
423 ;; the cookie, and the hook function takes the cookie too.
424 (cookie-fun nil
:type
(or null function
))
425 ;; This slot users can set with whatever information they find useful.
427 (def!method print-object
((obj breakpoint
) str
)
428 (let ((what (breakpoint-what obj
)))
429 (print-unreadable-object (obj str
:type t
)
434 (debug-fun (debug-fun-name what
)))
437 (debug-fun (breakpoint-kind obj
)))))))
441 (defstruct (code-location (:constructor nil
)
443 ;; the DEBUG-FUN containing this CODE-LOCATION
444 (debug-fun nil
:type debug-fun
)
445 ;; This is initially :UNSURE. Upon first trying to access an
446 ;; :UNPARSED slot, if the data is unavailable, then this becomes T,
447 ;; and the code-location is unknown. If the data is available, this
448 ;; becomes NIL, a known location. We can't use a separate type
449 ;; code-location for this since we must return code-locations before
450 ;; we can tell whether they're known or unknown. For example, when
451 ;; parsing the stack, we don't want to unpack all the variables and
452 ;; blocks just to make frames.
453 (%unknown-p
:unsure
:type
(member t nil
:unsure
))
454 ;; the DEBUG-BLOCK containing CODE-LOCATION. XXX Possibly toss this
455 ;; out and just find it in the blocks cache in DEBUG-FUN.
456 (%debug-block
:unparsed
:type
(or debug-block
(member :unparsed
)))
457 ;; This is the number of forms processed by the compiler or loader
458 ;; before the top level form containing this code-location.
459 (%tlf-offset
:unparsed
:type
(or index
(member :unparsed
)))
460 ;; This is the depth-first number of the node that begins
461 ;; code-location within its top level form.
462 (%form-number
:unparsed
:type
(or index
(member :unparsed
))))
463 (def!method print-object
((obj code-location
) str
)
464 (print-unreadable-object (obj str
:type t
)
465 (prin1 (debug-fun-name (code-location-debug-fun obj
))
468 (defstruct (compiled-code-location
469 (:include code-location
)
470 (:constructor make-known-code-location
471 (pc debug-fun %tlf-offset %form-number
472 %live-set kind step-info
&aux
(%unknown-p nil
)))
473 (:constructor make-compiled-code-location
(pc debug-fun
))
475 ;; an index into DEBUG-FUN's component slot
477 ;; a bit-vector indexed by a variable's position in
478 ;; DEBUG-FUN-DEBUG-VARS indicating whether the variable has a
479 ;; valid value at this code-location. (unexported).
480 (%live-set
:unparsed
:type
(or simple-bit-vector
(member :unparsed
)))
481 ;; (unexported) To see SB!C::LOCATION-KIND, do
482 ;; (SB!KERNEL:TYPE-EXPAND 'SB!C::LOCATION-KIND).
483 (kind :unparsed
:type
(or (member :unparsed
) sb
!c
::location-kind
))
484 (step-info :unparsed
:type
(or (member :unparsed
:foo
) simple-string
)))
488 ;;; Return the number of top level forms processed by the compiler
489 ;;; before compiling this source. If this source is uncompiled, this
490 ;;; is zero. This may be zero even if the source is compiled since the
491 ;;; first form in the first file compiled in one compilation, for
492 ;;; example, must have a root number of zero -- the compiler saw no
493 ;;; other top level forms before it.
494 (defun debug-source-root-number (debug-source)
495 (sb!c
::debug-source-source-root debug-source
))
499 ;;; This is used in FIND-ESCAPED-FRAME and with the bogus components
500 ;;; and LRAs used for :FUN-END breakpoints. When a component's
501 ;;; debug-info slot is :BOGUS-LRA, then the REAL-LRA-SLOT contains the
502 ;;; real component to continue executing, as opposed to the bogus
503 ;;; component which appeared in some frame's LRA location.
504 (defconstant real-lra-slot sb
!vm
:code-constants-offset
)
506 ;;; These are magically converted by the compiler.
507 (defun current-sp () (current-sp))
508 (defun current-fp () (current-fp))
509 (defun stack-ref (s n
) (stack-ref s n
))
510 (defun %set-stack-ref
(s n value
) (%set-stack-ref s n value
))
511 (defun fun-code-header (fun) (fun-code-header fun
))
512 (defun lra-code-header (lra) (lra-code-header lra
))
513 (defun %make-lisp-obj
(value) (%make-lisp-obj value
))
514 (defun get-lisp-obj-address (thing) (get-lisp-obj-address thing
))
515 (defun fun-word-offset (fun) (fun-word-offset fun
))
517 #!-sb-fluid
(declaim (inline control-stack-pointer-valid-p
))
518 (defun control-stack-pointer-valid-p (x)
519 (declare (type system-area-pointer x
))
520 (let* (#!-stack-grows-downward-not-upward
522 (descriptor-sap *control-stack-start
*))
523 #!+stack-grows-downward-not-upward
525 (descriptor-sap *control-stack-end
*)))
526 #!-stack-grows-downward-not-upward
527 (and (sap< x
(current-sp))
528 (sap<= control-stack-start x
)
529 (zerop (logand (sap-int x
) sb
!vm
:fixnum-tag-mask
)))
530 #!+stack-grows-downward-not-upward
531 (and (sap>= x
(current-sp))
532 (sap> control-stack-end x
)
533 (zerop (logand (sap-int x
) sb
!vm
:fixnum-tag-mask
)))))
535 (declaim (inline component-ptr-from-pc
))
536 (sb!alien
:define-alien-routine component-ptr-from-pc
(system-area-pointer)
537 (pc system-area-pointer
))
540 (sb!alien
:define-alien-routine valid-lisp-pointer-p sb
!alien
:int
541 (pointer system-area-pointer
))
543 (declaim (inline component-from-component-ptr
))
544 (defun component-from-component-ptr (component-ptr)
545 (declare (type system-area-pointer component-ptr
))
546 (make-lisp-obj (logior (sap-int component-ptr
)
547 sb
!vm
:other-pointer-lowtag
)))
549 ;;;; (OR X86 X86-64) support
551 (defun compute-lra-data-from-pc (pc)
552 (declare (type system-area-pointer pc
))
553 (let ((component-ptr (component-ptr-from-pc pc
)))
554 (unless (sap= component-ptr
(int-sap #x0
))
555 (let* ((code (component-from-component-ptr component-ptr
))
556 (code-header-len (* (get-header-data code
) sb
!vm
:n-word-bytes
))
557 (pc-offset (- (sap-int pc
)
558 (- (get-lisp-obj-address code
)
559 sb
!vm
:other-pointer-lowtag
)
561 ; (format t "c-lra-fpc ~A ~A ~A~%" pc code pc-offset)
562 (values pc-offset code
)))))
567 (defconstant sb
!vm
::nargs-offset
#.sb
!vm
::ecx-offset
)
569 ;;; Check for a valid return address - it could be any valid C/Lisp
572 ;;; XXX Could be a little smarter.
573 #!-sb-fluid
(declaim (inline ra-pointer-valid-p
))
574 (defun ra-pointer-valid-p (ra)
575 (declare (type system-area-pointer ra
))
577 ;; not the first page (which is unmapped)
579 ;; FIXME: Where is this documented? Is it really true of every CPU
580 ;; architecture? Is it even necessarily true in current SBCL?
581 (>= (sap-int ra
) 4096)
582 ;; not a Lisp stack pointer
583 (not (control-stack-pointer-valid-p ra
))))
585 ;;; Try to find a valid previous stack. This is complex on the x86 as
586 ;;; it can jump between C and Lisp frames. To help find a valid frame
587 ;;; it searches backwards.
589 ;;; XXX Should probably check whether it has reached the bottom of the
592 ;;; XXX Should handle interrupted frames, both Lisp and C. At present
593 ;;; it manages to find a fp trail, see linux hack below.
594 (declaim (maybe-inline x86-call-context
))
595 (defun x86-call-context (fp)
596 (declare (type system-area-pointer fp
))
603 ((not (control-stack-pointer-valid-p fp
))
606 ;; Check the two possible frame pointers.
607 (let ((lisp-ocfp (sap-ref-sap fp
(- (* (1+ ocfp-save-offset
)
608 sb
!vm
::n-word-bytes
))))
609 (lisp-ra (sap-ref-sap fp
(- (* (1+ return-pc-save-offset
)
610 sb
!vm
::n-word-bytes
))))
611 (c-ocfp (sap-ref-sap fp
(* 0 sb
!vm
:n-word-bytes
)))
612 (c-ra (sap-ref-sap fp
(* 1 sb
!vm
:n-word-bytes
))))
613 (cond ((and (sap> lisp-ocfp fp
)
614 (control-stack-pointer-valid-p lisp-ocfp
)
615 (ra-pointer-valid-p lisp-ra
)
617 (control-stack-pointer-valid-p c-ocfp
)
618 (ra-pointer-valid-p c-ra
))
619 ;; Look forward another step to check their validity.
620 (let ((lisp-ok (handle lisp-ocfp
))
621 (c-ok (handle c-ocfp
)))
622 (cond ((and lisp-ok c-ok
)
623 ;; Both still seem valid - choose the lisp frame.
625 (if (sap> lisp-ocfp c-ocfp
)
626 (values t lisp-ra lisp-ocfp
)
627 (values t c-ra c-ocfp
))
629 (values t lisp-ra lisp-ocfp
))
631 ;; The lisp convention is looking good.
632 (values t lisp-ra lisp-ocfp
))
634 ;; The C convention is looking good.
635 (values t c-ra c-ocfp
))
637 ;; Neither seems right?
639 ((and (sap> lisp-ocfp fp
)
640 (control-stack-pointer-valid-p lisp-ocfp
)
641 (ra-pointer-valid-p lisp-ra
))
642 ;; The lisp convention is looking good.
643 (values t lisp-ra lisp-ocfp
))
644 ((and (sap> c-ocfp fp
)
645 (control-stack-pointer-valid-p c-ocfp
)
646 #!-linux
(ra-pointer-valid-p c-ra
))
647 ;; The C convention is looking good.
648 (values t c-ra c-ocfp
))
655 ;;; Convert the descriptor into a SAP. The bits all stay the same, we just
656 ;;; change our notion of what we think they are.
657 #!-sb-fluid
(declaim (inline descriptor-sap
))
658 (defun descriptor-sap (x)
659 (int-sap (get-lisp-obj-address x
)))
661 ;;; Return the top frame of the control stack as it was before calling
664 (/noshow0
"entering TOP-FRAME")
665 (multiple-value-bind (fp pc
) (%caller-frame-and-pc
)
666 (compute-calling-frame (descriptor-sap fp
) pc nil
)))
668 ;;; Flush all of the frames above FRAME, and renumber all the frames
670 (defun flush-frames-above (frame)
671 (setf (frame-up frame
) nil
)
672 (do ((number 0 (1+ number
))
673 (frame frame
(frame-%down frame
)))
674 ((not (frame-p frame
)))
675 (setf (frame-number frame
) number
)))
677 (defun find-saved-frame-down (fp up-frame
)
678 (multiple-value-bind (saved-fp saved-pc
) (sb!c
:find-saved-fp-and-pc fp
)
680 (compute-calling-frame (descriptor-sap saved-fp
) saved-pc up-frame
))))
682 ;;; Return the frame immediately below FRAME on the stack; or when
683 ;;; FRAME is the bottom of the stack, return NIL.
684 (defun frame-down (frame)
685 (/noshow0
"entering FRAME-DOWN")
686 ;; We have to access the old-fp and return-pc out of frame and pass
687 ;; them to COMPUTE-CALLING-FRAME.
688 (let ((down (frame-%down frame
)))
689 (if (eq down
:unparsed
)
690 (let ((debug-fun (frame-debug-fun frame
)))
691 (/noshow0
"in DOWN :UNPARSED case")
692 (setf (frame-%down frame
)
695 (let ((c-d-f (compiled-debug-fun-compiler-debug-fun
697 (compute-calling-frame
700 frame ocfp-save-offset
701 (sb!c
::compiled-debug-fun-old-fp c-d-f
)))
703 frame lra-save-offset
704 (sb!c
::compiled-debug-fun-return-pc c-d-f
))
707 (let ((fp (frame-pointer frame
)))
708 (when (control-stack-pointer-valid-p fp
)
710 (multiple-value-bind (ok ra ofp
) (x86-call-context fp
)
712 (compute-calling-frame ofp ra frame
)
713 (find-saved-frame-down fp frame
)))
715 (compute-calling-frame
717 (sap-ref-sap fp
(* ocfp-save-offset
721 (sap-ref-32 fp
(* ocfp-save-offset
722 sb
!vm
:n-word-bytes
)))
724 (stack-ref fp lra-save-offset
)
729 ;;; Get the old FP or return PC out of FRAME. STACK-SLOT is the
730 ;;; standard save location offset on the stack. LOC is the saved
731 ;;; SC-OFFSET describing the main location.
732 (defun get-context-value (frame stack-slot loc
)
733 (declare (type compiled-frame frame
) (type unsigned-byte stack-slot
)
734 (type sb
!c
:sc-offset loc
))
735 (let ((pointer (frame-pointer frame
))
736 (escaped (compiled-frame-escaped frame
)))
738 (sub-access-debug-var-slot pointer loc escaped
)
740 (stack-ref pointer stack-slot
)
744 (stack-ref pointer stack-slot
))
746 (sap-ref-sap pointer
(- (* (1+ stack-slot
)
747 sb
!vm
::n-word-bytes
))))))))
749 (defun (setf get-context-value
) (value frame stack-slot loc
)
750 (declare (type compiled-frame frame
) (type unsigned-byte stack-slot
)
751 (type sb
!c
:sc-offset loc
))
752 (let ((pointer (frame-pointer frame
))
753 (escaped (compiled-frame-escaped frame
)))
755 (sub-set-debug-var-slot pointer loc value escaped
)
757 (setf (stack-ref pointer stack-slot
) value
)
761 (setf (stack-ref pointer stack-slot
) value
))
763 (setf (sap-ref-sap pointer
(- (* (1+ stack-slot
)
764 sb
!vm
::n-word-bytes
))) value
))))))
766 (defun foreign-function-backtrace-name (sap)
767 (let ((name (sap-foreign-symbol sap
)))
769 (format nil
"foreign function: ~A" name
)
770 (format nil
"foreign function: #x~X" (sap-int sap
)))))
772 ;;; This returns a frame for the one existing in time immediately
773 ;;; prior to the frame referenced by current-fp. This is current-fp's
774 ;;; caller or the next frame down the control stack. If there is no
775 ;;; down frame, this returns NIL for the bottom of the stack. UP-FRAME
776 ;;; is the up link for the resulting frame object, and it is null when
777 ;;; we call this to get the top of the stack.
779 ;;; The current frame contains the pointer to the temporally previous
780 ;;; frame we want, and the current frame contains the pc at which we
781 ;;; will continue executing upon returning to that previous frame.
783 ;;; Note: Sometimes LRA is actually a fixnum. This happens when lisp
784 ;;; calls into C. In this case, the code object is stored on the stack
785 ;;; after the LRA, and the LRA is the word offset.
787 (defun compute-calling-frame (caller lra up-frame
)
788 (declare (type system-area-pointer caller
))
789 (/noshow0
"entering COMPUTE-CALLING-FRAME")
790 (when (control-stack-pointer-valid-p caller
)
792 (multiple-value-bind (code pc-offset escaped
)
794 (multiple-value-bind (word-offset code
)
796 (let ((fp (frame-pointer up-frame
)))
798 (stack-ref fp
(1+ lra-save-offset
))))
799 (values (get-header-data lra
)
800 (lra-code-header lra
)))
803 (* (1+ (- word-offset
(get-header-data code
)))
806 (values :foreign-function
809 (find-escaped-frame caller
))
810 (if (and (code-component-p code
)
811 (eq (%code-debug-info code
) :bogus-lra
))
812 (let ((real-lra (code-header-ref code real-lra-slot
)))
813 (compute-calling-frame caller real-lra up-frame
))
814 (let ((d-fun (case code
816 (make-bogus-debug-fun
817 "undefined function"))
819 (make-bogus-debug-fun
820 (foreign-function-backtrace-name
821 (int-sap (get-lisp-obj-address lra
)))))
823 (make-bogus-debug-fun
824 "bogus stack frame"))
826 (debug-fun-from-pc code pc-offset
)))))
827 (/noshow0
"returning MAKE-COMPILED-FRAME from COMPUTE-CALLING-FRAME")
828 (make-compiled-frame caller up-frame d-fun
829 (code-location-from-pc d-fun pc-offset
831 (if up-frame
(1+ (frame-number up-frame
)) 0)
835 (defun compute-calling-frame (caller ra up-frame
)
836 (declare (type system-area-pointer caller ra
))
837 (/noshow0
"entering COMPUTE-CALLING-FRAME")
838 (when (control-stack-pointer-valid-p caller
)
840 ;; First check for an escaped frame.
841 (multiple-value-bind (code pc-offset escaped
) (find-escaped-frame caller
)
844 ;; If it's escaped it may be a function end breakpoint trap.
845 (when (and (code-component-p code
)
846 (eq (%code-debug-info code
) :bogus-lra
))
847 ;; If :bogus-lra grab the real lra.
848 (setq pc-offset
(code-header-ref
849 code
(1+ real-lra-slot
)))
850 (setq code
(code-header-ref code real-lra-slot
))
853 (multiple-value-setq (pc-offset code
)
854 (compute-lra-data-from-pc ra
))
856 (setf code
:foreign-function
858 (let ((d-fun (case code
860 (make-bogus-debug-fun
861 "undefined function"))
863 (make-bogus-debug-fun
864 (foreign-function-backtrace-name ra
)))
866 (make-bogus-debug-fun
867 "bogus stack frame"))
869 (debug-fun-from-pc code pc-offset
)))))
870 (/noshow0
"returning MAKE-COMPILED-FRAME from COMPUTE-CALLING-FRAME")
871 (make-compiled-frame caller up-frame d-fun
872 (code-location-from-pc d-fun pc-offset
874 (if up-frame
(1+ (frame-number up-frame
)) 0)
877 (defun nth-interrupt-context (n)
878 (declare (type (unsigned-byte 32) n
)
879 (optimize (speed 3) (safety 0)))
880 (sb!alien
:sap-alien
(sb!vm
::current-thread-offset-sap
881 (+ sb
!vm
::thread-interrupt-contexts-offset n
))
885 (defun find-escaped-frame (frame-pointer)
886 (declare (type system-area-pointer frame-pointer
))
887 (/noshow0
"entering FIND-ESCAPED-FRAME")
888 (dotimes (index *free-interrupt-context-index
* (values nil
0 nil
))
889 (/noshow0
"at head of WITH-ALIEN")
890 (let ((context (nth-interrupt-context index
)))
891 (/noshow0
"got CONTEXT")
892 (when (= (sap-int frame-pointer
)
893 (sb!vm
:context-register context sb
!vm
::cfp-offset
))
895 (/noshow0
"in WITHOUT-GCING")
896 (let* ((component-ptr (component-ptr-from-pc
897 (sb!vm
:context-pc context
)))
898 (code (unless (sap= component-ptr
(int-sap #x0
))
899 (component-from-component-ptr component-ptr
))))
900 (/noshow0
"got CODE")
902 (return (values code
0 context
)))
903 (let* ((code-header-len (* (get-header-data code
)
906 (- (sap-int (sb!vm
:context-pc context
))
907 (- (get-lisp-obj-address code
)
908 sb
!vm
:other-pointer-lowtag
)
910 (/noshow
"got PC-OFFSET")
911 (unless (<= 0 pc-offset
912 (* (code-header-ref code sb
!vm
:code-code-size-slot
)
914 ;; We were in an assembly routine. Therefore, use the
917 ;; FIXME: Should this be WARN or ERROR or what?
918 (format t
"** pc-offset ~S not in code obj ~S?~%"
920 (/noshow0
"returning from FIND-ESCAPED-FRAME")
922 (values code pc-offset context
)))))))))
925 (defun find-escaped-frame (frame-pointer)
926 (declare (type system-area-pointer frame-pointer
))
927 (/noshow0
"entering FIND-ESCAPED-FRAME")
928 (dotimes (index *free-interrupt-context-index
* (values nil
0 nil
))
929 (/noshow0
"at head of WITH-ALIEN")
930 (let ((scp (nth-interrupt-context index
)))
932 (when (= (sap-int frame-pointer
)
933 (sb!vm
:context-register scp sb
!vm
::cfp-offset
))
935 (/noshow0
"in WITHOUT-GCING")
936 (let ((code (code-object-from-bits
937 (sb!vm
:context-register scp sb
!vm
::code-offset
))))
938 (/noshow0
"got CODE")
940 (return (values code
0 scp
)))
941 (let* ((code-header-len (* (get-header-data code
)
944 (- (sap-int (sb!vm
:context-pc scp
))
945 (- (get-lisp-obj-address code
)
946 sb
!vm
:other-pointer-lowtag
)
948 (let ((code-size (* (code-header-ref code
949 sb
!vm
:code-code-size-slot
)
950 sb
!vm
:n-word-bytes
)))
951 (unless (<= 0 pc-offset code-size
)
952 ;; We were in an assembly routine.
953 (multiple-value-bind (new-pc-offset computed-return
)
954 (find-pc-from-assembly-fun code scp
)
955 (setf pc-offset new-pc-offset
)
956 (unless (<= 0 pc-offset code-size
)
958 "Set PC-OFFSET to zero and continue backtrace."
961 "~@<PC-OFFSET (~D) not in code object. Frame details:~
962 ~2I~:@_PC: #X~X~:@_CODE: ~S~:@_CODE FUN: ~S~:@_LRA: ~
963 #X~X~:@_COMPUTED RETURN: #X~X.~:>"
966 (sap-int (sb!vm
:context-pc scp
))
968 (%code-entry-points code
)
969 (sb!vm
:context-register scp sb
!vm
::lra-offset
)
971 ;; We failed to pinpoint where PC is, but set
972 ;; pc-offset to 0 to keep the backtrace from
974 (setf pc-offset
0)))))
975 (/noshow0
"returning from FIND-ESCAPED-FRAME")
977 (if (eq (%code-debug-info code
) :bogus-lra
)
978 (let ((real-lra (code-header-ref code
980 (values (lra-code-header real-lra
)
981 (get-header-data real-lra
)
983 (values code pc-offset scp
))))))))))
986 (defun find-pc-from-assembly-fun (code scp
)
987 "Finds the PC for the return from an assembly routine properly.
988 For some architectures (such as PPC) this will not be the $LRA
990 (let ((return-machine-address (sb!vm
::return-machine-address scp
))
991 (code-header-len (* (get-header-data code
) sb
!vm
:n-word-bytes
)))
992 (values (- return-machine-address
993 (- (get-lisp-obj-address code
)
994 sb
!vm
:other-pointer-lowtag
)
996 return-machine-address
)))
998 ;;; Find the code object corresponding to the object represented by
999 ;;; bits and return it. We assume bogus functions correspond to the
1000 ;;; undefined-function.
1002 (defun code-object-from-bits (bits)
1003 (declare (type (unsigned-byte 32) bits
))
1004 (let ((object (make-lisp-obj bits nil
)))
1005 (if (functionp object
)
1006 (or (fun-code-header object
)
1007 :undefined-function
)
1008 (let ((lowtag (lowtag-of object
)))
1009 (when (= lowtag sb
!vm
:other-pointer-lowtag
)
1010 (let ((widetag (widetag-of object
)))
1011 (cond ((= widetag sb
!vm
:code-header-widetag
)
1013 ((= widetag sb
!vm
:return-pc-header-widetag
)
1014 (lra-code-header object
))
1018 ;;;; frame utilities
1020 ;;; This returns a COMPILED-DEBUG-FUN for COMPONENT and PC. We fetch the
1021 ;;; SB!C::DEBUG-INFO and run down its FUN-MAP to get a
1022 ;;; SB!C::COMPILED-DEBUG-FUN from the PC. The result only needs to
1023 ;;; reference the COMPONENT, for function constants, and the
1024 ;;; SB!C::COMPILED-DEBUG-FUN.
1025 (defun debug-fun-from-pc (component pc
)
1026 (let ((info (%code-debug-info component
)))
1029 ;; FIXME: It seems that most of these (at least on x86) are
1030 ;; actually assembler routines, and could be named by looking
1031 ;; at the sb-fasl:*assembler-routines*.
1032 (make-bogus-debug-fun "no debug information for frame"))
1033 ((eq info
:bogus-lra
)
1034 (make-bogus-debug-fun "function end breakpoint"))
1036 (let* ((fun-map (sb!c
::compiled-debug-info-fun-map info
))
1037 (len (length fun-map
)))
1038 (declare (type simple-vector fun-map
))
1040 (make-compiled-debug-fun (svref fun-map
0) component
)
1043 (>= pc
(sb!c
::compiled-debug-fun-elsewhere-pc
1044 (svref fun-map
0)))))
1045 (declare (type sb
!int
:index i
))
1048 (< pc
(if elsewhere-p
1049 (sb!c
::compiled-debug-fun-elsewhere-pc
1050 (svref fun-map
(1+ i
)))
1051 (svref fun-map i
))))
1052 (return (make-compiled-debug-fun
1053 (svref fun-map
(1- i
))
1057 ;;; This returns a code-location for the COMPILED-DEBUG-FUN,
1058 ;;; DEBUG-FUN, and the pc into its code vector. If we stopped at a
1059 ;;; breakpoint, find the CODE-LOCATION for that breakpoint. Otherwise,
1060 ;;; make an :UNSURE code location, so it can be filled in when we
1061 ;;; figure out what is going on.
1062 (defun code-location-from-pc (debug-fun pc escaped
)
1063 (or (and (compiled-debug-fun-p debug-fun
)
1065 (let ((data (breakpoint-data
1066 (compiled-debug-fun-component debug-fun
)
1068 (when (and data
(breakpoint-data-breakpoints data
))
1069 (let ((what (breakpoint-what
1070 (first (breakpoint-data-breakpoints data
)))))
1071 (when (compiled-code-location-p what
)
1073 (make-compiled-code-location pc debug-fun
)))
1075 ;;; Return an alist mapping catch tags to CODE-LOCATIONs. These are
1076 ;;; CODE-LOCATIONs at which execution would continue with frame as the
1077 ;;; top frame if someone threw to the corresponding tag.
1078 (defun frame-catches (frame)
1079 (let ((catch (descriptor-sap sb
!vm
:*current-catch-block
*))
1080 (reversed-result nil
)
1081 (fp (frame-pointer frame
)))
1082 (loop until
(zerop (sap-int catch
))
1083 finally
(return (nreverse reversed-result
))
1088 (* sb
!vm
:catch-block-current-cont-slot
1089 sb
!vm
:n-word-bytes
))
1093 (* sb
!vm
:catch-block-current-cont-slot
1094 sb
!vm
:n-word-bytes
))))
1095 (let* (#!-
(or x86 x86-64
)
1096 (lra (stack-ref catch sb
!vm
:catch-block-entry-pc-slot
))
1099 catch
(* sb
!vm
:catch-block-entry-pc-slot
1100 sb
!vm
:n-word-bytes
)))
1103 (stack-ref catch sb
!vm
:catch-block-current-code-slot
))
1105 (component (component-from-component-ptr
1106 (component-ptr-from-pc ra
)))
1109 (* (- (1+ (get-header-data lra
))
1110 (get-header-data component
))
1114 (- (get-lisp-obj-address component
)
1115 sb
!vm
:other-pointer-lowtag
)
1116 (* (get-header-data component
) sb
!vm
:n-word-bytes
))))
1117 (push (cons #!-
(or x86 x86-64
)
1118 (stack-ref catch sb
!vm
:catch-block-tag-slot
)
1121 (sap-ref-word catch
(* sb
!vm
:catch-block-tag-slot
1122 sb
!vm
:n-word-bytes
)))
1123 (make-compiled-code-location
1124 offset
(frame-debug-fun frame
)))
1129 (* sb
!vm
:catch-block-previous-catch-slot
1130 sb
!vm
:n-word-bytes
))
1134 (* sb
!vm
:catch-block-previous-catch-slot
1135 sb
!vm
:n-word-bytes
)))))))
1137 ;;; Modify the value of the OLD-TAG catches in FRAME to NEW-TAG
1138 (defun replace-frame-catch-tag (frame old-tag new-tag
)
1139 (let ((catch (descriptor-sap sb
!vm
:*current-catch-block
*))
1140 (fp (frame-pointer frame
)))
1141 (loop until
(zerop (sap-int catch
))
1145 (* sb
!vm
:catch-block-current-cont-slot
1146 sb
!vm
:n-word-bytes
))
1150 (* sb
!vm
:catch-block-current-cont-slot
1151 sb
!vm
:n-word-bytes
))))
1154 (stack-ref catch sb
!vm
:catch-block-tag-slot
)
1157 (sap-ref-word catch
(* sb
!vm
:catch-block-tag-slot
1158 sb
!vm
:n-word-bytes
)))))
1159 (when (eq current-tag old-tag
)
1161 (setf (stack-ref catch sb
!vm
:catch-block-tag-slot
) new-tag
)
1163 (setf (sap-ref-word catch
(* sb
!vm
:catch-block-tag-slot
1164 sb
!vm
:n-word-bytes
))
1165 (get-lisp-obj-address new-tag
)))))
1169 (* sb
!vm
:catch-block-previous-catch-slot
1170 sb
!vm
:n-word-bytes
))
1174 (* sb
!vm
:catch-block-previous-catch-slot
1175 sb
!vm
:n-word-bytes
)))))))
1179 ;;;; operations on DEBUG-FUNs
1181 ;;; Execute the forms in a context with BLOCK-VAR bound to each
1182 ;;; DEBUG-BLOCK in DEBUG-FUN successively. Result is an optional
1183 ;;; form to execute for return values, and DO-DEBUG-FUN-BLOCKS
1184 ;;; returns nil if there is no result form. This signals a
1185 ;;; NO-DEBUG-BLOCKS condition when the DEBUG-FUN lacks
1186 ;;; DEBUG-BLOCK information.
1187 (defmacro do-debug-fun-blocks
((block-var debug-fun
&optional result
)
1189 (let ((blocks (gensym))
1191 `(let ((,blocks
(debug-fun-debug-blocks ,debug-fun
)))
1192 (declare (simple-vector ,blocks
))
1193 (dotimes (,i
(length ,blocks
) ,result
)
1194 (let ((,block-var
(svref ,blocks
,i
)))
1197 ;;; Execute body in a context with VAR bound to each DEBUG-VAR in
1198 ;;; DEBUG-FUN. This returns the value of executing result (defaults to
1199 ;;; nil). This may iterate over only some of DEBUG-FUN's variables or
1200 ;;; none depending on debug policy; for example, possibly the
1201 ;;; compilation only preserved argument information.
1202 (defmacro do-debug-fun-vars
((var debug-fun
&optional result
) &body body
)
1203 (let ((vars (gensym))
1205 `(let ((,vars
(debug-fun-debug-vars ,debug-fun
)))
1206 (declare (type (or null simple-vector
) ,vars
))
1208 (dotimes (,i
(length ,vars
) ,result
)
1209 (let ((,var
(svref ,vars
,i
)))
1213 ;;; Return the object of type FUNCTION associated with the DEBUG-FUN,
1214 ;;; or NIL if the function is unavailable or is non-existent as a user
1215 ;;; callable function object.
1216 (defun debug-fun-fun (debug-fun)
1217 (let ((cached-value (debug-fun-%function debug-fun
)))
1218 (if (eq cached-value
:unparsed
)
1219 (setf (debug-fun-%function debug-fun
)
1220 (etypecase debug-fun
1223 (compiled-debug-fun-component debug-fun
))
1225 (sb!c
::compiled-debug-fun-start-pc
1226 (compiled-debug-fun-compiler-debug-fun debug-fun
))))
1227 (do ((entry (%code-entry-points component
)
1228 (%simple-fun-next entry
)))
1231 (sb!c
::compiled-debug-fun-start-pc
1232 (compiled-debug-fun-compiler-debug-fun
1233 (fun-debug-fun entry
))))
1235 (bogus-debug-fun nil
)))
1238 ;;; Return the name of the function represented by DEBUG-FUN. This may
1239 ;;; be a string or a cons; do not assume it is a symbol.
1240 (defun debug-fun-name (debug-fun)
1241 (declare (type debug-fun debug-fun
))
1242 (etypecase debug-fun
1244 (sb!c
::compiled-debug-fun-name
1245 (compiled-debug-fun-compiler-debug-fun debug-fun
)))
1247 (bogus-debug-fun-%name debug-fun
))))
1249 ;;; Return a DEBUG-FUN that represents debug information for FUN.
1250 (defun fun-debug-fun (fun)
1251 (declare (type function fun
))
1252 (ecase (widetag-of fun
)
1253 (#.sb
!vm
:closure-header-widetag
1254 (fun-debug-fun (%closure-fun fun
)))
1255 (#.sb
!vm
:funcallable-instance-header-widetag
1256 (fun-debug-fun (funcallable-instance-fun fun
)))
1257 (#.sb
!vm
:simple-fun-header-widetag
1258 (let* ((name (%simple-fun-name fun
))
1259 (component (fun-code-header fun
))
1262 (and (sb!c
::compiled-debug-fun-p x
)
1263 (eq (sb!c
::compiled-debug-fun-name x
) name
)
1264 (eq (sb!c
::compiled-debug-fun-kind x
) nil
)))
1265 (sb!c
::compiled-debug-info-fun-map
1266 (%code-debug-info component
)))))
1268 (make-compiled-debug-fun res component
)
1269 ;; KLUDGE: comment from CMU CL:
1270 ;; This used to be the non-interpreted branch, but
1271 ;; William wrote it to return the debug-fun of fun's XEP
1272 ;; instead of fun's debug-fun. The above code does this
1273 ;; more correctly, but it doesn't get or eliminate all
1274 ;; appropriate cases. It mostly works, and probably
1275 ;; works for all named functions anyway.
1277 (debug-fun-from-pc component
1278 (* (- (fun-word-offset fun
)
1279 (get-header-data component
))
1280 sb
!vm
:n-word-bytes
)))))))
1282 ;;; Return the kind of the function, which is one of :OPTIONAL,
1283 ;;; :EXTERNAL, :TOPLEVEL, :CLEANUP, or NIL.
1284 (defun debug-fun-kind (debug-fun)
1285 ;; FIXME: This "is one of" information should become part of the function
1286 ;; declamation, not just a doc string
1287 (etypecase debug-fun
1289 (sb!c
::compiled-debug-fun-kind
1290 (compiled-debug-fun-compiler-debug-fun debug-fun
)))
1294 ;;; Is there any variable information for DEBUG-FUN?
1295 (defun debug-var-info-available (debug-fun)
1296 (not (not (debug-fun-debug-vars debug-fun
))))
1298 ;;; Return a list of DEBUG-VARs in DEBUG-FUN having the same name
1299 ;;; and package as SYMBOL. If SYMBOL is uninterned, then this returns
1300 ;;; a list of DEBUG-VARs without package names and with the same name
1301 ;;; as symbol. The result of this function is limited to the
1302 ;;; availability of variable information in DEBUG-FUN; for
1303 ;;; example, possibly DEBUG-FUN only knows about its arguments.
1304 (defun debug-fun-symbol-vars (debug-fun symbol
)
1305 (let ((vars (ambiguous-debug-vars debug-fun
(symbol-name symbol
)))
1306 (package (and (symbol-package symbol
)
1307 (package-name (symbol-package symbol
)))))
1308 (delete-if (if (stringp package
)
1310 (let ((p (debug-var-package-name var
)))
1311 (or (not (stringp p
))
1312 (string/= p package
))))
1314 (stringp (debug-var-package-name var
))))
1317 ;;; Return a list of DEBUG-VARs in DEBUG-FUN whose names contain
1318 ;;; NAME-PREFIX-STRING as an initial substring. The result of this
1319 ;;; function is limited to the availability of variable information in
1320 ;;; debug-fun; for example, possibly debug-fun only knows
1321 ;;; about its arguments.
1322 (defun ambiguous-debug-vars (debug-fun name-prefix-string
)
1323 (declare (simple-string name-prefix-string
))
1324 (let ((variables (debug-fun-debug-vars debug-fun
)))
1325 (declare (type (or null simple-vector
) variables
))
1327 (let* ((len (length variables
))
1328 (prefix-len (length name-prefix-string
))
1329 (pos (find-var name-prefix-string variables len
))
1332 ;; Find names from pos to variable's len that contain prefix.
1333 (do ((i pos
(1+ i
)))
1335 (let* ((var (svref variables i
))
1336 (name (debug-var-symbol-name var
))
1337 (name-len (length name
)))
1338 (declare (simple-string name
))
1339 (when (/= (or (string/= name-prefix-string name
1340 :end1 prefix-len
:end2 name-len
)
1345 (setq res
(nreverse res
)))
1348 ;;; This returns a position in VARIABLES for one containing NAME as an
1349 ;;; initial substring. END is the length of VARIABLES if supplied.
1350 (defun find-var (name variables
&optional end
)
1351 (declare (simple-vector variables
)
1352 (simple-string name
))
1353 (let ((name-len (length name
)))
1354 (position name variables
1356 (let* ((y (debug-var-symbol-name y
))
1358 (declare (simple-string y
))
1359 (and (>= y-len name-len
)
1360 (string= x y
:end1 name-len
:end2 name-len
))))
1361 :end
(or end
(length variables
)))))
1363 ;;; Return a list representing the lambda-list for DEBUG-FUN. The
1364 ;;; list has the following structure:
1365 ;;; (required-var1 required-var2
1367 ;;; (:optional var3 suppliedp-var4)
1368 ;;; (:optional var5)
1370 ;;; (:rest var6) (:rest var7)
1372 ;;; (:keyword keyword-symbol var8 suppliedp-var9)
1373 ;;; (:keyword keyword-symbol var10)
1376 ;;; Each VARi is a DEBUG-VAR; however it may be the symbol :DELETED if
1377 ;;; it is unreferenced in DEBUG-FUN. This signals a
1378 ;;; LAMBDA-LIST-UNAVAILABLE condition when there is no argument list
1380 (defun debug-fun-lambda-list (debug-fun)
1381 (etypecase debug-fun
1382 (compiled-debug-fun (compiled-debug-fun-lambda-list debug-fun
))
1383 (bogus-debug-fun nil
)))
1385 ;;; Note: If this has to compute the lambda list, it caches it in DEBUG-FUN.
1386 (defun compiled-debug-fun-lambda-list (debug-fun)
1387 (let ((lambda-list (debug-fun-%lambda-list debug-fun
)))
1388 (cond ((eq lambda-list
:unparsed
)
1389 (multiple-value-bind (args argsp
)
1390 (parse-compiled-debug-fun-lambda-list debug-fun
)
1391 (setf (debug-fun-%lambda-list debug-fun
) args
)
1394 (debug-signal 'lambda-list-unavailable
1395 :debug-fun debug-fun
))))
1397 ((bogus-debug-fun-p debug-fun
)
1399 ((sb!c
::compiled-debug-fun-arguments
1400 (compiled-debug-fun-compiler-debug-fun debug-fun
))
1401 ;; If the packed information is there (whether empty or not) as
1402 ;; opposed to being nil, then returned our cached value (nil).
1405 ;; Our cached value is nil, and the packed lambda-list information
1406 ;; is nil, so we don't have anything available.
1407 (debug-signal 'lambda-list-unavailable
1408 :debug-fun debug-fun
)))))
1410 ;;; COMPILED-DEBUG-FUN-LAMBDA-LIST calls this when a
1411 ;;; COMPILED-DEBUG-FUN has no lambda list information cached. It
1412 ;;; returns the lambda list as the first value and whether there was
1413 ;;; any argument information as the second value. Therefore,
1414 ;;; (VALUES NIL T) means there were no arguments, but (VALUES NIL NIL)
1415 ;;; means there was no argument information.
1416 (defun parse-compiled-debug-fun-lambda-list (debug-fun)
1417 (let ((args (sb!c
::compiled-debug-fun-arguments
1418 (compiled-debug-fun-compiler-debug-fun debug-fun
))))
1423 (values (coerce (debug-fun-debug-vars debug-fun
) 'list
)
1426 (let ((vars (debug-fun-debug-vars debug-fun
))
1431 (declare (type (or null simple-vector
) vars
))
1433 (when (>= i len
) (return))
1434 (let ((ele (aref args i
)))
1439 ;; Deleted required arg at beginning of args array.
1440 (push :deleted res
))
1441 (sb!c
::optional-args
1444 ;; SUPPLIED-P var immediately following keyword or
1445 ;; optional. Stick the extra var in the result
1446 ;; element representing the keyword or optional,
1447 ;; which is the previous one.
1449 ;; FIXME: NCONC used for side-effect: the effect is defined,
1450 ;; but this is bad style no matter what.
1452 (list (compiled-debug-fun-lambda-list-var
1453 args
(incf i
) vars
))))
1456 (compiled-debug-fun-lambda-list-var
1457 args
(incf i
) vars
))
1460 ;; Just ignore the fact that the next two args are
1461 ;; the &MORE arg context and count, and act like they
1462 ;; are regular arguments.
1466 (push (list :keyword
1468 (compiled-debug-fun-lambda-list-var
1469 args
(incf i
) vars
))
1472 ;; We saw an optional marker, so the following
1473 ;; non-symbols are indexes indicating optional
1475 (push (list :optional
(svref vars ele
)) res
))
1477 ;; Required arg at beginning of args array.
1478 (push (svref vars ele
) res
))))
1480 (values (nreverse res
) t
))))))
1482 ;;; This is used in COMPILED-DEBUG-FUN-LAMBDA-LIST.
1483 (defun compiled-debug-fun-lambda-list-var (args i vars
)
1484 (declare (type (simple-array * (*)) args
)
1485 (simple-vector vars
))
1486 (let ((ele (aref args i
)))
1487 (cond ((not (symbolp ele
)) (svref vars ele
))
1488 ((eq ele
'sb
!c
::deleted
) :deleted
)
1489 (t (error "malformed arguments description")))))
1491 (defun compiled-debug-fun-debug-info (debug-fun)
1492 (%code-debug-info
(compiled-debug-fun-component debug-fun
)))
1494 ;;;; unpacking variable and basic block data
1496 (defvar *parsing-buffer
*
1497 (make-array 20 :adjustable t
:fill-pointer t
))
1498 (defvar *other-parsing-buffer
*
1499 (make-array 20 :adjustable t
:fill-pointer t
))
1500 ;;; PARSE-DEBUG-BLOCKS and PARSE-DEBUG-VARS
1501 ;;; use this to unpack binary encoded information. It returns the
1502 ;;; values returned by the last form in body.
1504 ;;; This binds buffer-var to *parsing-buffer*, makes sure it starts at
1505 ;;; element zero, and makes sure if we unwind, we nil out any set
1506 ;;; elements for GC purposes.
1508 ;;; This also binds other-var to *other-parsing-buffer* when it is
1509 ;;; supplied, making sure it starts at element zero and that we nil
1510 ;;; out any elements if we unwind.
1512 ;;; This defines the local macro RESULT that takes a buffer, copies
1513 ;;; its elements to a resulting simple-vector, nil's out elements, and
1514 ;;; restarts the buffer at element zero. RESULT returns the
1516 (eval-when (:compile-toplevel
:execute
)
1517 (sb!xc
:defmacro with-parsing-buffer
((buffer-var &optional other-var
)
1519 (let ((len (gensym))
1522 (let ((,buffer-var
*parsing-buffer
*)
1523 ,@(if other-var
`((,other-var
*other-parsing-buffer
*))))
1524 (setf (fill-pointer ,buffer-var
) 0)
1525 ,@(if other-var
`((setf (fill-pointer ,other-var
) 0)))
1526 (macrolet ((result (buf)
1527 `(let* ((,',len
(length ,buf
))
1528 (,',res
(make-array ,',len
)))
1529 (replace ,',res
,buf
:end1
,',len
:end2
,',len
)
1530 (fill ,buf nil
:end
,',len
)
1531 (setf (fill-pointer ,buf
) 0)
1534 (fill *parsing-buffer
* nil
)
1535 ,@(if other-var
`((fill *other-parsing-buffer
* nil
))))))
1538 ;;; The argument is a debug internals structure. This returns the
1539 ;;; DEBUG-BLOCKs for DEBUG-FUN, regardless of whether we have unpacked
1540 ;;; them yet. It signals a NO-DEBUG-BLOCKS condition if it can't
1541 ;;; return the blocks.
1542 (defun debug-fun-debug-blocks (debug-fun)
1543 (let ((blocks (debug-fun-blocks debug-fun
)))
1544 (cond ((eq blocks
:unparsed
)
1545 (setf (debug-fun-blocks debug-fun
)
1546 (parse-debug-blocks debug-fun
))
1547 (unless (debug-fun-blocks debug-fun
)
1548 (debug-signal 'no-debug-blocks
1549 :debug-fun debug-fun
))
1550 (debug-fun-blocks debug-fun
))
1553 (debug-signal 'no-debug-blocks
1554 :debug-fun debug-fun
)))))
1556 ;;; Return a SIMPLE-VECTOR of DEBUG-BLOCKs or NIL. NIL indicates there
1557 ;;; was no basic block information.
1558 (defun parse-debug-blocks (debug-fun)
1559 (etypecase debug-fun
1561 (parse-compiled-debug-blocks debug-fun
))
1563 (debug-signal 'no-debug-blocks
:debug-fun debug-fun
))))
1565 ;;; This does some of the work of PARSE-DEBUG-BLOCKS.
1566 (defun parse-compiled-debug-blocks (debug-fun)
1567 (let* ((var-count (length (debug-fun-debug-vars debug-fun
)))
1568 (compiler-debug-fun (compiled-debug-fun-compiler-debug-fun
1570 (blocks (sb!c
::compiled-debug-fun-blocks compiler-debug-fun
))
1571 ;; KLUDGE: 8 is a hard-wired constant in the compiler for the
1572 ;; element size of the packed binary representation of the
1574 (live-set-len (ceiling var-count
8))
1575 (tlf-number (sb!c
::compiled-debug-fun-tlf-number compiler-debug-fun
)))
1577 (return-from parse-compiled-debug-blocks nil
))
1578 (macrolet ((aref+ (a i
) `(prog1 (aref ,a
,i
) (incf ,i
))))
1579 (with-parsing-buffer (blocks-buffer locations-buffer
)
1581 (len (length blocks
))
1584 (when (>= i len
) (return))
1585 (let ((succ-and-flags (aref+ blocks i
))
1587 (declare (type (unsigned-byte 8) succ-and-flags
)
1589 (dotimes (k (ldb sb
!c
::compiled-debug-block-nsucc-byte
1591 (push (sb!c
:read-var-integer blocks i
) successors
))
1593 (dotimes (k (sb!c
:read-var-integer blocks i
)
1594 (result locations-buffer
))
1595 (let ((kind (svref sb
!c
::*compiled-code-location-kinds
*
1598 (sb!c
:read-var-integer blocks i
)))
1599 (tlf-offset (or tlf-number
1600 (sb!c
:read-var-integer blocks i
)))
1601 (form-number (sb!c
:read-var-integer blocks i
))
1602 (live-set (sb!c
:read-packed-bit-vector
1603 live-set-len blocks i
))
1604 (step-info (sb!c
:read-var-string blocks i
)))
1605 (vector-push-extend (make-known-code-location
1606 pc debug-fun tlf-offset
1607 form-number live-set kind
1610 (setf last-pc pc
))))
1611 (block (make-compiled-debug-block
1612 locations successors
1614 sb
!c
::compiled-debug-block-elsewhere-p
1615 succ-and-flags
))))))
1616 (vector-push-extend block blocks-buffer
)
1617 (dotimes (k (length locations
))
1618 (setf (code-location-%debug-block
(svref locations k
))
1620 (let ((res (result blocks-buffer
)))
1621 (declare (simple-vector res
))
1622 (dotimes (i (length res
))
1623 (let* ((block (svref res i
))
1625 (dolist (ele (debug-block-successors block
))
1626 (push (svref res ele
) succs
))
1627 (setf (debug-block-successors block
) succs
)))
1630 ;;; The argument is a debug internals structure. This returns NIL if
1631 ;;; there is no variable information. It returns an empty
1632 ;;; simple-vector if there were no locals in the function. Otherwise
1633 ;;; it returns a SIMPLE-VECTOR of DEBUG-VARs.
1634 (defun debug-fun-debug-vars (debug-fun)
1635 (let ((vars (debug-fun-%debug-vars debug-fun
)))
1636 (if (eq vars
:unparsed
)
1637 (setf (debug-fun-%debug-vars debug-fun
)
1638 (etypecase debug-fun
1640 (parse-compiled-debug-vars debug-fun
))
1641 (bogus-debug-fun nil
)))
1644 ;;; VARS is the parsed variables for a minimal debug function. We need
1645 ;;; to assign names of the form ARG-NNN. We must pad with leading
1646 ;;; zeros, since the arguments must be in alphabetical order.
1647 (defun assign-minimal-var-names (vars)
1648 (declare (simple-vector vars
))
1649 (let* ((len (length vars
))
1650 (width (length (format nil
"~W" (1- len
)))))
1652 (without-package-locks
1653 (setf (compiled-debug-var-symbol (svref vars i
))
1654 (intern (format nil
"ARG-~V,'0D" width i
)
1655 ;; KLUDGE: It's somewhat nasty to have a bare
1656 ;; package name string here. It would be
1657 ;; nicer to have #.(FIND-PACKAGE "SB!DEBUG")
1658 ;; instead, since then at least it would transform
1659 ;; correctly under package renaming and stuff.
1660 ;; However, genesis can't handle dumped packages..
1663 ;; FIXME: Maybe this could be fixed by moving the
1664 ;; whole debug-int.lisp file to warm init? (after
1665 ;; which dumping a #.(FIND-PACKAGE ..) expression
1666 ;; would work fine) If this is possible, it would
1667 ;; probably be a good thing, since minimizing the
1668 ;; amount of stuff in cold init is basically good.
1669 (or (find-package "SB-DEBUG")
1670 (find-package "SB!DEBUG"))))))))
1672 ;;; Parse the packed representation of DEBUG-VARs from
1673 ;;; DEBUG-FUN's SB!C::COMPILED-DEBUG-FUN, returning a vector
1674 ;;; of DEBUG-VARs, or NIL if there was no information to parse.
1675 (defun parse-compiled-debug-vars (debug-fun)
1676 (let* ((cdebug-fun (compiled-debug-fun-compiler-debug-fun
1678 (packed-vars (sb!c
::compiled-debug-fun-vars cdebug-fun
))
1679 (args-minimal (eq (sb!c
::compiled-debug-fun-arguments cdebug-fun
)
1683 (buffer (make-array 0 :fill-pointer
0 :adjustable t
)))
1684 ((>= i
(length packed-vars
))
1685 (let ((result (coerce buffer
'simple-vector
)))
1687 (assign-minimal-var-names result
))
1689 (flet ((geti () (prog1 (aref packed-vars i
) (incf i
))))
1690 (let* ((flags (geti))
1691 (minimal (logtest sb
!c
::compiled-debug-var-minimal-p flags
))
1692 (deleted (logtest sb
!c
::compiled-debug-var-deleted-p flags
))
1693 (live (logtest sb
!c
::compiled-debug-var-environment-live
1695 (save (logtest sb
!c
::compiled-debug-var-save-loc-p flags
))
1696 (symbol (if minimal nil
(geti)))
1697 (id (if (logtest sb
!c
::compiled-debug-var-id-p flags
)
1700 (sc-offset (if deleted
0 (geti)))
1701 (save-sc-offset (if save
(geti) nil
)))
1702 (aver (not (and args-minimal
(not minimal
))))
1703 (vector-push-extend (make-compiled-debug-var symbol
1712 ;;; If we're sure of whether code-location is known, return T or NIL.
1713 ;;; If we're :UNSURE, then try to fill in the code-location's slots.
1714 ;;; This determines whether there is any debug-block information, and
1715 ;;; if code-location is known.
1717 ;;; ??? IF this conses closures every time it's called, then break off the
1718 ;;; :UNSURE part to get the HANDLER-CASE into another function.
1719 (defun code-location-unknown-p (basic-code-location)
1720 (ecase (code-location-%unknown-p basic-code-location
)
1724 (setf (code-location-%unknown-p basic-code-location
)
1725 (handler-case (not (fill-in-code-location basic-code-location
))
1726 (no-debug-blocks () t
))))))
1728 ;;; Return the DEBUG-BLOCK containing code-location if it is available.
1729 ;;; Some debug policies inhibit debug-block information, and if none
1730 ;;; is available, then this signals a NO-DEBUG-BLOCKS condition.
1731 (defun code-location-debug-block (basic-code-location)
1732 (let ((block (code-location-%debug-block basic-code-location
)))
1733 (if (eq block
:unparsed
)
1734 (etypecase basic-code-location
1735 (compiled-code-location
1736 (compute-compiled-code-location-debug-block basic-code-location
))
1737 ;; (There used to be more cases back before sbcl-0.7.0, when
1738 ;; we did special tricks to debug the IR1 interpreter.)
1742 ;;; Store and return BASIC-CODE-LOCATION's debug-block. We determines
1743 ;;; the correct one using the code-location's pc. We use
1744 ;;; DEBUG-FUN-DEBUG-BLOCKS to return the cached block information
1745 ;;; or signal a NO-DEBUG-BLOCKS condition. The blocks are sorted by
1746 ;;; their first code-location's pc, in ascending order. Therefore, as
1747 ;;; soon as we find a block that starts with a pc greater than
1748 ;;; basic-code-location's pc, we know the previous block contains the
1749 ;;; pc. If we get to the last block, then the code-location is either
1750 ;;; in the second to last block or the last block, and we have to be
1751 ;;; careful in determining this since the last block could be code at
1752 ;;; the end of the function. We have to check for the last block being
1753 ;;; code first in order to see how to compare the code-location's pc.
1754 (defun compute-compiled-code-location-debug-block (basic-code-location)
1755 (let* ((pc (compiled-code-location-pc basic-code-location
))
1756 (debug-fun (code-location-debug-fun
1757 basic-code-location
))
1758 (blocks (debug-fun-debug-blocks debug-fun
))
1759 (len (length blocks
)))
1760 (declare (simple-vector blocks
))
1761 (setf (code-location-%debug-block basic-code-location
)
1767 (let ((last (svref blocks end
)))
1769 ((debug-block-elsewhere-p last
)
1771 (sb!c
::compiled-debug-fun-elsewhere-pc
1772 (compiled-debug-fun-compiler-debug-fun
1774 (svref blocks
(1- end
))
1777 (compiled-code-location-pc
1778 (svref (compiled-debug-block-code-locations last
)
1780 (svref blocks
(1- end
)))
1782 (declare (type index i end
))
1784 (compiled-code-location-pc
1785 (svref (compiled-debug-block-code-locations
1788 (return (svref blocks
(1- i
)))))))))
1790 ;;; Return the CODE-LOCATION's DEBUG-SOURCE.
1791 (defun code-location-debug-source (code-location)
1792 (let ((info (compiled-debug-fun-debug-info
1793 (code-location-debug-fun code-location
))))
1794 (or (sb!c
::debug-info-source info
)
1795 (debug-signal 'no-debug-blocks
:debug-fun
1796 (code-location-debug-fun code-location
)))))
1798 ;;; Returns the number of top level forms before the one containing
1799 ;;; CODE-LOCATION as seen by the compiler in some compilation unit. (A
1800 ;;; compilation unit is not necessarily a single file, see the section
1801 ;;; on debug-sources.)
1802 (defun code-location-toplevel-form-offset (code-location)
1803 (when (code-location-unknown-p code-location
)
1804 (error 'unknown-code-location
:code-location code-location
))
1805 (let ((tlf-offset (code-location-%tlf-offset code-location
)))
1806 (cond ((eq tlf-offset
:unparsed
)
1807 (etypecase code-location
1808 (compiled-code-location
1809 (unless (fill-in-code-location code-location
)
1810 ;; This check should be unnecessary. We're missing
1811 ;; debug info the compiler should have dumped.
1812 (bug "unknown code location"))
1813 (code-location-%tlf-offset code-location
))
1814 ;; (There used to be more cases back before sbcl-0.7.0,,
1815 ;; when we did special tricks to debug the IR1
1820 ;;; Return the number of the form corresponding to CODE-LOCATION. The
1821 ;;; form number is derived by a walking the subforms of a top level
1822 ;;; form in depth-first order.
1823 (defun code-location-form-number (code-location)
1824 (when (code-location-unknown-p code-location
)
1825 (error 'unknown-code-location
:code-location code-location
))
1826 (let ((form-num (code-location-%form-number code-location
)))
1827 (cond ((eq form-num
:unparsed
)
1828 (etypecase code-location
1829 (compiled-code-location
1830 (unless (fill-in-code-location code-location
)
1831 ;; This check should be unnecessary. We're missing
1832 ;; debug info the compiler should have dumped.
1833 (bug "unknown code location"))
1834 (code-location-%form-number code-location
))
1835 ;; (There used to be more cases back before sbcl-0.7.0,,
1836 ;; when we did special tricks to debug the IR1
1841 ;;; Return the kind of CODE-LOCATION, one of:
1842 ;;; :INTERPRETED, :UNKNOWN-RETURN, :KNOWN-RETURN, :INTERNAL-ERROR,
1843 ;;; :NON-LOCAL-EXIT, :BLOCK-START, :CALL-SITE, :SINGLE-VALUE-RETURN,
1844 ;;; :NON-LOCAL-ENTRY
1845 (defun code-location-kind (code-location)
1846 (when (code-location-unknown-p code-location
)
1847 (error 'unknown-code-location
:code-location code-location
))
1848 (etypecase code-location
1849 (compiled-code-location
1850 (let ((kind (compiled-code-location-kind code-location
)))
1851 (cond ((not (eq kind
:unparsed
)) kind
)
1852 ((not (fill-in-code-location code-location
))
1853 ;; This check should be unnecessary. We're missing
1854 ;; debug info the compiler should have dumped.
1855 (bug "unknown code location"))
1857 (compiled-code-location-kind code-location
)))))
1858 ;; (There used to be more cases back before sbcl-0.7.0,,
1859 ;; when we did special tricks to debug the IR1
1863 ;;; This returns CODE-LOCATION's live-set if it is available. If
1864 ;;; there is no debug-block information, this returns NIL.
1865 (defun compiled-code-location-live-set (code-location)
1866 (if (code-location-unknown-p code-location
)
1868 (let ((live-set (compiled-code-location-%live-set code-location
)))
1869 (cond ((eq live-set
:unparsed
)
1870 (unless (fill-in-code-location code-location
)
1871 ;; This check should be unnecessary. We're missing
1872 ;; debug info the compiler should have dumped.
1874 ;; FIXME: This error and comment happen over and over again.
1875 ;; Make them a shared function.
1876 (bug "unknown code location"))
1877 (compiled-code-location-%live-set code-location
))
1880 ;;; true if OBJ1 and OBJ2 are the same place in the code
1881 (defun code-location= (obj1 obj2
)
1883 (compiled-code-location
1885 (compiled-code-location
1886 (and (eq (code-location-debug-fun obj1
)
1887 (code-location-debug-fun obj2
))
1888 (sub-compiled-code-location= obj1 obj2
)))
1889 ;; (There used to be more cases back before sbcl-0.7.0,,
1890 ;; when we did special tricks to debug the IR1
1893 ;; (There used to be more cases back before sbcl-0.7.0,,
1894 ;; when we did special tricks to debug IR1-interpreted code.)
1896 (defun sub-compiled-code-location= (obj1 obj2
)
1897 (= (compiled-code-location-pc obj1
)
1898 (compiled-code-location-pc obj2
)))
1900 ;;; Fill in CODE-LOCATION's :UNPARSED slots, returning T or NIL
1901 ;;; depending on whether the code-location was known in its
1902 ;;; DEBUG-FUN's debug-block information. This may signal a
1903 ;;; NO-DEBUG-BLOCKS condition due to DEBUG-FUN-DEBUG-BLOCKS, and
1904 ;;; it assumes the %UNKNOWN-P slot is already set or going to be set.
1905 (defun fill-in-code-location (code-location)
1906 (declare (type compiled-code-location code-location
))
1907 (let* ((debug-fun (code-location-debug-fun code-location
))
1908 (blocks (debug-fun-debug-blocks debug-fun
)))
1909 (declare (simple-vector blocks
))
1910 (dotimes (i (length blocks
) nil
)
1911 (let* ((block (svref blocks i
))
1912 (locations (compiled-debug-block-code-locations block
)))
1913 (declare (simple-vector locations
))
1914 (dotimes (j (length locations
))
1915 (let ((loc (svref locations j
)))
1916 (when (sub-compiled-code-location= code-location loc
)
1917 (setf (code-location-%debug-block code-location
) block
)
1918 (setf (code-location-%tlf-offset code-location
)
1919 (code-location-%tlf-offset loc
))
1920 (setf (code-location-%form-number code-location
)
1921 (code-location-%form-number loc
))
1922 (setf (compiled-code-location-%live-set code-location
)
1923 (compiled-code-location-%live-set loc
))
1924 (setf (compiled-code-location-kind code-location
)
1925 (compiled-code-location-kind loc
))
1926 (setf (compiled-code-location-step-info code-location
)
1927 (compiled-code-location-step-info loc
))
1928 (return-from fill-in-code-location t
))))))))
1930 ;;;; operations on DEBUG-BLOCKs
1932 ;;; Execute FORMS in a context with CODE-VAR bound to each
1933 ;;; CODE-LOCATION in DEBUG-BLOCK, and return the value of RESULT.
1934 (defmacro do-debug-block-locations
((code-var debug-block
&optional result
)
1936 (let ((code-locations (gensym))
1938 `(let ((,code-locations
(debug-block-code-locations ,debug-block
)))
1939 (declare (simple-vector ,code-locations
))
1940 (dotimes (,i
(length ,code-locations
) ,result
)
1941 (let ((,code-var
(svref ,code-locations
,i
)))
1944 ;;; Return the name of the function represented by DEBUG-FUN.
1945 ;;; This may be a string or a cons; do not assume it is a symbol.
1946 (defun debug-block-fun-name (debug-block)
1947 (etypecase debug-block
1948 (compiled-debug-block
1949 (let ((code-locs (compiled-debug-block-code-locations debug-block
)))
1950 (declare (simple-vector code-locs
))
1951 (if (zerop (length code-locs
))
1952 "??? Can't get name of debug-block's function."
1954 (code-location-debug-fun (svref code-locs
0))))))
1955 ;; (There used to be more cases back before sbcl-0.7.0, when we
1956 ;; did special tricks to debug the IR1 interpreter.)
1959 (defun debug-block-code-locations (debug-block)
1960 (etypecase debug-block
1961 (compiled-debug-block
1962 (compiled-debug-block-code-locations debug-block
))
1963 ;; (There used to be more cases back before sbcl-0.7.0, when we
1964 ;; did special tricks to debug the IR1 interpreter.)
1967 ;;;; operations on debug variables
1969 (defun debug-var-symbol-name (debug-var)
1970 (symbol-name (debug-var-symbol debug-var
)))
1972 ;;; FIXME: Make sure that this isn't called anywhere that it wouldn't
1973 ;;; be acceptable to have NIL returned, or that it's only called on
1974 ;;; DEBUG-VARs whose symbols have non-NIL packages.
1975 (defun debug-var-package-name (debug-var)
1976 (package-name (symbol-package (debug-var-symbol debug-var
))))
1978 ;;; Return the value stored for DEBUG-VAR in frame, or if the value is
1979 ;;; not :VALID, then signal an INVALID-VALUE error.
1980 (defun debug-var-valid-value (debug-var frame
)
1981 (unless (eq (debug-var-validity debug-var
(frame-code-location frame
))
1983 (error 'invalid-value
:debug-var debug-var
:frame frame
))
1984 (debug-var-value debug-var frame
))
1986 ;;; Returns the value stored for DEBUG-VAR in frame. The value may be
1987 ;;; invalid. This is SETFable.
1988 (defun debug-var-value (debug-var frame
)
1989 (aver (typep frame
'compiled-frame
))
1990 (let ((res (access-compiled-debug-var-slot debug-var frame
)))
1991 (if (indirect-value-cell-p res
)
1992 (value-cell-ref res
)
1995 ;;; This returns what is stored for the variable represented by
1996 ;;; DEBUG-VAR relative to the FRAME. This may be an indirect value
1997 ;;; cell if the variable is both closed over and set.
1998 (defun access-compiled-debug-var-slot (debug-var frame
)
1999 (declare (optimize (speed 1)))
2000 (let ((escaped (compiled-frame-escaped frame
)))
2002 (sub-access-debug-var-slot
2003 (frame-pointer frame
)
2004 (compiled-debug-var-sc-offset debug-var
)
2006 (sub-access-debug-var-slot
2007 (frame-pointer frame
)
2008 (or (compiled-debug-var-save-sc-offset debug-var
)
2009 (compiled-debug-var-sc-offset debug-var
))))))
2011 ;;; a helper function for working with possibly-invalid values:
2012 ;;; Do (%MAKE-LISP-OBJ VAL) only if the value looks valid.
2014 ;;; (Such values can arise in registers on machines with conservative
2015 ;;; GC, and might also arise in debug variable locations when
2016 ;;; those variables are invalid.)
2017 (defun make-lisp-obj (val &optional
(errorp t
))
2020 (zerop (logand val sb
!vm
:fixnum-tag-mask
))
2021 ;; immediate single float, 64-bit only
2022 #!+#.
(cl:if
(cl:= sb
!vm
::n-machine-word-bits
64) '(and) '(or))
2023 (= (logand val
#xff
) sb
!vm
:single-float-widetag
)
2025 (and (zerop (logandc2 val
#x1fffffff
)) ; Top bits zero
2026 (= (logand val
#xff
) sb
!vm
:character-widetag
)) ; char tag
2028 (= val sb
!vm
:unbound-marker-widetag
)
2031 (not (zerop (valid-lisp-pointer-p (int-sap val
))))
2032 ;; FIXME: There is no fundamental reason not to use the above
2033 ;; function on other platforms as well, but I didn't have
2034 ;; others available while doing this. --NS 2007-06-21
2036 (and (logbitp 0 val
)
2037 (or (< sb
!vm
:read-only-space-start val
2038 (* sb
!vm
:*read-only-space-free-pointer
*
2039 sb
!vm
:n-word-bytes
))
2040 (< sb
!vm
:static-space-start val
2041 (* sb
!vm
:*static-space-free-pointer
*
2042 sb
!vm
:n-word-bytes
))
2043 (< (current-dynamic-space-start) val
2044 (sap-int (dynamic-space-free-pointer))))))
2045 (values (%make-lisp-obj val
) t
)
2047 (error "~S is not a valid argument to ~S"
2049 (values (make-unprintable-object (format nil
"invalid object #x~X" val
))
2053 (defun sub-access-debug-var-slot (fp sc-offset
&optional escaped
)
2054 (macrolet ((with-escaped-value ((var) &body forms
)
2056 (let ((,var
(sb!vm
:context-register
2058 (sb!c
:sc-offset-offset sc-offset
))))
2060 :invalid-value-for-unescaped-register-storage
))
2061 (escaped-float-value (format)
2063 (sb!vm
:context-float-register
2065 (sb!c
:sc-offset-offset sc-offset
)
2067 :invalid-value-for-unescaped-register-storage
))
2068 (with-nfp ((var) &body body
)
2069 `(let ((,var
(if escaped
2071 (sb!vm
:context-register escaped
2074 (sb!sys
:sap-ref-sap fp
(* nfp-save-offset
2075 sb
!vm
:n-word-bytes
))
2077 (sb!vm
::make-number-stack-pointer
2078 (sb!sys
:sap-ref-32 fp
(* nfp-save-offset
2079 sb
!vm
:n-word-bytes
))))))
2081 (ecase (sb!c
:sc-offset-scn sc-offset
)
2082 ((#.sb
!vm
:any-reg-sc-number
2083 #.sb
!vm
:descriptor-reg-sc-number
2084 #!+rt
#.sb
!vm
:word-pointer-reg-sc-number
)
2085 (sb!sys
:without-gcing
2086 (with-escaped-value (val)
2087 (make-lisp-obj val nil
))))
2088 (#.sb
!vm
:character-reg-sc-number
2089 (with-escaped-value (val)
2091 (#.sb
!vm
:sap-reg-sc-number
2092 (with-escaped-value (val)
2093 (sb!sys
:int-sap val
)))
2094 (#.sb
!vm
:signed-reg-sc-number
2095 (with-escaped-value (val)
2096 (if (logbitp (1- sb
!vm
:n-word-bits
) val
)
2097 (logior val
(ash -
1 sb
!vm
:n-word-bits
))
2099 (#.sb
!vm
:unsigned-reg-sc-number
2100 (with-escaped-value (val)
2102 (#.sb
!vm
:non-descriptor-reg-sc-number
2103 (error "Local non-descriptor register access?"))
2104 (#.sb
!vm
:interior-reg-sc-number
2105 (error "Local interior register access?"))
2106 (#.sb
!vm
:single-reg-sc-number
2107 (escaped-float-value single-float
))
2108 (#.sb
!vm
:double-reg-sc-number
2109 (escaped-float-value double-float
))
2111 (#.sb
!vm
:long-reg-sc-number
2112 (escaped-float-value long-float
))
2113 (#.sb
!vm
:complex-single-reg-sc-number
2116 (sb!vm
:context-float-register
2117 escaped
(sb!c
:sc-offset-offset sc-offset
) 'single-float
)
2118 (sb!vm
:context-float-register
2119 escaped
(1+ (sb!c
:sc-offset-offset sc-offset
)) 'single-float
))
2120 :invalid-value-for-unescaped-register-storage
))
2121 (#.sb
!vm
:complex-double-reg-sc-number
2124 (sb!vm
:context-float-register
2125 escaped
(sb!c
:sc-offset-offset sc-offset
) 'double-float
)
2126 (sb!vm
:context-float-register
2127 escaped
(+ (sb!c
:sc-offset-offset sc-offset
) #!+sparc
2 #!-sparc
1)
2129 :invalid-value-for-unescaped-register-storage
))
2131 (#.sb
!vm
:complex-long-reg-sc-number
2134 (sb!vm
:context-float-register
2135 escaped
(sb!c
:sc-offset-offset sc-offset
) 'long-float
)
2136 (sb!vm
:context-float-register
2137 escaped
(+ (sb!c
:sc-offset-offset sc-offset
) #!+sparc
4)
2139 :invalid-value-for-unescaped-register-storage
))
2140 (#.sb
!vm
:single-stack-sc-number
2142 (sb!sys
:sap-ref-single nfp
(* (sb!c
:sc-offset-offset sc-offset
)
2143 sb
!vm
:n-word-bytes
))))
2144 (#.sb
!vm
:double-stack-sc-number
2146 (sb!sys
:sap-ref-double nfp
(* (sb!c
:sc-offset-offset sc-offset
)
2147 sb
!vm
:n-word-bytes
))))
2149 (#.sb
!vm
:long-stack-sc-number
2151 (sb!sys
:sap-ref-long nfp
(* (sb!c
:sc-offset-offset sc-offset
)
2152 sb
!vm
:n-word-bytes
))))
2153 (#.sb
!vm
:complex-single-stack-sc-number
2156 (sb!sys
:sap-ref-single nfp
(* (sb!c
:sc-offset-offset sc-offset
)
2157 sb
!vm
:n-word-bytes
))
2158 (sb!sys
:sap-ref-single nfp
(* (1+ (sb!c
:sc-offset-offset sc-offset
))
2159 sb
!vm
:n-word-bytes
)))))
2160 (#.sb
!vm
:complex-double-stack-sc-number
2163 (sb!sys
:sap-ref-double nfp
(* (sb!c
:sc-offset-offset sc-offset
)
2164 sb
!vm
:n-word-bytes
))
2165 (sb!sys
:sap-ref-double nfp
(* (+ (sb!c
:sc-offset-offset sc-offset
) 2)
2166 sb
!vm
:n-word-bytes
)))))
2168 (#.sb
!vm
:complex-long-stack-sc-number
2171 (sb!sys
:sap-ref-long nfp
(* (sb!c
:sc-offset-offset sc-offset
)
2172 sb
!vm
:n-word-bytes
))
2173 (sb!sys
:sap-ref-long nfp
(* (+ (sb!c
:sc-offset-offset sc-offset
)
2175 sb
!vm
:n-word-bytes
)))))
2176 (#.sb
!vm
:control-stack-sc-number
2177 (sb!kernel
:stack-ref fp
(sb!c
:sc-offset-offset sc-offset
)))
2178 (#.sb
!vm
:character-stack-sc-number
2180 (code-char (sb!sys
:sap-ref-32 nfp
(* (sb!c
:sc-offset-offset sc-offset
)
2181 sb
!vm
:n-word-bytes
)))))
2182 (#.sb
!vm
:unsigned-stack-sc-number
2184 (sb!sys
:sap-ref-32 nfp
(* (sb!c
:sc-offset-offset sc-offset
)
2185 sb
!vm
:n-word-bytes
))))
2186 (#.sb
!vm
:signed-stack-sc-number
2188 (sb!sys
:signed-sap-ref-32 nfp
(* (sb!c
:sc-offset-offset sc-offset
)
2189 sb
!vm
:n-word-bytes
))))
2190 (#.sb
!vm
:sap-stack-sc-number
2192 (sb!sys
:sap-ref-sap nfp
(* (sb!c
:sc-offset-offset sc-offset
)
2193 sb
!vm
:n-word-bytes
)))))))
2196 (defun sub-access-debug-var-slot (fp sc-offset
&optional escaped
)
2197 (declare (type system-area-pointer fp
))
2198 (macrolet ((with-escaped-value ((var) &body forms
)
2200 (let ((,var
(sb!vm
:context-register
2202 (sb!c
:sc-offset-offset sc-offset
))))
2204 :invalid-value-for-unescaped-register-storage
))
2205 (escaped-float-value (format)
2207 (sb!vm
:context-float-register
2208 escaped
(sb!c
:sc-offset-offset sc-offset
) ',format
)
2209 :invalid-value-for-unescaped-register-storage
))
2210 (escaped-complex-float-value (format)
2213 (sb!vm
:context-float-register
2214 escaped
(sb!c
:sc-offset-offset sc-offset
) ',format
)
2215 (sb!vm
:context-float-register
2216 escaped
(1+ (sb!c
:sc-offset-offset sc-offset
)) ',format
))
2217 :invalid-value-for-unescaped-register-storage
)))
2218 (ecase (sb!c
:sc-offset-scn sc-offset
)
2219 ((#.sb
!vm
:any-reg-sc-number
#.sb
!vm
:descriptor-reg-sc-number
)
2221 (with-escaped-value (val)
2222 (make-lisp-obj val nil
))))
2223 (#.sb
!vm
:character-reg-sc-number
2224 (with-escaped-value (val)
2226 (#.sb
!vm
:sap-reg-sc-number
2227 (with-escaped-value (val)
2229 (#.sb
!vm
:signed-reg-sc-number
2230 (with-escaped-value (val)
2231 (if (logbitp (1- sb
!vm
:n-word-bits
) val
)
2232 (logior val
(ash -
1 sb
!vm
:n-word-bits
))
2234 (#.sb
!vm
:unsigned-reg-sc-number
2235 (with-escaped-value (val)
2237 (#.sb
!vm
:single-reg-sc-number
2238 (escaped-float-value single-float
))
2239 (#.sb
!vm
:double-reg-sc-number
2240 (escaped-float-value double-float
))
2242 (#.sb
!vm
:long-reg-sc-number
2243 (escaped-float-value long-float
))
2244 (#.sb
!vm
:complex-single-reg-sc-number
2245 (escaped-complex-float-value single-float
))
2246 (#.sb
!vm
:complex-double-reg-sc-number
2247 (escaped-complex-float-value double-float
))
2249 (#.sb
!vm
:complex-long-reg-sc-number
2250 (escaped-complex-float-value long-float
))
2251 (#.sb
!vm
:single-stack-sc-number
2252 (sap-ref-single fp
(- (* (1+ (sb!c
:sc-offset-offset sc-offset
))
2253 sb
!vm
:n-word-bytes
))))
2254 (#.sb
!vm
:double-stack-sc-number
2255 (sap-ref-double fp
(- (* (+ (sb!c
:sc-offset-offset sc-offset
) 2)
2256 sb
!vm
:n-word-bytes
))))
2258 (#.sb
!vm
:long-stack-sc-number
2259 (sap-ref-long fp
(- (* (+ (sb!c
:sc-offset-offset sc-offset
) 3)
2260 sb
!vm
:n-word-bytes
))))
2261 (#.sb
!vm
:complex-single-stack-sc-number
2263 (sap-ref-single fp
(- (* (1+ (sb!c
:sc-offset-offset sc-offset
))
2264 sb
!vm
:n-word-bytes
)))
2265 (sap-ref-single fp
(- (* (+ (sb!c
:sc-offset-offset sc-offset
) 2)
2266 sb
!vm
:n-word-bytes
)))))
2267 (#.sb
!vm
:complex-double-stack-sc-number
2269 (sap-ref-double fp
(- (* (+ (sb!c
:sc-offset-offset sc-offset
) 2)
2270 sb
!vm
:n-word-bytes
)))
2271 (sap-ref-double fp
(- (* (+ (sb!c
:sc-offset-offset sc-offset
) 4)
2272 sb
!vm
:n-word-bytes
)))))
2274 (#.sb
!vm
:complex-long-stack-sc-number
2276 (sap-ref-long fp
(- (* (+ (sb!c
:sc-offset-offset sc-offset
) 3)
2277 sb
!vm
:n-word-bytes
)))
2278 (sap-ref-long fp
(- (* (+ (sb!c
:sc-offset-offset sc-offset
) 6)
2279 sb
!vm
:n-word-bytes
)))))
2280 (#.sb
!vm
:control-stack-sc-number
2281 (stack-ref fp
(sb!c
:sc-offset-offset sc-offset
)))
2282 (#.sb
!vm
:character-stack-sc-number
2284 (sap-ref-word fp
(- (* (1+ (sb!c
:sc-offset-offset sc-offset
))
2285 sb
!vm
:n-word-bytes
)))))
2286 (#.sb
!vm
:unsigned-stack-sc-number
2287 (sap-ref-word fp
(- (* (1+ (sb!c
:sc-offset-offset sc-offset
))
2288 sb
!vm
:n-word-bytes
))))
2289 (#.sb
!vm
:signed-stack-sc-number
2290 (signed-sap-ref-word fp
(- (* (1+ (sb!c
:sc-offset-offset sc-offset
))
2291 sb
!vm
:n-word-bytes
))))
2292 (#.sb
!vm
:sap-stack-sc-number
2293 (sap-ref-sap fp
(- (* (1+ (sb!c
:sc-offset-offset sc-offset
))
2294 sb
!vm
:n-word-bytes
)))))))
2296 ;;; This stores value as the value of DEBUG-VAR in FRAME. In the
2297 ;;; COMPILED-DEBUG-VAR case, access the current value to determine if
2298 ;;; it is an indirect value cell. This occurs when the variable is
2299 ;;; both closed over and set.
2300 (defun %set-debug-var-value
(debug-var frame new-value
)
2301 (aver (typep frame
'compiled-frame
))
2302 (let ((old-value (access-compiled-debug-var-slot debug-var frame
)))
2303 (if (indirect-value-cell-p old-value
)
2304 (value-cell-set old-value new-value
)
2305 (set-compiled-debug-var-slot debug-var frame new-value
)))
2308 ;;; This stores VALUE for the variable represented by debug-var
2309 ;;; relative to the frame. This assumes the location directly contains
2310 ;;; the variable's value; that is, there is no indirect value cell
2311 ;;; currently there in case the variable is both closed over and set.
2312 (defun set-compiled-debug-var-slot (debug-var frame value
)
2313 (let ((escaped (compiled-frame-escaped frame
)))
2315 (sub-set-debug-var-slot (frame-pointer frame
)
2316 (compiled-debug-var-sc-offset debug-var
)
2318 (sub-set-debug-var-slot
2319 (frame-pointer frame
)
2320 (or (compiled-debug-var-save-sc-offset debug-var
)
2321 (compiled-debug-var-sc-offset debug-var
))
2325 (defun sub-set-debug-var-slot (fp sc-offset value
&optional escaped
)
2326 (macrolet ((set-escaped-value (val)
2328 (setf (sb!vm
:context-register
2330 (sb!c
:sc-offset-offset sc-offset
))
2333 (set-escaped-float-value (format val
)
2335 (setf (sb!vm
:context-float-register
2337 (sb!c
:sc-offset-offset sc-offset
)
2341 (with-nfp ((var) &body body
)
2342 `(let ((,var
(if escaped
2344 (sb!vm
:context-register escaped
2349 sb
!vm
:n-word-bytes
))
2351 (sb!vm
::make-number-stack-pointer
2354 sb
!vm
:n-word-bytes
))))))
2356 (ecase (sb!c
:sc-offset-scn sc-offset
)
2357 ((#.sb
!vm
:any-reg-sc-number
2358 #.sb
!vm
:descriptor-reg-sc-number
2359 #!+rt
#.sb
!vm
:word-pointer-reg-sc-number
)
2362 (get-lisp-obj-address value
))))
2363 (#.sb
!vm
:character-reg-sc-number
2364 (set-escaped-value (char-code value
)))
2365 (#.sb
!vm
:sap-reg-sc-number
2366 (set-escaped-value (sap-int value
)))
2367 (#.sb
!vm
:signed-reg-sc-number
2368 (set-escaped-value (logand value
(1- (ash 1 sb
!vm
:n-word-bits
)))))
2369 (#.sb
!vm
:unsigned-reg-sc-number
2370 (set-escaped-value value
))
2371 (#.sb
!vm
:non-descriptor-reg-sc-number
2372 (error "Local non-descriptor register access?"))
2373 (#.sb
!vm
:interior-reg-sc-number
2374 (error "Local interior register access?"))
2375 (#.sb
!vm
:single-reg-sc-number
2376 (set-escaped-float-value single-float value
))
2377 (#.sb
!vm
:double-reg-sc-number
2378 (set-escaped-float-value double-float value
))
2380 (#.sb
!vm
:long-reg-sc-number
2381 (set-escaped-float-value long-float value
))
2382 (#.sb
!vm
:complex-single-reg-sc-number
2384 (setf (sb!vm
:context-float-register escaped
2385 (sb!c
:sc-offset-offset sc-offset
)
2388 (setf (sb!vm
:context-float-register
2389 escaped
(1+ (sb!c
:sc-offset-offset sc-offset
))
2393 (#.sb
!vm
:complex-double-reg-sc-number
2395 (setf (sb!vm
:context-float-register
2396 escaped
(sb!c
:sc-offset-offset sc-offset
) 'double-float
)
2398 (setf (sb!vm
:context-float-register
2400 (+ (sb!c
:sc-offset-offset sc-offset
) #!+sparc
2 #!-sparc
1)
2405 (#.sb
!vm
:complex-long-reg-sc-number
2407 (setf (sb!vm
:context-float-register
2408 escaped
(sb!c
:sc-offset-offset sc-offset
) 'long-float
)
2410 (setf (sb!vm
:context-float-register
2412 (+ (sb!c
:sc-offset-offset sc-offset
) #!+sparc
4)
2416 (#.sb
!vm
:single-stack-sc-number
2418 (setf (sap-ref-single nfp
(* (sb!c
:sc-offset-offset sc-offset
)
2419 sb
!vm
:n-word-bytes
))
2420 (the single-float value
))))
2421 (#.sb
!vm
:double-stack-sc-number
2423 (setf (sap-ref-double nfp
(* (sb!c
:sc-offset-offset sc-offset
)
2424 sb
!vm
:n-word-bytes
))
2425 (the double-float value
))))
2427 (#.sb
!vm
:long-stack-sc-number
2429 (setf (sap-ref-long nfp
(* (sb!c
:sc-offset-offset sc-offset
)
2430 sb
!vm
:n-word-bytes
))
2431 (the long-float value
))))
2432 (#.sb
!vm
:complex-single-stack-sc-number
2434 (setf (sap-ref-single
2435 nfp
(* (sb!c
:sc-offset-offset sc-offset
) sb
!vm
:n-word-bytes
))
2436 (the single-float
(realpart value
)))
2437 (setf (sap-ref-single
2438 nfp
(* (1+ (sb!c
:sc-offset-offset sc-offset
))
2439 sb
!vm
:n-word-bytes
))
2440 (the single-float
(realpart value
)))))
2441 (#.sb
!vm
:complex-double-stack-sc-number
2443 (setf (sap-ref-double
2444 nfp
(* (sb!c
:sc-offset-offset sc-offset
) sb
!vm
:n-word-bytes
))
2445 (the double-float
(realpart value
)))
2446 (setf (sap-ref-double
2447 nfp
(* (+ (sb!c
:sc-offset-offset sc-offset
) 2)
2448 sb
!vm
:n-word-bytes
))
2449 (the double-float
(realpart value
)))))
2451 (#.sb
!vm
:complex-long-stack-sc-number
2454 nfp
(* (sb!c
:sc-offset-offset sc-offset
) sb
!vm
:n-word-bytes
))
2455 (the long-float
(realpart value
)))
2457 nfp
(* (+ (sb!c
:sc-offset-offset sc-offset
) #!+sparc
4)
2458 sb
!vm
:n-word-bytes
))
2459 (the long-float
(realpart value
)))))
2460 (#.sb
!vm
:control-stack-sc-number
2461 (setf (stack-ref fp
(sb!c
:sc-offset-offset sc-offset
)) value
))
2462 (#.sb
!vm
:character-stack-sc-number
2464 (setf (sap-ref-32 nfp
(* (sb!c
:sc-offset-offset sc-offset
)
2465 sb
!vm
:n-word-bytes
))
2466 (char-code (the character value
)))))
2467 (#.sb
!vm
:unsigned-stack-sc-number
2469 (setf (sap-ref-32 nfp
(* (sb!c
:sc-offset-offset sc-offset
)
2470 sb
!vm
:n-word-bytes
))
2471 (the (unsigned-byte 32) value
))))
2472 (#.sb
!vm
:signed-stack-sc-number
2474 (setf (signed-sap-ref-32 nfp
(* (sb!c
:sc-offset-offset sc-offset
)
2475 sb
!vm
:n-word-bytes
))
2476 (the (signed-byte 32) value
))))
2477 (#.sb
!vm
:sap-stack-sc-number
2479 (setf (sap-ref-sap nfp
(* (sb!c
:sc-offset-offset sc-offset
)
2480 sb
!vm
:n-word-bytes
))
2481 (the system-area-pointer value
)))))))
2484 (defun sub-set-debug-var-slot (fp sc-offset value
&optional escaped
)
2485 (macrolet ((set-escaped-value (val)
2487 (setf (sb!vm
:context-register
2489 (sb!c
:sc-offset-offset sc-offset
))
2492 (ecase (sb!c
:sc-offset-scn sc-offset
)
2493 ((#.sb
!vm
:any-reg-sc-number
#.sb
!vm
:descriptor-reg-sc-number
)
2496 (get-lisp-obj-address value
))))
2497 (#.sb
!vm
:character-reg-sc-number
2498 (set-escaped-value (char-code value
)))
2499 (#.sb
!vm
:sap-reg-sc-number
2500 (set-escaped-value (sap-int value
)))
2501 (#.sb
!vm
:signed-reg-sc-number
2502 (set-escaped-value (logand value
(1- (ash 1 sb
!vm
:n-word-bits
)))))
2503 (#.sb
!vm
:unsigned-reg-sc-number
2504 (set-escaped-value value
))
2505 (#.sb
!vm
:single-reg-sc-number
2506 #+nil
;; don't have escaped floats.
2507 (set-escaped-float-value single-float value
))
2508 (#.sb
!vm
:double-reg-sc-number
2509 #+nil
;; don't have escaped floats -- still in npx?
2510 (set-escaped-float-value double-float value
))
2512 (#.sb
!vm
:long-reg-sc-number
2513 #+nil
;; don't have escaped floats -- still in npx?
2514 (set-escaped-float-value long-float value
))
2515 (#.sb
!vm
:single-stack-sc-number
2516 (setf (sap-ref-single
2517 fp
(- (* (1+ (sb!c
:sc-offset-offset sc-offset
))
2518 sb
!vm
:n-word-bytes
)))
2519 (the single-float value
)))
2520 (#.sb
!vm
:double-stack-sc-number
2521 (setf (sap-ref-double
2522 fp
(- (* (+ (sb!c
:sc-offset-offset sc-offset
) 2)
2523 sb
!vm
:n-word-bytes
)))
2524 (the double-float value
)))
2526 (#.sb
!vm
:long-stack-sc-number
2528 fp
(- (* (+ (sb!c
:sc-offset-offset sc-offset
) 3)
2529 sb
!vm
:n-word-bytes
)))
2530 (the long-float value
)))
2531 (#.sb
!vm
:complex-single-stack-sc-number
2532 (setf (sap-ref-single
2533 fp
(- (* (1+ (sb!c
:sc-offset-offset sc-offset
))
2534 sb
!vm
:n-word-bytes
)))
2535 (realpart (the (complex single-float
) value
)))
2536 (setf (sap-ref-single
2537 fp
(- (* (+ (sb!c
:sc-offset-offset sc-offset
) 2)
2538 sb
!vm
:n-word-bytes
)))
2539 (imagpart (the (complex single-float
) value
))))
2540 (#.sb
!vm
:complex-double-stack-sc-number
2541 (setf (sap-ref-double
2542 fp
(- (* (+ (sb!c
:sc-offset-offset sc-offset
) 2)
2543 sb
!vm
:n-word-bytes
)))
2544 (realpart (the (complex double-float
) value
)))
2545 (setf (sap-ref-double
2546 fp
(- (* (+ (sb!c
:sc-offset-offset sc-offset
) 4)
2547 sb
!vm
:n-word-bytes
)))
2548 (imagpart (the (complex double-float
) value
))))
2550 (#.sb
!vm
:complex-long-stack-sc-number
2552 fp
(- (* (+ (sb!c
:sc-offset-offset sc-offset
) 3)
2553 sb
!vm
:n-word-bytes
)))
2554 (realpart (the (complex long-float
) value
)))
2556 fp
(- (* (+ (sb!c
:sc-offset-offset sc-offset
) 6)
2557 sb
!vm
:n-word-bytes
)))
2558 (imagpart (the (complex long-float
) value
))))
2559 (#.sb
!vm
:control-stack-sc-number
2560 (setf (stack-ref fp
(sb!c
:sc-offset-offset sc-offset
)) value
))
2561 (#.sb
!vm
:character-stack-sc-number
2562 (setf (sap-ref-word fp
(- (* (1+ (sb!c
:sc-offset-offset sc-offset
))
2563 sb
!vm
:n-word-bytes
)))
2564 (char-code (the character value
))))
2565 (#.sb
!vm
:unsigned-stack-sc-number
2566 (setf (sap-ref-word fp
(- (* (1+ (sb!c
:sc-offset-offset sc-offset
))
2567 sb
!vm
:n-word-bytes
)))
2568 (the sb
!vm
:word value
)))
2569 (#.sb
!vm
:signed-stack-sc-number
2570 (setf (signed-sap-ref-word
2571 fp
(- (* (1+ (sb!c
:sc-offset-offset sc-offset
))
2572 sb
!vm
:n-word-bytes
)))
2573 (the (signed-byte #.sb
!vm
:n-word-bits
) value
)))
2574 (#.sb
!vm
:sap-stack-sc-number
2575 (setf (sap-ref-sap fp
(- (* (1+ (sb!c
:sc-offset-offset sc-offset
))
2576 sb
!vm
:n-word-bytes
)))
2577 (the system-area-pointer value
))))))
2579 ;;; The method for setting and accessing COMPILED-DEBUG-VAR values use
2580 ;;; this to determine if the value stored is the actual value or an
2581 ;;; indirection cell.
2582 (defun indirect-value-cell-p (x)
2583 (and (= (lowtag-of x
) sb
!vm
:other-pointer-lowtag
)
2584 (= (widetag-of x
) sb
!vm
:value-cell-header-widetag
)))
2586 ;;; Return three values reflecting the validity of DEBUG-VAR's value
2587 ;;; at BASIC-CODE-LOCATION:
2588 ;;; :VALID The value is known to be available.
2589 ;;; :INVALID The value is known to be unavailable.
2590 ;;; :UNKNOWN The value's availability is unknown.
2592 ;;; If the variable is always alive, then it is valid. If the
2593 ;;; code-location is unknown, then the variable's validity is
2594 ;;; :unknown. Once we've called CODE-LOCATION-UNKNOWN-P, we know the
2595 ;;; live-set information has been cached in the code-location.
2596 (defun debug-var-validity (debug-var basic-code-location
)
2597 (etypecase debug-var
2599 (compiled-debug-var-validity debug-var basic-code-location
))
2600 ;; (There used to be more cases back before sbcl-0.7.0, when
2601 ;; we did special tricks to debug the IR1 interpreter.)
2604 ;;; This is the method for DEBUG-VAR-VALIDITY for COMPILED-DEBUG-VARs.
2605 ;;; For safety, make sure basic-code-location is what we think.
2606 (defun compiled-debug-var-validity (debug-var basic-code-location
)
2607 (declare (type compiled-code-location basic-code-location
))
2608 (cond ((debug-var-alive-p debug-var
)
2609 (let ((debug-fun (code-location-debug-fun basic-code-location
)))
2610 (if (>= (compiled-code-location-pc basic-code-location
)
2611 (sb!c
::compiled-debug-fun-start-pc
2612 (compiled-debug-fun-compiler-debug-fun debug-fun
)))
2615 ((code-location-unknown-p basic-code-location
) :unknown
)
2617 (let ((pos (position debug-var
2618 (debug-fun-debug-vars
2619 (code-location-debug-fun
2620 basic-code-location
)))))
2622 (error 'unknown-debug-var
2623 :debug-var debug-var
2625 (code-location-debug-fun basic-code-location
)))
2626 ;; There must be live-set info since basic-code-location is known.
2627 (if (zerop (sbit (compiled-code-location-live-set
2628 basic-code-location
)
2635 ;;; This code produces and uses what we call source-paths. A
2636 ;;; source-path is a list whose first element is a form number as
2637 ;;; returned by CODE-LOCATION-FORM-NUMBER and whose last element is a
2638 ;;; top level form number as returned by
2639 ;;; CODE-LOCATION-TOPLEVEL-FORM-NUMBER. The elements from the last to
2640 ;;; the first, exclusively, are the numbered subforms into which to
2641 ;;; descend. For example:
2643 ;;; (let ((a (aref x 3)))
2645 ;;; The call to AREF in this example is form number 5. Assuming this
2646 ;;; DEFUN is the 11'th top level form, the source-path for the AREF
2647 ;;; call is as follows:
2649 ;;; Given the DEFUN, 3 gets you the LET, 1 gets you the bindings, 0
2650 ;;; gets the first binding, and 1 gets the AREF form.
2652 ;;; This returns a table mapping form numbers to source-paths. A
2653 ;;; source-path indicates a descent into the TOPLEVEL-FORM form,
2654 ;;; going directly to the subform corressponding to the form number.
2656 ;;; The vector elements are in the same format as the compiler's
2657 ;;; NODE-SOURCE-PATH; that is, the first element is the form number and
2658 ;;; the last is the TOPLEVEL-FORM number.
2659 (defun form-number-translations (form tlf-number
)
2661 (translations (make-array 12 :fill-pointer
0 :adjustable t
)))
2662 (labels ((translate1 (form path
)
2663 (unless (member form seen
)
2665 (vector-push-extend (cons (fill-pointer translations
) path
)
2670 (declare (fixnum pos
))
2673 (when (atom subform
) (return))
2674 (let ((fm (car subform
)))
2676 (translate1 fm
(cons pos path
)))
2678 (setq subform
(cdr subform
))
2679 (when (eq subform trail
) (return)))))
2683 (setq trail
(cdr trail
))))))))
2684 (translate1 form
(list tlf-number
)))
2685 (coerce translations
'simple-vector
)))
2687 ;;; FORM is a top level form, and path is a source-path into it. This
2688 ;;; returns the form indicated by the source-path. Context is the
2689 ;;; number of enclosing forms to return instead of directly returning
2690 ;;; the source-path form. When context is non-zero, the form returned
2691 ;;; contains a marker, #:****HERE****, immediately before the form
2692 ;;; indicated by path.
2693 (defun source-path-context (form path context
)
2694 (declare (type unsigned-byte context
))
2695 ;; Get to the form indicated by path or the enclosing form indicated
2696 ;; by context and path.
2697 (let ((path (reverse (butlast (cdr path
)))))
2698 (dotimes (i (- (length path
) context
))
2699 (let ((index (first path
)))
2700 (unless (and (listp form
) (< index
(length form
)))
2701 (error "Source path no longer exists."))
2702 (setq form
(elt form index
))
2703 (setq path
(rest path
))))
2704 ;; Recursively rebuild the source form resulting from the above
2705 ;; descent, copying the beginning of each subform up to the next
2706 ;; subform we descend into according to path. At the bottom of the
2707 ;; recursion, we return the form indicated by path preceded by our
2708 ;; marker, and this gets spliced into the resulting list structure
2709 ;; on the way back up.
2710 (labels ((frob (form path level
)
2711 (if (or (zerop level
) (null path
))
2714 `(#:***here
*** ,form
))
2715 (let ((n (first path
)))
2716 (unless (and (listp form
) (< n
(length form
)))
2717 (error "Source path no longer exists."))
2718 (let ((res (frob (elt form n
) (rest path
) (1- level
))))
2719 (nconc (subseq form
0 n
)
2720 (cons res
(nthcdr (1+ n
) form
))))))))
2721 (frob form path context
))))
2723 ;;;; PREPROCESS-FOR-EVAL
2725 ;;; Return a function of one argument that evaluates form in the
2726 ;;; lexical context of the BASIC-CODE-LOCATION LOC, or signal a
2727 ;;; NO-DEBUG-VARS condition when the LOC's DEBUG-FUN has no
2728 ;;; DEBUG-VAR information available.
2730 ;;; The returned function takes the frame to get values from as its
2731 ;;; argument, and it returns the values of FORM. The returned function
2732 ;;; can signal the following conditions: INVALID-VALUE,
2733 ;;; AMBIGUOUS-VAR-NAME, and FRAME-FUN-MISMATCH.
2734 (defun preprocess-for-eval (form loc
)
2735 (declare (type code-location loc
))
2736 (let ((n-frame (gensym))
2737 (fun (code-location-debug-fun loc
)))
2738 (unless (debug-var-info-available fun
)
2739 (debug-signal 'no-debug-vars
:debug-fun fun
))
2740 (sb!int
:collect
((binds)
2742 (do-debug-fun-vars (var fun
)
2743 (let ((validity (debug-var-validity var loc
)))
2744 (unless (eq validity
:invalid
)
2745 (let* ((sym (debug-var-symbol var
))
2746 (found (assoc sym
(binds))))
2748 (setf (second found
) :ambiguous
)
2749 (binds (list sym validity var
)))))))
2750 (dolist (bind (binds))
2751 (let ((name (first bind
))
2753 (ecase (second bind
)
2755 (specs `(,name
(debug-var-value ',var
,n-frame
))))
2757 (specs `(,name
(debug-signal 'invalid-value
2761 (specs `(,name
(debug-signal 'ambiguous-var-name
2763 :frame
,n-frame
)))))))
2764 (let ((res (coerce `(lambda (,n-frame
)
2765 (declare (ignorable ,n-frame
))
2766 (symbol-macrolet ,(specs) ,form
))
2769 ;; This prevents these functions from being used in any
2770 ;; location other than a function return location, so maybe
2771 ;; this should only check whether FRAME's DEBUG-FUN is the
2773 (unless (code-location= (frame-code-location frame
) loc
)
2774 (debug-signal 'frame-fun-mismatch
2775 :code-location loc
:form form
:frame frame
))
2776 (funcall res frame
))))))
2780 ;;;; user-visible interface
2782 ;;; Create and return a breakpoint. When program execution encounters
2783 ;;; the breakpoint, the system calls HOOK-FUN. HOOK-FUN takes the
2784 ;;; current frame for the function in which the program is running and
2785 ;;; the breakpoint object.
2787 ;;; WHAT and KIND determine where in a function the system invokes
2788 ;;; HOOK-FUN. WHAT is either a code-location or a DEBUG-FUN. KIND is
2789 ;;; one of :CODE-LOCATION, :FUN-START, or :FUN-END. Since the starts
2790 ;;; and ends of functions may not have code-locations representing
2791 ;;; them, designate these places by supplying WHAT as a DEBUG-FUN and
2792 ;;; KIND indicating the :FUN-START or :FUN-END. When WHAT is a
2793 ;;; DEBUG-FUN and kind is :FUN-END, then HOOK-FUN must take two
2794 ;;; additional arguments, a list of values returned by the function
2795 ;;; and a FUN-END-COOKIE.
2797 ;;; INFO is information supplied by and used by the user.
2799 ;;; FUN-END-COOKIE is a function. To implement :FUN-END
2800 ;;; breakpoints, the system uses starter breakpoints to establish the
2801 ;;; :FUN-END breakpoint for each invocation of the function. Upon
2802 ;;; each entry, the system creates a unique cookie to identify the
2803 ;;; invocation, and when the user supplies a function for this
2804 ;;; argument, the system invokes it on the frame and the cookie. The
2805 ;;; system later invokes the :FUN-END breakpoint hook on the same
2806 ;;; cookie. The user may save the cookie for comparison in the hook
2809 ;;; Signal an error if WHAT is an unknown code-location.
2810 (defun make-breakpoint (hook-fun what
2811 &key
(kind :code-location
) info fun-end-cookie
)
2814 (when (code-location-unknown-p what
)
2815 (error "cannot make a breakpoint at an unknown code location: ~S"
2817 (aver (eq kind
:code-location
))
2818 (let ((bpt (%make-breakpoint hook-fun what kind info
)))
2820 (compiled-code-location
2821 ;; This slot is filled in due to calling CODE-LOCATION-UNKNOWN-P.
2822 (when (eq (compiled-code-location-kind what
) :unknown-return
)
2823 (let ((other-bpt (%make-breakpoint hook-fun what
2824 :unknown-return-partner
2826 (setf (breakpoint-unknown-return-partner bpt
) other-bpt
)
2827 (setf (breakpoint-unknown-return-partner other-bpt
) bpt
))))
2828 ;; (There used to be more cases back before sbcl-0.7.0,,
2829 ;; when we did special tricks to debug the IR1
2836 (%make-breakpoint hook-fun what kind info
))
2838 (unless (eq (sb!c
::compiled-debug-fun-returns
2839 (compiled-debug-fun-compiler-debug-fun what
))
2841 (error ":FUN-END breakpoints are currently unsupported ~
2842 for the known return convention."))
2844 (let* ((bpt (%make-breakpoint hook-fun what kind info
))
2845 (starter (compiled-debug-fun-end-starter what
)))
2847 (setf starter
(%make-breakpoint
#'list what
:fun-start nil
))
2848 (setf (breakpoint-hook-fun starter
)
2849 (fun-end-starter-hook starter what
))
2850 (setf (compiled-debug-fun-end-starter what
) starter
))
2851 (setf (breakpoint-start-helper bpt
) starter
)
2852 (push bpt
(breakpoint-%info starter
))
2853 (setf (breakpoint-cookie-fun bpt
) fun-end-cookie
)
2856 ;;; These are unique objects created upon entry into a function by a
2857 ;;; :FUN-END breakpoint's starter hook. These are only created
2858 ;;; when users supply :FUN-END-COOKIE to MAKE-BREAKPOINT. Also,
2859 ;;; the :FUN-END breakpoint's hook is called on the same cookie
2860 ;;; when it is created.
2861 (defstruct (fun-end-cookie
2862 (:print-object
(lambda (obj str
)
2863 (print-unreadable-object (obj str
:type t
))))
2864 (:constructor make-fun-end-cookie
(bogus-lra debug-fun
))
2866 ;; a pointer to the bogus-lra created for :FUN-END breakpoints
2868 ;; the DEBUG-FUN associated with this cookie
2871 ;;; This maps bogus-lra-components to cookies, so that
2872 ;;; HANDLE-FUN-END-BREAKPOINT can find the appropriate cookie for the
2873 ;;; breakpoint hook.
2874 (defvar *fun-end-cookies
* (make-hash-table :test
'eq
:synchronized t
))
2876 ;;; This returns a hook function for the start helper breakpoint
2877 ;;; associated with a :FUN-END breakpoint. The returned function
2878 ;;; makes a fake LRA that all returns go through, and this piece of
2879 ;;; fake code actually breaks. Upon return from the break, the code
2880 ;;; provides the returnee with any values. Since the returned function
2881 ;;; effectively activates FUN-END-BPT on each entry to DEBUG-FUN's
2882 ;;; function, we must establish breakpoint-data about FUN-END-BPT.
2883 (defun fun-end-starter-hook (starter-bpt debug-fun
)
2884 (declare (type breakpoint starter-bpt
)
2885 (type compiled-debug-fun debug-fun
))
2886 (lambda (frame breakpoint
)
2887 (declare (ignore breakpoint
)
2889 (let ((lra-sc-offset
2890 (sb!c
::compiled-debug-fun-return-pc
2891 (compiled-debug-fun-compiler-debug-fun debug-fun
))))
2892 (multiple-value-bind (lra component offset
)
2894 (get-context-value frame
2897 (setf (get-context-value frame
2901 (let ((end-bpts (breakpoint-%info starter-bpt
)))
2902 (let ((data (breakpoint-data component offset
)))
2903 (setf (breakpoint-data-breakpoints data
) end-bpts
)
2904 (dolist (bpt end-bpts
)
2905 (setf (breakpoint-internal-data bpt
) data
)))
2906 (let ((cookie (make-fun-end-cookie lra debug-fun
)))
2907 (setf (gethash component
*fun-end-cookies
*) cookie
)
2908 (dolist (bpt end-bpts
)
2909 (let ((fun (breakpoint-cookie-fun bpt
)))
2910 (when fun
(funcall fun frame cookie
))))))))))
2912 ;;; This takes a FUN-END-COOKIE and a frame, and it returns
2913 ;;; whether the cookie is still valid. A cookie becomes invalid when
2914 ;;; the frame that established the cookie has exited. Sometimes cookie
2915 ;;; holders are unaware of cookie invalidation because their
2916 ;;; :FUN-END breakpoint hooks didn't run due to THROW'ing.
2918 ;;; This takes a frame as an efficiency hack since the user probably
2919 ;;; has a frame object in hand when using this routine, and it saves
2920 ;;; repeated parsing of the stack and consing when asking whether a
2921 ;;; series of cookies is valid.
2922 (defun fun-end-cookie-valid-p (frame cookie
)
2923 (let ((lra (fun-end-cookie-bogus-lra cookie
))
2924 (lra-sc-offset (sb!c
::compiled-debug-fun-return-pc
2925 (compiled-debug-fun-compiler-debug-fun
2926 (fun-end-cookie-debug-fun cookie
)))))
2927 (do ((frame frame
(frame-down frame
)))
2929 (when (and (compiled-frame-p frame
)
2930 (#!-
(or x86 x86-64
) eq
#!+(or x86 x86-64
) sap
=
2932 (get-context-value frame lra-save-offset lra-sc-offset
)))
2935 ;;;; ACTIVATE-BREAKPOINT
2937 ;;; Cause the system to invoke the breakpoint's hook function until
2938 ;;; the next call to DEACTIVATE-BREAKPOINT or DELETE-BREAKPOINT. The
2939 ;;; system invokes breakpoint hook functions in the opposite order
2940 ;;; that you activate them.
2941 (defun activate-breakpoint (breakpoint)
2942 (when (eq (breakpoint-status breakpoint
) :deleted
)
2943 (error "cannot activate a deleted breakpoint: ~S" breakpoint
))
2944 (unless (eq (breakpoint-status breakpoint
) :active
)
2945 (ecase (breakpoint-kind breakpoint
)
2947 (let ((loc (breakpoint-what breakpoint
)))
2949 (compiled-code-location
2950 (activate-compiled-code-location-breakpoint breakpoint
)
2951 (let ((other (breakpoint-unknown-return-partner breakpoint
)))
2953 (activate-compiled-code-location-breakpoint other
))))
2954 ;; (There used to be more cases back before sbcl-0.7.0, when
2955 ;; we did special tricks to debug the IR1 interpreter.)
2958 (etypecase (breakpoint-what breakpoint
)
2960 (activate-compiled-fun-start-breakpoint breakpoint
))
2961 ;; (There used to be more cases back before sbcl-0.7.0, when
2962 ;; we did special tricks to debug the IR1 interpreter.)
2965 (etypecase (breakpoint-what breakpoint
)
2967 (let ((starter (breakpoint-start-helper breakpoint
)))
2968 (unless (eq (breakpoint-status starter
) :active
)
2969 ;; may already be active by some other :FUN-END breakpoint
2970 (activate-compiled-fun-start-breakpoint starter
)))
2971 (setf (breakpoint-status breakpoint
) :active
))
2972 ;; (There used to be more cases back before sbcl-0.7.0, when
2973 ;; we did special tricks to debug the IR1 interpreter.)
2977 (defun activate-compiled-code-location-breakpoint (breakpoint)
2978 (declare (type breakpoint breakpoint
))
2979 (let ((loc (breakpoint-what breakpoint
)))
2980 (declare (type compiled-code-location loc
))
2981 (sub-activate-breakpoint
2983 (breakpoint-data (compiled-debug-fun-component
2984 (code-location-debug-fun loc
))
2985 (+ (compiled-code-location-pc loc
)
2986 (if (or (eq (breakpoint-kind breakpoint
)
2987 :unknown-return-partner
)
2988 (eq (compiled-code-location-kind loc
)
2989 :single-value-return
))
2990 sb
!vm
:single-value-return-byte-offset
2993 (defun activate-compiled-fun-start-breakpoint (breakpoint)
2994 (declare (type breakpoint breakpoint
))
2995 (let ((debug-fun (breakpoint-what breakpoint
)))
2996 (sub-activate-breakpoint
2998 (breakpoint-data (compiled-debug-fun-component debug-fun
)
2999 (sb!c
::compiled-debug-fun-start-pc
3000 (compiled-debug-fun-compiler-debug-fun
3003 (defun sub-activate-breakpoint (breakpoint data
)
3004 (declare (type breakpoint breakpoint
)
3005 (type breakpoint-data data
))
3006 (setf (breakpoint-status breakpoint
) :active
)
3008 (unless (breakpoint-data-breakpoints data
)
3009 (setf (breakpoint-data-instruction data
)
3011 (breakpoint-install (get-lisp-obj-address
3012 (breakpoint-data-component data
))
3013 (breakpoint-data-offset data
)))))
3014 (setf (breakpoint-data-breakpoints data
)
3015 (append (breakpoint-data-breakpoints data
) (list breakpoint
)))
3016 (setf (breakpoint-internal-data breakpoint
) data
)))
3018 ;;;; DEACTIVATE-BREAKPOINT
3020 ;;; Stop the system from invoking the breakpoint's hook function.
3021 (defun deactivate-breakpoint (breakpoint)
3022 (when (eq (breakpoint-status breakpoint
) :active
)
3024 (let ((loc (breakpoint-what breakpoint
)))
3026 ((or compiled-code-location compiled-debug-fun
)
3027 (deactivate-compiled-breakpoint breakpoint
)
3028 (let ((other (breakpoint-unknown-return-partner breakpoint
)))
3030 (deactivate-compiled-breakpoint other
))))
3031 ;; (There used to be more cases back before sbcl-0.7.0, when
3032 ;; we did special tricks to debug the IR1 interpreter.)
3036 (defun deactivate-compiled-breakpoint (breakpoint)
3037 (if (eq (breakpoint-kind breakpoint
) :fun-end
)
3038 (let ((starter (breakpoint-start-helper breakpoint
)))
3039 (unless (find-if (lambda (bpt)
3040 (and (not (eq bpt breakpoint
))
3041 (eq (breakpoint-status bpt
) :active
)))
3042 (breakpoint-%info starter
))
3043 (deactivate-compiled-breakpoint starter
)))
3044 (let* ((data (breakpoint-internal-data breakpoint
))
3045 (bpts (delete breakpoint
(breakpoint-data-breakpoints data
))))
3046 (setf (breakpoint-internal-data breakpoint
) nil
)
3047 (setf (breakpoint-data-breakpoints data
) bpts
)
3050 (breakpoint-remove (get-lisp-obj-address
3051 (breakpoint-data-component data
))
3052 (breakpoint-data-offset data
)
3053 (breakpoint-data-instruction data
)))
3054 (delete-breakpoint-data data
))))
3055 (setf (breakpoint-status breakpoint
) :inactive
)
3058 ;;;; BREAKPOINT-INFO
3060 ;;; Return the user-maintained info associated with breakpoint. This
3062 (defun breakpoint-info (breakpoint)
3063 (breakpoint-%info breakpoint
))
3064 (defun %set-breakpoint-info
(breakpoint value
)
3065 (setf (breakpoint-%info breakpoint
) value
)
3066 (let ((other (breakpoint-unknown-return-partner breakpoint
)))
3068 (setf (breakpoint-%info other
) value
))))
3070 ;;;; BREAKPOINT-ACTIVE-P and DELETE-BREAKPOINT
3072 (defun breakpoint-active-p (breakpoint)
3073 (ecase (breakpoint-status breakpoint
)
3075 ((:inactive
:deleted
) nil
)))
3077 ;;; Free system storage and remove computational overhead associated
3078 ;;; with breakpoint. After calling this, breakpoint is completely
3079 ;;; impotent and can never become active again.
3080 (defun delete-breakpoint (breakpoint)
3081 (let ((status (breakpoint-status breakpoint
)))
3082 (unless (eq status
:deleted
)
3083 (when (eq status
:active
)
3084 (deactivate-breakpoint breakpoint
))
3085 (setf (breakpoint-status breakpoint
) :deleted
)
3086 (let ((other (breakpoint-unknown-return-partner breakpoint
)))
3088 (setf (breakpoint-status other
) :deleted
)))
3089 (when (eq (breakpoint-kind breakpoint
) :fun-end
)
3090 (let* ((starter (breakpoint-start-helper breakpoint
))
3091 (breakpoints (delete breakpoint
3092 (the list
(breakpoint-info starter
)))))
3093 (setf (breakpoint-info starter
) breakpoints
)
3095 (delete-breakpoint starter
)
3096 (setf (compiled-debug-fun-end-starter
3097 (breakpoint-what breakpoint
))
3101 ;;;; C call out stubs
3103 ;;; This actually installs the break instruction in the component. It
3104 ;;; returns the overwritten bits. You must call this in a context in
3105 ;;; which GC is disabled, so that Lisp doesn't move objects around
3106 ;;; that C is pointing to.
3107 (sb!alien
:define-alien-routine
"breakpoint_install" sb
!alien
:unsigned-int
3108 (code-obj sb
!alien
:unsigned-long
)
3109 (pc-offset sb
!alien
:int
))
3111 ;;; This removes the break instruction and replaces the original
3112 ;;; instruction. You must call this in a context in which GC is disabled
3113 ;;; so Lisp doesn't move objects around that C is pointing to.
3114 (sb!alien
:define-alien-routine
"breakpoint_remove" sb
!alien
:void
3115 (code-obj sb
!alien
:unsigned-long
)
3116 (pc-offset sb
!alien
:int
)
3117 (old-inst sb
!alien
:unsigned-int
))
3119 (sb!alien
:define-alien-routine
"breakpoint_do_displaced_inst" sb
!alien
:void
3120 (scp (* os-context-t
))
3121 (orig-inst sb
!alien
:unsigned-int
))
3123 ;;;; breakpoint handlers (layer between C and exported interface)
3125 ;;; This maps components to a mapping of offsets to BREAKPOINT-DATAs.
3126 (defvar *component-breakpoint-offsets
* (make-hash-table :test
'eq
:synchronized t
))
3128 ;;; This returns the BREAKPOINT-DATA object associated with component cross
3129 ;;; offset. If none exists, this makes one, installs it, and returns it.
3130 (defun breakpoint-data (component offset
&optional
(create t
))
3131 (flet ((install-breakpoint-data ()
3133 (let ((data (make-breakpoint-data component offset
)))
3134 (push (cons offset data
)
3135 (gethash component
*component-breakpoint-offsets
*))
3137 (let ((offsets (gethash component
*component-breakpoint-offsets
*)))
3139 (let ((data (assoc offset offsets
)))
3142 (install-breakpoint-data)))
3143 (install-breakpoint-data)))))
3145 ;;; We use this when there are no longer any active breakpoints
3146 ;;; corresponding to DATA.
3147 (defun delete-breakpoint-data (data)
3148 ;; Again, this looks brittle. Is there no danger of being interrupted
3150 (let* ((component (breakpoint-data-component data
))
3151 (offsets (delete (breakpoint-data-offset data
)
3152 (gethash component
*component-breakpoint-offsets
*)
3155 (setf (gethash component
*component-breakpoint-offsets
*) offsets
)
3156 (remhash component
*component-breakpoint-offsets
*)))
3159 ;;; The C handler for interrupts calls this when it has a
3160 ;;; debugging-tool break instruction. This does *not* handle all
3161 ;;; breaks; for example, it does not handle breaks for internal
3163 (defun handle-breakpoint (offset component signal-context
)
3164 (let ((data (breakpoint-data component offset nil
)))
3166 (error "unknown breakpoint in ~S at offset ~S"
3167 (debug-fun-name (debug-fun-from-pc component offset
))
3169 (let ((breakpoints (breakpoint-data-breakpoints data
)))
3170 (if (or (null breakpoints
)
3171 (eq (breakpoint-kind (car breakpoints
)) :fun-end
))
3172 (handle-fun-end-breakpoint-aux breakpoints data signal-context
)
3173 (handle-breakpoint-aux breakpoints data
3174 offset component signal-context
)))))
3176 ;;; This holds breakpoint-datas while invoking the breakpoint hooks
3177 ;;; associated with that particular component and location. While they
3178 ;;; are executing, if we hit the location again, we ignore the
3179 ;;; breakpoint to avoid infinite recursion. fun-end breakpoints
3180 ;;; must work differently since the breakpoint-data is unique for each
3182 (defvar *executing-breakpoint-hooks
* nil
)
3184 ;;; This handles code-location and DEBUG-FUN :FUN-START
3186 (defun handle-breakpoint-aux (breakpoints data offset component signal-context
)
3188 (bug "breakpoint that nobody wants"))
3189 (unless (member data
*executing-breakpoint-hooks
*)
3190 (let ((*executing-breakpoint-hooks
* (cons data
3191 *executing-breakpoint-hooks
*)))
3192 (invoke-breakpoint-hooks breakpoints signal-context
)))
3193 ;; At this point breakpoints may not hold the same list as
3194 ;; BREAKPOINT-DATA-BREAKPOINTS since invoking hooks may have allowed
3195 ;; a breakpoint deactivation. In fact, if all breakpoints were
3196 ;; deactivated then data is invalid since it was deleted and so the
3197 ;; correct one must be looked up if it is to be used. If there are
3198 ;; no more breakpoints active at this location, then the normal
3199 ;; instruction has been put back, and we do not need to
3200 ;; DO-DISPLACED-INST.
3201 (setf data
(breakpoint-data component offset nil
))
3202 (when (and data
(breakpoint-data-breakpoints data
))
3203 ;; The breakpoint is still active, so we need to execute the
3204 ;; displaced instruction and leave the breakpoint instruction
3205 ;; behind. The best way to do this is different on each machine,
3206 ;; so we just leave it up to the C code.
3207 (breakpoint-do-displaced-inst signal-context
3208 (breakpoint-data-instruction data
))
3209 ;; Some platforms have no usable sigreturn() call. If your
3210 ;; implementation of arch_do_displaced_inst() _does_ sigreturn(),
3211 ;; it's polite to warn here
3212 #!+(and sparc solaris
)
3213 (error "BREAKPOINT-DO-DISPLACED-INST returned?")))
3215 (defun invoke-breakpoint-hooks (breakpoints signal-context
)
3216 (let* ((frame (signal-context-frame signal-context
)))
3217 (dolist (bpt breakpoints
)
3218 (funcall (breakpoint-hook-fun bpt
)
3220 ;; If this is an :UNKNOWN-RETURN-PARTNER, then pass the
3221 ;; hook function the original breakpoint, so that users
3222 ;; aren't forced to confront the fact that some
3223 ;; breakpoints really are two.
3224 (if (eq (breakpoint-kind bpt
) :unknown-return-partner
)
3225 (breakpoint-unknown-return-partner bpt
)
3228 (defun signal-context-frame (signal-context)
3231 (declare (optimize (inhibit-warnings 3)))
3232 (sb!alien
:sap-alien signal-context
(* os-context-t
))))
3233 (cfp (int-sap (sb!vm
:context-register scp sb
!vm
::cfp-offset
))))
3234 (compute-calling-frame cfp
3235 (sb!vm
:context-pc scp
)
3238 (defun handle-fun-end-breakpoint (offset component context
)
3239 (let ((data (breakpoint-data component offset nil
)))
3241 (error "unknown breakpoint in ~S at offset ~S"
3242 (debug-fun-name (debug-fun-from-pc component offset
))
3244 (let ((breakpoints (breakpoint-data-breakpoints data
)))
3246 (aver (eq (breakpoint-kind (car breakpoints
)) :fun-end
))
3247 (handle-fun-end-breakpoint-aux breakpoints data context
)))))
3249 ;;; Either HANDLE-BREAKPOINT calls this for :FUN-END breakpoints
3250 ;;; [old C code] or HANDLE-FUN-END-BREAKPOINT calls this directly
3252 (defun handle-fun-end-breakpoint-aux (breakpoints data signal-context
)
3253 ;; FIXME: This looks brittle: what if we are interrupted somewhere
3254 ;; here? ...or do we have interrupts disabled here?
3255 (delete-breakpoint-data data
)
3258 (declare (optimize (inhibit-warnings 3)))
3259 (sb!alien
:sap-alien signal-context
(* os-context-t
))))
3260 (frame (signal-context-frame signal-context
))
3261 (component (breakpoint-data-component data
))
3262 (cookie (gethash component
*fun-end-cookies
*)))
3263 (remhash component
*fun-end-cookies
*)
3264 (dolist (bpt breakpoints
)
3265 (funcall (breakpoint-hook-fun bpt
)
3267 (get-fun-end-breakpoint-values scp
)
3270 (defun get-fun-end-breakpoint-values (scp)
3271 (let ((ocfp (int-sap (sb!vm
:context-register
3273 #!-
(or x86 x86-64
) sb
!vm
::ocfp-offset
3274 #!+(or x86 x86-64
) sb
!vm
::ebx-offset
)))
3275 (nargs (make-lisp-obj
3276 (sb!vm
:context-register scp sb
!vm
::nargs-offset
)))
3277 (reg-arg-offsets '#.sb
!vm
::*register-arg-offsets
*)
3280 (dotimes (arg-num nargs
)
3281 (push (if reg-arg-offsets
3283 (sb!vm
:context-register scp
(pop reg-arg-offsets
)))
3284 (stack-ref ocfp arg-num
))
3286 (nreverse results
)))
3288 ;;;; MAKE-BOGUS-LRA (used for :FUN-END breakpoints)
3290 (defconstant bogus-lra-constants
3291 #!-
(or x86 x86-64
) 2 #!+(or x86 x86-64
) 3)
3292 (defconstant known-return-p-slot
3293 (+ sb
!vm
:code-constants-offset
#!-
(or x86 x86-64
) 1 #!+(or x86 x86-64
) 2))
3295 ;;; Make a bogus LRA object that signals a breakpoint trap when
3296 ;;; returned to. If the breakpoint trap handler returns, REAL-LRA is
3297 ;;; returned to. Three values are returned: the bogus LRA object, the
3298 ;;; code component it is part of, and the PC offset for the trap
3300 (defun make-bogus-lra (real-lra &optional known-return-p
)
3302 ;; These are really code labels, not variables: but this way we get
3304 (let* ((src-start (foreign-symbol-sap "fun_end_breakpoint_guts"))
3305 (src-end (foreign-symbol-sap "fun_end_breakpoint_end"))
3306 (trap-loc (foreign-symbol-sap "fun_end_breakpoint_trap"))
3307 (length (sap- src-end src-start
))
3309 (%primitive sb
!c
:allocate-code-object
(1+ bogus-lra-constants
)
3311 (dst-start (code-instructions code-object
)))
3312 (declare (type system-area-pointer
3313 src-start src-end dst-start trap-loc
)
3314 (type index length
))
3315 (setf (%code-debug-info code-object
) :bogus-lra
)
3316 (setf (code-header-ref code-object sb
!vm
:code-trace-table-offset-slot
)
3319 (setf (code-header-ref code-object real-lra-slot
) real-lra
)
3321 (multiple-value-bind (offset code
) (compute-lra-data-from-pc real-lra
)
3322 (setf (code-header-ref code-object real-lra-slot
) code
)
3323 (setf (code-header-ref code-object
(1+ real-lra-slot
)) offset
))
3324 (setf (code-header-ref code-object known-return-p-slot
)
3326 (system-area-ub8-copy src-start
0 dst-start
0 length
)
3327 (sb!vm
:sanctify-for-execution code-object
)
3329 (values dst-start code-object
(sap- trap-loc src-start
))
3331 (let ((new-lra (make-lisp-obj (+ (sap-int dst-start
)
3332 sb
!vm
:other-pointer-lowtag
))))
3335 (logandc2 (+ sb
!vm
:code-constants-offset bogus-lra-constants
1)
3337 (sb!vm
:sanctify-for-execution code-object
)
3338 (values new-lra code-object
(sap- trap-loc src-start
))))))
3342 ;;; This appears here because it cannot go with the DEBUG-FUN
3343 ;;; interface since DO-DEBUG-BLOCK-LOCATIONS isn't defined until after
3344 ;;; the DEBUG-FUN routines.
3346 ;;; Return a code-location before the body of a function and after all
3347 ;;; the arguments are in place; or if that location can't be
3348 ;;; determined due to a lack of debug information, return NIL.
3349 (defun debug-fun-start-location (debug-fun)
3350 (etypecase debug-fun
3352 (code-location-from-pc debug-fun
3353 (sb!c
::compiled-debug-fun-start-pc
3354 (compiled-debug-fun-compiler-debug-fun
3357 ;; (There used to be more cases back before sbcl-0.7.0, when
3358 ;; we did special tricks to debug the IR1 interpreter.)
3362 ;;;; Single-stepping
3364 ;;; The single-stepper works by inserting conditional trap instructions
3365 ;;; into the generated code (see src/compiler/*/call.lisp), currently:
3367 ;;; 1) Before the code generated for a function call that was
3368 ;;; translated to a VOP
3369 ;;; 2) Just before the call instruction for a full call
3371 ;;; In both cases, the trap will only be executed if stepping has been
3372 ;;; enabled, in which case it'll ultimately be handled by
3373 ;;; HANDLE-SINGLE-STEP-TRAP, which will either signal a stepping condition,
3374 ;;; or replace the function that's about to be called with a wrapper
3375 ;;; which will signal the condition.
3377 (defun handle-single-step-trap (kind callee-register-offset
)
3378 (let ((context (nth-interrupt-context (1- *free-interrupt-context-index
*))))
3379 ;; The following calls must get tail-call eliminated for
3380 ;; *STEP-FRAME* to get set correctly on non-x86.
3381 (if (= kind single-step-before-trap
)
3382 (handle-single-step-before-trap context
)
3383 (handle-single-step-around-trap context callee-register-offset
))))
3385 (defvar *step-frame
* nil
)
3387 (defun handle-single-step-before-trap (context)
3388 (let ((step-info (single-step-info-from-context context
)))
3389 ;; If there was not enough debug information available, there's no
3390 ;; sense in signaling the condition.
3394 (signal-context-frame (sb!alien
::alien-sap context
))
3396 ;; KLUDGE: Use the first non-foreign frame as the
3397 ;; *STACK-TOP-HINT*. Getting the frame from the signal
3398 ;; context as on x86 would be cleaner, but
3399 ;; SIGNAL-CONTEXT-FRAME doesn't seem seem to work at all
3401 (loop with frame
= (frame-down (top-frame))
3403 for dfun
= (frame-debug-fun frame
)
3404 do
(when (typep dfun
'compiled-debug-fun
)
3406 do
(setf frame
(frame-down frame
)))))
3407 (sb!impl
::step-form step-info
3408 ;; We could theoretically store information in
3409 ;; the debug-info about to determine the
3410 ;; arguments here, but for now let's just pass
3414 ;;; This function will replace the fdefn / function that was in the
3415 ;;; register at CALLEE-REGISTER-OFFSET with a wrapper function. To
3416 ;;; ensure that the full call will use the wrapper instead of the
3417 ;;; original, conditional trap must be emitted before the fdefn /
3418 ;;; function is converted into a raw address.
3419 (defun handle-single-step-around-trap (context callee-register-offset
)
3420 ;; Fetch the function / fdefn we're about to call from the
3421 ;; appropriate register.
3422 (let* ((callee (make-lisp-obj
3423 (context-register context callee-register-offset
)))
3424 (step-info (single-step-info-from-context context
)))
3425 ;; If there was not enough debug information available, there's no
3426 ;; sense in signaling the condition.
3428 (return-from handle-single-step-around-trap
))
3429 (let* ((fun (lambda (&rest args
)
3431 (apply (typecase callee
3432 (fdefn (fdefn-fun callee
))
3435 ;; Signal a step condition
3437 (let ((*step-frame
* (frame-down (top-frame))))
3438 (sb!impl
::step-form step-info args
))))
3439 ;; And proceed based on its return value.
3441 ;; STEP-INTO was selected. Use *STEP-OUT* to
3442 ;; let the stepper know that selecting the
3443 ;; STEP-OUT restart is valid inside this
3444 (let ((sb!impl
::*step-out
* :maybe
))
3445 ;; Pass the return values of the call to
3446 ;; STEP-VALUES, which will signal a
3447 ;; condition with them in the VALUES slot.
3449 (multiple-value-call #'sb
!impl
::step-values
3452 ;; If the user selected the STEP-OUT
3453 ;; restart during the call, resume
3455 (when (eq sb
!impl
::*step-out
* t
)
3456 (sb!impl
::enable-stepping
))))
3457 ;; STEP-NEXT / CONTINUE / OUT selected:
3458 ;; Disable the stepper for the duration of
3460 (sb!impl
::with-stepping-disabled
3462 (new-callee (etypecase callee
3464 (let ((fdefn (make-fdefn (gensym))))
3465 (setf (fdefn-fun fdefn
) fun
)
3468 ;; And then store the wrapper in the same place.
3469 (setf (context-register context callee-register-offset
)
3470 (get-lisp-obj-address new-callee
)))))
3472 ;;; Given a signal context, fetch the step-info that's been stored in
3473 ;;; the debug info at the trap point.
3474 (defun single-step-info-from-context (context)
3475 (multiple-value-bind (pc-offset code
)
3476 (compute-lra-data-from-pc (context-pc context
))
3477 (let* ((debug-fun (debug-fun-from-pc code pc-offset
))
3478 (location (code-location-from-pc debug-fun
3483 (fill-in-code-location location
)
3484 (code-location-debug-source location
)
3485 (compiled-code-location-step-info location
))
3489 ;;; Return the frame that triggered a single-step condition. Used to
3490 ;;; provide a *STACK-TOP-HINT*.
3491 (defun find-stepped-frame ()