1 ;;;; the implementation of the programmer's interface to writing
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
15 ;;; FIXME: There are an awful lot of package prefixes in this code.
16 ;;; Couldn't we have SB-DI use the SB-C and SB-VM packages?
20 ;;;; The interface to building debugging tools signals conditions that
21 ;;;; prevent it from adhering to its contract. These are
22 ;;;; serious-conditions because the program using the interface must
23 ;;;; handle them before it can correctly continue execution. These
24 ;;;; debugging conditions are not errors since it is no fault of the
25 ;;;; programmers that the conditions occur. The interface does not
26 ;;;; provide for programs to detect these situations other than
27 ;;;; calling a routine that detects them and signals a condition. For
28 ;;;; example, programmers call A which may fail to return successfully
29 ;;;; due to a lack of debug information, and there is no B the they
30 ;;;; could have called to realize A would fail. It is not an error to
31 ;;;; have called A, but it is an error for the program to then ignore
32 ;;;; the signal generated by A since it cannot continue without A's
33 ;;;; correctly returning a value or performing some operation.
35 ;;;; Use DEBUG-SIGNAL to signal these conditions.
37 (define-condition debug-condition (serious-condition)
41 "All DEBUG-CONDITIONs inherit from this type. These are serious conditions
42 that must be handled, but they are not programmer errors."))
44 (define-condition no-debug-info (debug-condition)
45 ((code-component :reader no-debug-info-code-component
46 :initarg :code-component))
48 (:documentation "There is no usable debugging information available.")
49 (:report (lambda (condition stream)
52 "no debug information available for ~S~%"
53 (no-debug-info-code-component condition)))))
55 (define-condition no-debug-function-returns (debug-condition)
56 ((debug-function :reader no-debug-function-returns-debug-function
57 :initarg :debug-function))
60 "The system could not return values from a frame with DEBUG-FUNCTION since
61 it lacked information about returning values.")
62 (:report (lambda (condition stream)
63 (let ((fun (debug-function-function
64 (no-debug-function-returns-debug-function condition))))
66 "~&Cannot return values from ~:[frame~;~:*~S~] since ~
67 the debug information lacks details about returning ~
71 (define-condition no-debug-blocks (debug-condition)
72 ((debug-function :reader no-debug-blocks-debug-function
73 :initarg :debug-function))
75 (:documentation "The debug-function has no debug-block information.")
76 (:report (lambda (condition stream)
77 (format stream "~&~S has no debug-block information."
78 (no-debug-blocks-debug-function condition)))))
80 (define-condition no-debug-vars (debug-condition)
81 ((debug-function :reader no-debug-vars-debug-function
82 :initarg :debug-function))
84 (:documentation "The debug-function has no DEBUG-VAR information.")
85 (:report (lambda (condition stream)
86 (format stream "~&~S has no debug variable information."
87 (no-debug-vars-debug-function condition)))))
89 (define-condition lambda-list-unavailable (debug-condition)
90 ((debug-function :reader lambda-list-unavailable-debug-function
91 :initarg :debug-function))
94 "The debug-function has no lambda-list since argument DEBUG-VARs are
96 (:report (lambda (condition stream)
97 (format stream "~&~S has no lambda-list information available."
98 (lambda-list-unavailable-debug-function condition)))))
100 (define-condition invalid-value (debug-condition)
101 ((debug-var :reader invalid-value-debug-var :initarg :debug-var)
102 (frame :reader invalid-value-frame :initarg :frame))
103 (:report (lambda (condition stream)
104 (format stream "~&~S has :invalid or :unknown value in ~S."
105 (invalid-value-debug-var condition)
106 (invalid-value-frame condition)))))
108 (define-condition ambiguous-variable-name (debug-condition)
109 ((name :reader ambiguous-variable-name-name :initarg :name)
110 (frame :reader ambiguous-variable-name-frame :initarg :frame))
111 (:report (lambda (condition stream)
112 (format stream "~&~S names more than one valid variable in ~S."
113 (ambiguous-variable-name-name condition)
114 (ambiguous-variable-name-frame condition)))))
116 ;;;; errors and DEBUG-SIGNAL
118 ;;; The debug-internals code tries to signal all programmer errors as
119 ;;; subtypes of DEBUG-ERROR. There are calls to ERROR signalling
120 ;;; SIMPLE-ERRORs, but these dummy checks in the code and shouldn't
123 ;;; While under development, this code also signals errors in code
124 ;;; branches that remain unimplemented.
126 (define-condition debug-error (error) ()
129 "All programmer errors from using the interface for building debugging
130 tools inherit from this type."))
132 (define-condition unhandled-debug-condition (debug-error)
133 ((condition :reader unhandled-debug-condition-condition :initarg :condition))
134 (:report (lambda (condition stream)
135 (format stream "~&unhandled DEBUG-CONDITION:~%~A"
136 (unhandled-debug-condition-condition condition)))))
138 (define-condition unknown-code-location (debug-error)
139 ((code-location :reader unknown-code-location-code-location
140 :initarg :code-location))
141 (:report (lambda (condition stream)
142 (format stream "~&invalid use of an unknown code-location: ~S"
143 (unknown-code-location-code-location condition)))))
145 (define-condition unknown-debug-var (debug-error)
146 ((debug-var :reader unknown-debug-var-debug-var :initarg :debug-var)
147 (debug-function :reader unknown-debug-var-debug-function
148 :initarg :debug-function))
149 (:report (lambda (condition stream)
150 (format stream "~&~S is not in ~S."
151 (unknown-debug-var-debug-var condition)
152 (unknown-debug-var-debug-function condition)))))
154 (define-condition invalid-control-stack-pointer (debug-error)
156 (:report (lambda (condition stream)
157 (declare (ignore condition))
159 (write-string "invalid control stack pointer" stream))))
161 (define-condition frame-function-mismatch (debug-error)
162 ((code-location :reader frame-function-mismatch-code-location
163 :initarg :code-location)
164 (frame :reader frame-function-mismatch-frame :initarg :frame)
165 (form :reader frame-function-mismatch-form :initarg :form))
166 (:report (lambda (condition stream)
169 "~&Form was preprocessed for ~S,~% but called on ~S:~% ~S"
170 (frame-function-mismatch-code-location condition)
171 (frame-function-mismatch-frame condition)
172 (frame-function-mismatch-form condition)))))
174 ;;; This signals debug-conditions. If they go unhandled, then signal
175 ;;; an UNHANDLED-DEBUG-CONDITION error.
177 ;;; ??? Get SIGNAL in the right package!
178 (defmacro debug-signal (datum &rest arguments)
179 `(let ((condition (make-condition ,datum ,@arguments)))
181 (error 'unhandled-debug-condition :condition condition)))
185 ;;;; Most of these structures model information stored in internal
186 ;;;; data structures created by the compiler. Whenever comments
187 ;;;; preface an object or type with "compiler", they refer to the
188 ;;;; internal compiler thing, not to the object or type with the same
189 ;;;; name in the "SB-DI" package.
193 ;;; These exist for caching data stored in packed binary form in
194 ;;; compiler debug-functions. Debug-functions store these.
195 (defstruct (debug-var (:constructor nil)
197 ;; the name of the variable
198 (symbol (required-argument) :type symbol)
199 ;; a unique integer identification relative to other variables with the same
201 (id 0 :type sb!c::index)
202 ;; Does the variable always have a valid value?
203 (alive-p nil :type boolean))
204 (def!method print-object ((debug-var debug-var) stream)
205 (print-unreadable-object (debug-var stream :type t :identity t)
208 (debug-var-symbol debug-var)
209 (debug-var-id debug-var))))
212 (setf (fdocumentation 'debug-var-id 'function)
213 "Return the integer that makes DEBUG-VAR's name and package unique
214 with respect to other DEBUG-VARs in the same function.")
216 (defstruct (compiled-debug-var
218 (:constructor make-compiled-debug-var
219 (symbol id alive-p sc-offset save-sc-offset))
221 ;; Storage class and offset. (unexported).
222 (sc-offset nil :type sb!c::sc-offset)
223 ;; Storage class and offset when saved somewhere.
224 (save-sc-offset nil :type (or sb!c::sc-offset null)))
228 ;;; These represent call-frames on the stack.
229 (defstruct (frame (:constructor nil)
231 ;; the next frame up, or NIL when top frame
232 (up nil :type (or frame null))
233 ;; the previous frame down, or NIL when the bottom frame. Before
234 ;; computing the next frame down, this slot holds the frame pointer
235 ;; to the control stack for the given frame. This lets us get the
236 ;; next frame down and the return-pc for that frame.
237 (%down :unparsed :type (or frame (member nil :unparsed)))
238 ;; the debug-function for the function whose call this frame
240 (debug-function nil :type debug-function)
241 ;; the code-location to continue upon return to frame
242 (code-location nil :type code-location)
243 ;; an a-list of catch-tags to code-locations
244 (%catches :unparsed :type (or list (member :unparsed)))
245 ;; pointer to frame on control stack. (unexported) When this frame
246 ;; is an interpreted-frame, this pointer is an index into the
247 ;; interpreter's stack.
249 ;; This is the frame's number for prompt printing. Top is zero.
250 (number 0 :type index))
253 (setf (fdocumentation 'frame-up 'function)
254 "Return the frame immediately above frame on the stack. When frame is
255 the top of the stack, this returns nil.")
258 (setf (fdocumentation 'frame-debug-function 'function)
259 "Return the debug-function for the function whose call frame represents.")
262 (setf (fdocumentation 'frame-code-location 'function)
263 "Return the code-location where the frame's debug-function will continue
264 running when program execution returns to this frame. If someone
265 interrupted this frame, the result could be an unknown code-location.")
267 (defstruct (compiled-frame
269 (:constructor make-compiled-frame
270 (pointer up debug-function code-location number
271 #!+gengc saved-state-chain
274 ;; This indicates whether someone interrupted the frame.
275 ;; (unexported). If escaped, this is a pointer to the state that was
276 ;; saved when we were interrupted. On the non-gengc system, this is
277 ;; a pointer to an os_context_t, i.e. the third argument to an
278 ;; SA_SIGACTION-style signal handler. On the gengc system, this is a
279 ;; state pointer from SAVED-STATE-CHAIN.
281 ;; a list of SAPs to saved states. Each time we unwind past an
282 ;; exception, we pop the next entry off this list. When we get to
283 ;; the end of the list, there is nothing else on the stack.
284 #!+gengc (saved-state-chain nil :type list))
285 (def!method print-object ((obj compiled-frame) str)
286 (print-unreadable-object (obj str :type t)
288 "~S~:[~;, interrupted~]"
289 (debug-function-name (frame-debug-function obj))
290 (compiled-frame-escaped obj))))
292 (defstruct (interpreted-frame
294 (:constructor make-interpreted-frame
295 (pointer up debug-function code-location number
298 ;; This points to the compiled-frame for SB!BYTECODE:INTERNAL-APPLY-LOOP.
299 (real-frame nil :type compiled-frame)
300 ;; This is the closed over data used by the interpreter.
301 (closure nil :type simple-vector))
302 (def!method print-object ((obj interpreted-frame) str)
303 (print-unreadable-object (obj str :type t)
304 (prin1 (debug-function-name (frame-debug-function obj)) str)))
308 ;;; These exist for caching data stored in packed binary form in
309 ;;; compiler debug-functions. *COMPILED-DEBUG-FUNCTIONS* maps a
310 ;;; SB!C::DEBUG-FUNCTION to a DEBUG-FUNCTION. There should only be one
311 ;;; DEBUG-FUNCTION in existence for any function; that is, all
312 ;;; code-locations and other objects that reference DEBUG-FUNCTIONs
313 ;;; point to unique objects. This is due to the overhead in cached
315 (defstruct (debug-function (:constructor nil)
317 ;; some representation of the function arguments. See
318 ;; DEBUG-FUNCTION-LAMBDA-LIST.
319 ;; NOTE: must parse vars before parsing arg list stuff.
320 (%lambda-list :unparsed)
321 ;; cached DEBUG-VARS information (unexported).
322 ;; These are sorted by their name.
323 (%debug-vars :unparsed :type (or simple-vector null (member :unparsed)))
324 ;; cached debug-block information. This is NIL when we have tried to
325 ;; parse the packed binary info, but none is available.
326 (blocks :unparsed :type (or simple-vector null (member :unparsed)))
327 ;; the actual function if available
328 (%function :unparsed :type (or null function (member :unparsed))))
329 (def!method print-object ((obj debug-function) stream)
330 (print-unreadable-object (obj stream :type t)
331 (prin1 (debug-function-name obj) stream)))
333 (defstruct (compiled-debug-function
334 (:include debug-function)
335 (:constructor %make-compiled-debug-function
336 (compiler-debug-fun component))
338 ;; compiler's dumped debug-function information (unexported)
339 (compiler-debug-fun nil :type sb!c::compiled-debug-function)
340 ;; code object (unexported).
342 ;; the :FUNCTION-START breakpoint (if any) used to facilitate
343 ;; function end breakpoints
344 (end-starter nil :type (or null breakpoint)))
346 ;;; This maps SB!C::COMPILED-DEBUG-FUNCTIONs to
347 ;;; COMPILED-DEBUG-FUNCTIONs, so we can get at cached stuff and not
348 ;;; duplicate COMPILED-DEBUG-FUNCTION structures.
349 (defvar *compiled-debug-functions* (make-hash-table :test 'eq))
351 ;;; Make a COMPILED-DEBUG-FUNCTION for a SB!C::COMPILER-DEBUG-FUNCTION
352 ;;; and its component. This maps the latter to the former in
353 ;;; *COMPILED-DEBUG-FUNCTIONS*. If there already is a
354 ;;; COMPILED-DEBUG-FUNCTION, then this returns it from
355 ;;; *COMPILED-DEBUG-FUNCTIONS*.
356 (defun make-compiled-debug-function (compiler-debug-fun component)
357 (or (gethash compiler-debug-fun *compiled-debug-functions*)
358 (setf (gethash compiler-debug-fun *compiled-debug-functions*)
359 (%make-compiled-debug-function compiler-debug-fun component))))
361 (defstruct (bogus-debug-function
362 (:include debug-function)
363 (:constructor make-bogus-debug-function
364 (%name &aux (%lambda-list nil) (%debug-vars nil)
365 (blocks nil) (%function nil)))
369 (defvar *ir1-lambda-debug-function* (make-hash-table :test 'eq))
373 ;;; These exist for caching data stored in packed binary form in compiler
375 (defstruct (debug-block (:constructor nil)
377 ;; Code-locations where execution continues after this block.
378 (successors nil :type list)
379 ;; This indicates whether the block is a special glob of code shared
380 ;; by various functions and tucked away elsewhere in a component.
381 ;; This kind of block has no start code-location. This slot is in
382 ;; all debug-blocks since it is an exported interface.
383 (elsewhere-p nil :type boolean))
384 (def!method print-object ((obj debug-block) str)
385 (print-unreadable-object (obj str :type t)
386 (prin1 (debug-block-function-name obj) str)))
389 (setf (fdocumentation 'debug-block-successors 'function)
390 "Returns the list of possible code-locations where execution may continue
391 when the basic-block represented by debug-block completes its execution.")
394 (setf (fdocumentation 'debug-block-elsewhere-p 'function)
395 "Returns whether debug-block represents elsewhere code.")
397 (defstruct (compiled-debug-block (:include debug-block)
399 make-compiled-debug-block
400 (code-locations successors elsewhere-p))
402 ;; code-location information for the block
403 (code-locations nil :type simple-vector))
405 (defvar *ir1-block-debug-block* (make-hash-table :test 'eq))
409 ;;; This is an internal structure that manages information about a
410 ;;; breakpoint locations. See *COMPONENT-BREAKPOINT-OFFSETS*.
411 (defstruct (breakpoint-data (:constructor make-breakpoint-data
414 ;; This is the component in which the breakpoint lies.
416 ;; This is the byte offset into the component.
417 (offset nil :type sb!c::index)
418 ;; The original instruction replaced by the breakpoint.
419 (instruction nil :type (or null (unsigned-byte 32)))
420 ;; A list of user breakpoints at this location.
421 (breakpoints nil :type list))
422 (def!method print-object ((obj breakpoint-data) str)
423 (print-unreadable-object (obj str :type t)
424 (format str "~S at ~S"
426 (debug-function-from-pc (breakpoint-data-component obj)
427 (breakpoint-data-offset obj)))
428 (breakpoint-data-offset obj))))
430 (defstruct (breakpoint (:constructor %make-breakpoint
431 (hook-function what kind %info))
433 ;; This is the function invoked when execution encounters the
434 ;; breakpoint. It takes a frame, the breakpoint, and optionally a
435 ;; list of values. Values are supplied for :FUNCTION-END breakpoints
436 ;; as values to return for the function containing the breakpoint.
437 ;; :FUNCTION-END breakpoint hook-functions also take a cookie
438 ;; argument. See COOKIE-FUN slot.
439 (hook-function nil :type function)
440 ;; CODE-LOCATION or DEBUG-FUNCTION
441 (what nil :type (or code-location debug-function))
442 ;; :CODE-LOCATION, :FUNCTION-START, or :FUNCTION-END for that kind
443 ;; of breakpoint. :UNKNOWN-RETURN-PARTNER if this is the partner of
444 ;; a :code-location breakpoint at an :UNKNOWN-RETURN code-location.
445 (kind nil :type (member :code-location :function-start :function-end
446 :unknown-return-partner))
447 ;; Status helps the user and the implementation.
448 (status :inactive :type (member :active :inactive :deleted))
449 ;; This is a backpointer to a breakpoint-data.
450 (internal-data nil :type (or null breakpoint-data))
451 ;; With code-locations whose type is :UNKNOWN-RETURN, there are
452 ;; really two breakpoints: one at the multiple-value entry point,
453 ;; and one at the single-value entry point. This slot holds the
454 ;; breakpoint for the other one, or NIL if this isn't at an
455 ;; :UNKNOWN-RETURN code location.
456 (unknown-return-partner nil :type (or null breakpoint))
457 ;; :FUNCTION-END breakpoints use a breakpoint at the :FUNCTION-START
458 ;; to establish the end breakpoint upon function entry. We do this
459 ;; by frobbing the LRA to jump to a special piece of code that
460 ;; breaks and provides the return values for the returnee. This slot
461 ;; points to the start breakpoint, so we can activate, deactivate,
463 (start-helper nil :type (or null breakpoint))
464 ;; This is a hook users supply to get a dynamically unique cookie
465 ;; for identifying :FUNCTION-END breakpoint executions. That is, if
466 ;; there is one :FUNCTION-END breakpoint, but there may be multiple
467 ;; pending calls of its function on the stack. This function takes
468 ;; the cookie, and the hook-function takes the cookie too.
469 (cookie-fun nil :type (or null function))
470 ;; This slot users can set with whatever information they find useful.
472 (def!method print-object ((obj breakpoint) str)
473 (let ((what (breakpoint-what obj)))
474 (print-unreadable-object (obj str :type t)
479 (debug-function (debug-function-name what)))
482 (debug-function (breakpoint-kind obj)))))))
485 (setf (fdocumentation 'breakpoint-hook-function 'function)
486 "Returns the breakpoint's function the system calls when execution encounters
487 the breakpoint, and it is active. This is SETF'able.")
490 (setf (fdocumentation 'breakpoint-what 'function)
491 "Returns the breakpoint's what specification.")
494 (setf (fdocumentation 'breakpoint-kind 'function)
495 "Returns the breakpoint's kind specification.")
499 (defstruct (code-location (:constructor nil)
501 ;; This is the debug-function containing code-location.
502 (debug-function nil :type debug-function)
503 ;; This is initially :UNSURE. Upon first trying to access an
504 ;; :unparsed slot, if the data is unavailable, then this becomes t,
505 ;; and the code-location is unknown. If the data is available, this
506 ;; becomes nil, a known location. We can't use a separate type
507 ;; code-location for this since we must return code-locations before
508 ;; we can tell whether they're known or unknown. For example, when
509 ;; parsing the stack, we don't want to unpack all the variables and
510 ;; blocks just to make frames.
511 (%unknown-p :unsure :type (member t nil :unsure))
512 ;; This is the debug-block containing code-location. Possibly toss
513 ;; this out and just find it in the blocks cache in debug-function.
514 (%debug-block :unparsed :type (or debug-block (member :unparsed)))
515 ;; This is the number of forms processed by the compiler or loader
516 ;; before the top-level form containing this code-location.
517 (%tlf-offset :unparsed :type (or sb!c::index (member :unparsed)))
518 ;; This is the depth-first number of the node that begins
519 ;; code-location within its top-level form.
520 (%form-number :unparsed :type (or sb!c::index (member :unparsed))))
521 (def!method print-object ((obj code-location) str)
522 (print-unreadable-object (obj str :type t)
523 (prin1 (debug-function-name (code-location-debug-function obj))
527 (setf (fdocumentation 'code-location-debug-function 'function)
528 "Returns the debug-function representing information about the function
529 corresponding to the code-location.")
531 (defstruct (compiled-code-location
532 (:include code-location)
533 (:constructor make-known-code-location
534 (pc debug-function %tlf-offset %form-number
535 %live-set kind &aux (%unknown-p nil)))
536 (:constructor make-compiled-code-location (pc debug-function))
538 ;; This is an index into debug-function's component slot.
539 (pc nil :type sb!c::index)
540 ;; This is a bit-vector indexed by a variable's position in
541 ;; DEBUG-FUNCTION-DEBUG-VARS indicating whether the variable has a
542 ;; valid value at this code-location. (unexported).
543 (%live-set :unparsed :type (or simple-bit-vector (member :unparsed)))
544 ;; (unexported) To see SB!C::LOCATION-KIND, do
545 ;; (SB!KERNEL:TYPE-EXPAND 'SB!C::LOCATION-KIND).
546 (kind :unparsed :type (or (member :unparsed) sb!c::location-kind)))
550 ;;; Return the number of top-level forms processed by the compiler
551 ;;; before compiling this source. If this source is uncompiled, this
552 ;;; is zero. This may be zero even if the source is compiled since the
553 ;;; first form in the first file compiled in one compilation, for
554 ;;; example, must have a root number of zero -- the compiler saw no
555 ;;; other top-level forms before it.
556 (defun debug-source-root-number (debug-source)
557 (sb!c::debug-source-source-root debug-source))
561 ;;; This is used in FIND-ESCAPED-FRAME and with the bogus components
562 ;;; and LRAs used for :function-end breakpoints. When a components
563 ;;; debug-info slot is :bogus-lra, then the real-lra-slot contains the
564 ;;; real component to continue executing, as opposed to the bogus
565 ;;; component which appeared in some frame's LRA location.
566 (defconstant real-lra-slot sb!vm:code-constants-offset)
568 ;;; These are magically converted by the compiler.
569 (defun current-sp () (current-sp))
570 (defun current-fp () (current-fp))
571 (defun stack-ref (s n) (stack-ref s n))
572 (defun %set-stack-ref (s n value) (%set-stack-ref s n value))
573 (defun function-code-header (fun) (function-code-header fun))
574 #!-gengc (defun lra-code-header (lra) (lra-code-header lra))
575 (defun make-lisp-obj (value) (make-lisp-obj value))
576 (defun get-lisp-obj-address (thing) (get-lisp-obj-address thing))
577 (defun function-word-offset (fun) (function-word-offset fun))
579 #!-sb-fluid (declaim (inline cstack-pointer-valid-p))
580 (defun cstack-pointer-valid-p (x)
581 (declare (type system-area-pointer x))
582 #!-x86 ; stack grows toward high address values
583 (and (sap< x (current-sp))
584 (sap<= #!-gengc (int-sap control-stack-start)
585 #!+gengc (mutator-control-stack-base)
587 (zerop (logand (sap-int x) #b11)))
588 #!+x86 ; stack grows toward low address values
589 (and (sap>= x (current-sp))
590 (sap> (int-sap control-stack-end) x)
591 (zerop (logand (sap-int x) #b11))))
594 (sb!alien:def-alien-routine component-ptr-from-pc (system-area-pointer)
595 (pc system-area-pointer))
598 (defun component-from-component-ptr (component-ptr)
599 (declare (type system-area-pointer component-ptr))
600 (make-lisp-obj (logior (sap-int component-ptr)
601 sb!vm:other-pointer-type)))
608 (defun compute-lra-data-from-pc (pc)
609 (declare (type system-area-pointer pc))
610 (let ((component-ptr (component-ptr-from-pc pc)))
611 (unless (sap= component-ptr (int-sap #x0))
612 (let* ((code (component-from-component-ptr component-ptr))
613 (code-header-len (* (get-header-data code) sb!vm:word-bytes))
614 (pc-offset (- (sap-int pc)
615 (- (get-lisp-obj-address code)
616 sb!vm:other-pointer-type)
618 ; (format t "c-lra-fpc ~A ~A ~A~%" pc code pc-offset)
619 (values pc-offset code)))))
621 (defconstant sb!vm::nargs-offset #.sb!vm::ecx-offset)
623 ;;; Check for a valid return address - it could be any valid C/Lisp
626 ;;; XXX Could be a little smarter.
627 #!-sb-fluid (declaim (inline ra-pointer-valid-p))
628 (defun ra-pointer-valid-p (ra)
629 (declare (type system-area-pointer ra))
631 ;; Not the first page which is unmapped.
632 (>= (sap-int ra) 4096)
633 ;; Not a Lisp stack pointer.
634 (not (cstack-pointer-valid-p ra))))
636 ;;; Try to find a valid previous stack. This is complex on the x86 as
637 ;;; it can jump between C and Lisp frames. To help find a valid frame
638 ;;; it searches backwards.
640 ;;; XXX Should probably check whether it has reached the bottom of the
643 ;;; XXX Should handle interrupted frames, both Lisp and C. At present
644 ;;; it manages to find a fp trail, see linux hack below.
645 (defun x86-call-context (fp &key (depth 0))
646 (declare (type system-area-pointer fp)
648 ;;(format t "*CC ~S ~S~%" fp depth)
650 ((not (cstack-pointer-valid-p fp))
651 #+nil (format t "debug invalid fp ~S~%" fp)
654 ;; Check the two possible frame pointers.
655 (let ((lisp-ocfp (sap-ref-sap fp (- (* (1+ sb!vm::ocfp-save-offset) 4))))
656 (lisp-ra (sap-ref-sap fp (- (* (1+ sb!vm::return-pc-save-offset)
658 (c-ocfp (sap-ref-sap fp (* 0 sb!vm:word-bytes)))
659 (c-ra (sap-ref-sap fp (* 1 sb!vm:word-bytes))))
660 (cond ((and (sap> lisp-ocfp fp) (cstack-pointer-valid-p lisp-ocfp)
661 (ra-pointer-valid-p lisp-ra)
662 (sap> c-ocfp fp) (cstack-pointer-valid-p c-ocfp)
663 (ra-pointer-valid-p c-ra))
665 "*C Both valid ~S ~S ~S ~S~%"
666 lisp-ocfp lisp-ra c-ocfp c-ra)
667 ;; Look forward another step to check their validity.
668 (let ((lisp-path-fp (x86-call-context lisp-ocfp
670 (c-path-fp (x86-call-context c-ocfp :depth (1+ depth))))
671 (cond ((and lisp-path-fp c-path-fp)
672 ;; Both still seem valid - choose the lisp frame.
673 #+nil (when (zerop depth)
675 "debug: both still valid ~S ~S ~S ~S~%"
676 lisp-ocfp lisp-ra c-ocfp c-ra))
678 (if (sap> lisp-ocfp c-ocfp)
679 (values lisp-ra lisp-ocfp)
680 (values c-ra c-ocfp))
682 (values lisp-ra lisp-ocfp))
684 ;; The lisp convention is looking good.
685 #+nil (format t "*C lisp-ocfp ~S ~S~%" lisp-ocfp lisp-ra)
686 (values lisp-ra lisp-ocfp))
688 ;; The C convention is looking good.
689 #+nil (format t "*C c-ocfp ~S ~S~%" c-ocfp c-ra)
690 (values c-ra c-ocfp))
692 ;; Neither seems right?
693 #+nil (format t "debug: no valid2 fp found ~S ~S~%"
696 ((and (sap> lisp-ocfp fp) (cstack-pointer-valid-p lisp-ocfp)
697 (ra-pointer-valid-p lisp-ra))
698 ;; The lisp convention is looking good.
699 #+nil (format t "*C lisp-ocfp ~S ~S~%" lisp-ocfp lisp-ra)
700 (values lisp-ra lisp-ocfp))
701 ((and (sap> c-ocfp fp) (cstack-pointer-valid-p c-ocfp)
702 #!-linux (ra-pointer-valid-p c-ra))
703 ;; The C convention is looking good.
704 #+nil (format t "*C c-ocfp ~S ~S~%" c-ocfp c-ra)
705 (values c-ra c-ocfp))
707 #+nil (format t "debug: no valid fp found ~S ~S~%"
713 ;;; Convert the descriptor into a SAP. The bits all stay the same, we just
714 ;;; change our notion of what we think they are.
715 #!-sb-fluid (declaim (inline descriptor-sap))
716 (defun descriptor-sap (x)
717 (int-sap (get-lisp-obj-address x)))
719 ;;; Return the top frame of the control stack as it was before calling
722 (/show0 "entering TOP-FRAME")
723 (multiple-value-bind (fp pc) (%caller-frame-and-pc)
724 (possibly-an-interpreted-frame
725 (compute-calling-frame (descriptor-sap fp)
726 #!-gengc pc #!+gengc (descriptor-sap pc)
730 ;;; Flush all of the frames above FRAME, and renumber all the frames
732 (defun flush-frames-above (frame)
733 (setf (frame-up frame) nil)
734 (do ((number 0 (1+ number))
735 (frame frame (frame-%down frame)))
736 ((not (frame-p frame)))
737 (setf (frame-number frame) number)))
739 ;;; Return the frame immediately below FRAME on the stack; or when
740 ;;; FRAME is the bottom of the stack, return NIL.
741 (defun frame-down (frame)
742 (/show0 "entering FRAME-DOWN")
743 ;; We have to access the old-fp and return-pc out of frame and pass
744 ;; them to COMPUTE-CALLING-FRAME.
745 (let ((down (frame-%down frame)))
746 (if (eq down :unparsed)
747 (let* ((real (frame-real-frame frame))
748 (debug-fun (frame-debug-function real)))
749 (/show0 "in DOWN :UNPARSED case")
750 (setf (frame-%down frame)
752 (compiled-debug-function
753 (let ((c-d-f (compiled-debug-function-compiler-debug-fun
755 (possibly-an-interpreted-frame
756 (compute-calling-frame
759 real sb!vm::ocfp-save-offset
760 (sb!c::compiled-debug-function-old-fp c-d-f)))
763 real sb!vm::lra-save-offset
764 (sb!c::compiled-debug-function-return-pc c-d-f))
768 real sb!vm::ra-save-offset
769 (sb!c::compiled-debug-function-return-pc c-d-f)))
772 (bogus-debug-function
773 (let ((fp (frame-pointer real)))
774 (when (cstack-pointer-valid-p fp)
776 (multiple-value-bind (ra ofp) (x86-call-context fp)
777 (compute-calling-frame ofp ra frame))
779 (compute-calling-frame
781 (sap-ref-sap fp (* sb!vm::ocfp-save-offset
785 (sap-ref-32 fp (* sb!vm::ocfp-save-offset
789 (stack-ref fp sb!vm::lra-save-offset)
791 (sap-ref-sap fp (* sb!vm::ra-save-offset
796 ;;; Get the old FP or return PC out of FRAME. STACK-SLOT is the
797 ;;; standard save location offset on the stack. LOC is the saved
798 ;;; SC-OFFSET describing the main location.
800 (defun get-context-value (frame stack-slot loc)
801 (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
802 (type sb!c::sc-offset loc))
803 (let ((pointer (frame-pointer frame))
804 (escaped (compiled-frame-escaped frame)))
806 (sub-access-debug-var-slot pointer loc escaped)
807 (stack-ref pointer stack-slot))))
809 (defun get-context-value (frame stack-slot loc)
810 (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
811 (type sb!c::sc-offset loc))
812 (let ((pointer (frame-pointer frame))
813 (escaped (compiled-frame-escaped frame)))
815 (sub-access-debug-var-slot pointer loc escaped)
817 (#.sb!vm::ocfp-save-offset
818 (stack-ref pointer stack-slot))
819 (#.sb!vm::lra-save-offset
820 (sap-ref-sap pointer (- (* (1+ stack-slot) 4))))))))
823 (defun (setf get-context-value) (value frame stack-slot loc)
824 (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
825 (type sb!c::sc-offset loc))
826 (let ((pointer (frame-pointer frame))
827 (escaped (compiled-frame-escaped frame)))
829 (sub-set-debug-var-slot pointer loc value escaped)
830 (setf (stack-ref pointer stack-slot) value))))
833 (defun (setf get-context-value) (value frame stack-slot loc)
834 (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
835 (type sb!c::sc-offset loc))
836 (let ((pointer (frame-pointer frame))
837 (escaped (compiled-frame-escaped frame)))
839 (sub-set-debug-var-slot pointer loc value escaped)
841 (#.sb!vm::ocfp-save-offset
842 (setf (stack-ref pointer stack-slot) value))
843 (#.sb!vm::lra-save-offset
844 (setf (sap-ref-sap pointer (- (* (1+ stack-slot) 4))) value))))))
846 ;;; This doesn't do anything in sbcl-0.7.0, since the functionality
847 ;;; was lost in the switch from IR1 interpreter to bytecode interpreter.
848 ;;; However, it might be revived someday. (See the FIXME for
849 ;;; POSSIBLY-AN-INTERPRETED-FRAME.)
851 ;;; (defvar *debugging-interpreter* nil
853 ;;; "When set, the debugger foregoes making interpreted frames, so you can
854 ;;; debug the functions that manifest the interpreter.")
856 ;;; Note: In CMU CL with the IR1 interpreter, this did
857 ;;; This takes a newly computed frame, FRAME, and the frame above it
858 ;;; on the stack, UP-FRAME, which is possibly NIL. FRAME is NIL when
859 ;;; we hit the bottom of the control stack. When FRAME represents a
860 ;;; call to SB!BYTECODE::INTERNAL-APPLY-LOOP, we make an interpreted frame
861 ;;; to replace FRAME. The interpreted frame points to FRAME.
862 ;;; But with SBCL's switch to byte-interpreter-only, this is functionality
863 ;;; wasn't maintained, so this is just a placeholder, and when you
864 ;;; try to "debug byte code" you end up debugging the byte interpreter
867 ;;; (It might be good to update the old CMU CL functionality so that
868 ;;; you can really debug byte code instead of seeing a bunch of
869 ;;; confusing byte interpreter implementation stuff, so I've left the
870 ;;; placeholder in place. But be aware that doing so is a big messy
871 ;;; job: grep for 'interpreted-debug-' in the sbcl-0.6.13 sources to
872 ;;; see what you're getting into. -- WHN)
873 (defun possibly-an-interpreted-frame (frame up-frame)
875 ;; new SBCL code, not ambitious enough to do anything tricky like
876 ;; hiding the byte interpreter when debugging
877 (declare (ignore up-frame))
878 (/show "doing trivial POSSIBLY-AN-INTERPRETED-FRAME")
881 ;; old CMU CL code to hide IR1 interpreter when debugging:
883 ;;(if (or (not frame)
884 ;; (not (eq (debug-function-name (frame-debug-function
886 ;; 'sb!bytecode::internal-apply-loop))
887 ;; *debugging-interpreter*
888 ;; (compiled-frame-escaped frame))
890 ;; (flet ((get-var (name location)
891 ;; (let ((vars (sb!di:ambiguous-debug-vars
892 ;; (sb!di:frame-debug-function frame) name)))
893 ;; (when (or (null vars) (> (length vars) 1))
894 ;; (error "zero or more than one ~A variable in ~
895 ;; SB!BYTECODE::INTERNAL-APPLY-LOOP"
896 ;; (string-downcase name)))
897 ;; (if (eq (debug-var-validity (car vars) location)
900 ;; (let* ((code-loc (frame-code-location frame))
901 ;; (ptr-var (get-var "FRAME-PTR" code-loc))
902 ;; (node-var (get-var "NODE" code-loc))
903 ;; (closure-var (get-var "CLOSURE" code-loc)))
904 ;; (if (and ptr-var node-var closure-var)
905 ;; (let* ((node (debug-var-value node-var frame))
906 ;; (d-fun (make-interpreted-debug-function
907 ;; (sb!c::block-home-lambda (sb!c::node-block
909 ;; (make-interpreted-frame
910 ;; (debug-var-value ptr-var frame)
913 ;; (make-interpreted-code-location node d-fun)
914 ;; (frame-number frame)
916 ;; (debug-var-value closure-var frame)))
920 ;;; This returns a frame for the one existing in time immediately
921 ;;; prior to the frame referenced by current-fp. This is current-fp's
922 ;;; caller or the next frame down the control stack. If there is no
923 ;;; down frame, this returns nil for the bottom of the stack. Up-frame
924 ;;; is the up link for the resulting frame object, and it is nil when
925 ;;; we call this to get the top of the stack.
927 ;;; The current frame contains the pointer to the temporally previous
928 ;;; frame we want, and the current frame contains the pc at which we
929 ;;; will continue executing upon returning to that previous frame.
931 ;;; Note: Sometimes LRA is actually a fixnum. This happens when lisp
932 ;;; calls into C. In this case, the code object is stored on the stack
933 ;;; after the LRA, and the LRA is the word offset.
935 (defun compute-calling-frame (caller lra up-frame)
936 (declare (type system-area-pointer caller))
937 (when (cstack-pointer-valid-p caller)
938 (multiple-value-bind (code pc-offset escaped)
940 (multiple-value-bind (word-offset code)
942 (let ((fp (frame-pointer up-frame)))
944 (stack-ref fp (1+ sb!vm::lra-save-offset))))
945 (values (get-header-data lra)
946 (lra-code-header lra)))
949 (* (1+ (- word-offset (get-header-data code)))
952 (values :foreign-function
955 (find-escaped-frame caller))
956 (if (and (code-component-p code)
957 (eq (%code-debug-info code) :bogus-lra))
958 (let ((real-lra (code-header-ref code real-lra-slot)))
959 (compute-calling-frame caller real-lra up-frame))
960 (let ((d-fun (case code
962 (make-bogus-debug-function
963 "undefined function"))
965 (make-bogus-debug-function
966 "foreign function call land"))
968 (make-bogus-debug-function
969 "bogus stack frame"))
971 (debug-function-from-pc code pc-offset)))))
972 (make-compiled-frame caller up-frame d-fun
973 (code-location-from-pc d-fun pc-offset
975 (if up-frame (1+ (frame-number up-frame)) 0)
979 (defun compute-calling-frame (caller ra up-frame)
980 (declare (type system-area-pointer caller ra))
981 (/show0 "entering COMPUTE-CALLING-FRAME")
982 (when (cstack-pointer-valid-p caller)
984 ;; First check for an escaped frame.
985 (multiple-value-bind (code pc-offset escaped) (find-escaped-frame caller)
988 (/show0 "in CODE clause")
989 ;; If it's escaped it may be a function end breakpoint trap.
990 (when (and (code-component-p code)
991 (eq (%code-debug-info code) :bogus-lra))
992 ;; If :bogus-lra grab the real lra.
993 (setq pc-offset (code-header-ref
994 code (1+ real-lra-slot)))
995 (setq code (code-header-ref code real-lra-slot))
998 (/show0 "in T clause")
1000 (multiple-value-setq (pc-offset code)
1001 (compute-lra-data-from-pc ra))
1003 (setf code :foreign-function
1007 (let ((d-fun (case code
1008 (:undefined-function
1009 (make-bogus-debug-function
1010 "undefined function"))
1012 (make-bogus-debug-function
1013 "foreign function call land"))
1015 (make-bogus-debug-function
1016 "bogus stack frame"))
1018 (debug-function-from-pc code pc-offset)))))
1019 (/show0 "returning MAKE-COMPILED-FRAME from COMPUTE-CALLING-FRAME")
1020 (make-compiled-frame caller up-frame d-fun
1021 (code-location-from-pc d-fun pc-offset
1023 (if up-frame (1+ (frame-number up-frame)) 0)
1027 (defun find-escaped-frame (frame-pointer)
1028 (declare (type system-area-pointer frame-pointer))
1029 (/show0 "entering FIND-ESCAPED-FRAME")
1030 (dotimes (index *free-interrupt-context-index* (values nil 0 nil))
1031 (sb!alien:with-alien
1032 ((lisp-interrupt-contexts (array (* os-context-t) nil) :extern))
1033 (/show0 "at head of WITH-ALIEN")
1034 (let ((context (sb!alien:deref lisp-interrupt-contexts index)))
1035 (/show0 "got CONTEXT")
1036 (when (= (sap-int frame-pointer)
1037 (sb!vm:context-register context sb!vm::cfp-offset))
1039 (/show0 "in WITHOUT-GCING")
1040 (let* ((component-ptr (component-ptr-from-pc
1041 (sb!vm:context-pc context)))
1042 (code (unless (sap= component-ptr (int-sap #x0))
1043 (component-from-component-ptr component-ptr))))
1046 (return (values code 0 context)))
1047 (let* ((code-header-len (* (get-header-data code)
1050 (- (sap-int (sb!vm:context-pc context))
1051 (- (get-lisp-obj-address code)
1052 sb!vm:other-pointer-type)
1054 (/show "got PC-OFFSET")
1055 (unless (<= 0 pc-offset
1056 (* (code-header-ref code sb!vm:code-code-size-slot)
1058 ;; We were in an assembly routine. Therefore, use the
1061 ;; FIXME: Should this be WARN or ERROR or what?
1062 (format t "** pc-offset ~S not in code obj ~S?~%"
1064 (/show0 "returning from FIND-ESCAPED-FRAME")
1066 (values code pc-offset context))))))))))
1069 (defun find-escaped-frame (frame-pointer)
1070 (declare (type system-area-pointer frame-pointer))
1071 (dotimes (index *free-interrupt-context-index* (values nil 0 nil))
1072 (sb!alien:with-alien
1073 ((lisp-interrupt-contexts (array (* os-context-t) nil) :extern))
1074 (let ((scp (sb!alien:deref lisp-interrupt-contexts index)))
1075 (when (= (sap-int frame-pointer)
1076 (sb!vm:context-register scp sb!vm::cfp-offset))
1078 (let ((code (code-object-from-bits
1079 (sb!vm:context-register scp sb!vm::code-offset))))
1080 (when (symbolp code)
1081 (return (values code 0 scp)))
1082 (let* ((code-header-len (* (get-header-data code)
1085 (- (sap-int (sb!vm:context-pc scp))
1086 (- (get-lisp-obj-address code)
1087 sb!vm:other-pointer-type)
1089 ;; Check to see whether we were executing in a branch
1091 #!+(or pmax sgi) ; pmax only (and broken anyway)
1092 (when (logbitp 31 (sb!alien:slot scp '%mips::sc-cause))
1093 (incf pc-offset sb!vm:word-bytes))
1094 (unless (<= 0 pc-offset
1095 (* (code-header-ref code sb!vm:code-code-size-slot)
1097 ;; We were in an assembly routine. Therefore, use the
1100 (- (sb!vm:context-register scp sb!vm::lra-offset)
1101 (get-lisp-obj-address code)
1104 (if (eq (%code-debug-info code) :bogus-lra)
1105 (let ((real-lra (code-header-ref code
1107 (values (lra-code-header real-lra)
1108 (get-header-data real-lra)
1110 (values code pc-offset scp)))))))))))
1112 ;;; Find the code object corresponding to the object represented by
1113 ;;; bits and return it. We assume bogus functions correspond to the
1114 ;;; undefined-function.
1116 (defun code-object-from-bits (bits)
1117 (declare (type (unsigned-byte 32) bits))
1118 (let ((object (make-lisp-obj bits)))
1119 (if (functionp object)
1120 (or (function-code-header object)
1121 :undefined-function)
1122 (let ((lowtag (get-lowtag object)))
1123 (if (= lowtag sb!vm:other-pointer-type)
1124 (let ((type (get-type object)))
1125 (cond ((= type sb!vm:code-header-type)
1127 ((= type sb!vm:return-pc-header-type)
1128 (lra-code-header object))
1132 ;;; SB!KERNEL:*SAVED-STATE-CHAIN* -- maintained by the C code as a
1133 ;;; list of SAPs, each SAP pointing to a saved exception state.
1135 (declaim (special *saved-state-chain*))
1138 ;;; (DEFUN LOOKUP-TRACE-TABLE-ENTRY (COMPONENT PC) ..)
1139 ;;; for this case, but it hasn't been maintained in SBCL.
1141 (eval-when (:compile-toplevel :load-toplevel :execute)
1142 (error "hopelessly stale"))
1145 ;;; (DEFUN EXTRACT-INFO-FROM-STATE (STATE) ..)
1146 ;;; for this case, but it hasn't been maintained in SBCL.
1148 (eval-when (:compile-toplevel :load-toplevel :execute)
1149 (error "hopelessly stale"))
1152 ;;; (DEFUN COMPUTE-CALLING-FRAME (OCFP RA UP-FRAME) ..)
1153 ;;; for this case, but it hasn't been maintained in SBCL.
1155 (eval-when (:compile-toplevel :load-toplevel :execute)
1156 (error "hopelessly stale"))
1158 ;;;; frame utilities
1160 ;;; This returns a COMPILED-DEBUG-FUNCTION for code and pc. We fetch
1161 ;;; the SB!C::DEBUG-INFO and run down its function-map to get a
1162 ;;; SB!C::COMPILED-DEBUG-FUNCTION from the pc. The result only needs
1163 ;;; to reference the component, for function constants, and the
1164 ;;; SB!C::COMPILED-DEBUG-FUNCTION.
1165 (defun debug-function-from-pc (component pc)
1166 (let ((info (%code-debug-info component)))
1169 (debug-signal 'no-debug-info :code-component component))
1170 ((eq info :bogus-lra)
1171 (make-bogus-debug-function "function end breakpoint"))
1173 (let* ((function-map (get-debug-info-function-map info))
1174 (len (length function-map)))
1175 (declare (simple-vector function-map))
1177 (make-compiled-debug-function (svref function-map 0) component)
1180 (>= pc (sb!c::compiled-debug-function-elsewhere-pc
1181 (svref function-map 0)))))
1182 (declare (type sb!int:index i))
1185 (< pc (if elsewhere-p
1186 (sb!c::compiled-debug-function-elsewhere-pc
1187 (svref function-map (1+ i)))
1188 (svref function-map i))))
1189 (return (make-compiled-debug-function
1190 (svref function-map (1- i))
1194 ;;; This returns a code-location for the COMPILED-DEBUG-FUNCTION,
1195 ;;; DEBUG-FUN, and the pc into its code vector. If we stopped at a
1196 ;;; breakpoint, find the CODE-LOCATION for that breakpoint. Otherwise,
1197 ;;; make an :UNSURE code location, so it can be filled in when we
1198 ;;; figure out what is going on.
1199 (defun code-location-from-pc (debug-fun pc escaped)
1200 (or (and (compiled-debug-function-p debug-fun)
1202 (let ((data (breakpoint-data
1203 (compiled-debug-function-component debug-fun)
1205 (when (and data (breakpoint-data-breakpoints data))
1206 (let ((what (breakpoint-what
1207 (first (breakpoint-data-breakpoints data)))))
1208 (when (compiled-code-location-p what)
1210 (make-compiled-code-location pc debug-fun)))
1212 ;;; Return an alist mapping catch tags to CODE-LOCATIONs. These are
1213 ;;; CODE-LOCATIONs at which execution would continue with frame as the
1214 ;;; top frame if someone threw to the corresponding tag.
1215 (defun frame-catches (frame)
1217 #!-gengc (descriptor-sap *current-catch-block*)
1218 #!+gengc (mutator-current-catch-block))
1220 (fp (frame-pointer (frame-real-frame frame))))
1222 (when (zerop (sap-int catch)) (return (nreverse res)))
1226 (* sb!vm:catch-block-current-cont-slot
1231 (* sb!vm:catch-block-current-cont-slot
1232 sb!vm:word-bytes))))
1233 (let* (#!-(or gengc x86)
1234 (lra (stack-ref catch sb!vm:catch-block-entry-pc-slot))
1237 catch (* sb!vm:catch-block-entry-pc-slot
1241 (stack-ref catch sb!vm:catch-block-current-code-slot))
1243 (component (component-from-component-ptr
1244 (component-ptr-from-pc ra)))
1247 (* (- (1+ (get-header-data lra))
1248 (get-header-data component))
1252 (get-lisp-obj-address component)
1253 (get-header-data component))
1254 sb!vm:other-pointer-type)
1257 (- (get-lisp-obj-address component)
1258 sb!vm:other-pointer-type)
1259 (* (get-header-data component) sb!vm:word-bytes))))
1261 (stack-ref catch sb!vm:catch-block-tag-slot)
1264 (sap-ref-32 catch (* sb!vm:catch-block-tag-slot
1266 (make-compiled-code-location
1267 offset (frame-debug-function frame)))
1272 (* sb!vm:catch-block-previous-catch-slot
1277 (* sb!vm:catch-block-previous-catch-slot
1278 sb!vm:word-bytes)))))))
1280 ;;; If an interpreted frame, return the real frame, otherwise frame.
1281 (defun frame-real-frame (frame)
1283 (compiled-frame frame)
1284 (interpreted-frame (interpreted-frame-real-frame frame))))
1286 ;;;; operations on DEBUG-FUNCTIONs
1288 ;;; Execute the forms in a context with block-var bound to each
1289 ;;; debug-block in debug-function successively. Result is an optional
1290 ;;; form to execute for return values, and DO-DEBUG-FUNCTION-BLOCKS
1291 ;;; returns nil if there is no result form. This signals a
1292 ;;; no-debug-blocks condition when the debug-function lacks
1293 ;;; debug-block information.
1294 (defmacro do-debug-function-blocks ((block-var debug-function &optional result)
1296 (let ((blocks (gensym))
1298 `(let ((,blocks (debug-function-debug-blocks ,debug-function)))
1299 (declare (simple-vector ,blocks))
1300 (dotimes (,i (length ,blocks) ,result)
1301 (let ((,block-var (svref ,blocks ,i)))
1304 ;;; Execute body in a context with var bound to each debug-var in
1305 ;;; debug-function. This returns the value of executing result (defaults to
1306 ;;; nil). This may iterate over only some of debug-function's variables or none
1307 ;;; depending on debug policy; for example, possibly the compilation only
1308 ;;; preserved argument information.
1309 (defmacro do-debug-function-variables ((var debug-function &optional result)
1311 (let ((vars (gensym))
1313 `(let ((,vars (debug-function-debug-vars ,debug-function)))
1314 (declare (type (or null simple-vector) ,vars))
1316 (dotimes (,i (length ,vars) ,result)
1317 (let ((,var (svref ,vars ,i)))
1321 ;;; Return the Common Lisp function associated with the debug-function. This
1322 ;;; returns nil if the function is unavailable or is non-existent as a user
1323 ;;; callable function object.
1324 (defun debug-function-function (debug-function)
1325 (let ((cached-value (debug-function-%function debug-function)))
1326 (if (eq cached-value :unparsed)
1327 (setf (debug-function-%function debug-function)
1328 (etypecase debug-function
1329 (compiled-debug-function
1331 (compiled-debug-function-component debug-function))
1333 (sb!c::compiled-debug-function-start-pc
1334 (compiled-debug-function-compiler-debug-fun
1336 (do ((entry (%code-entry-points component)
1337 (%function-next entry)))
1340 (sb!c::compiled-debug-function-start-pc
1341 (compiled-debug-function-compiler-debug-fun
1342 (function-debug-function entry))))
1344 (bogus-debug-function nil)))
1347 ;;; Return the name of the function represented by debug-function. This may
1348 ;;; be a string or a cons; do not assume it is a symbol.
1349 (defun debug-function-name (debug-function)
1350 (etypecase debug-function
1351 (compiled-debug-function
1352 (sb!c::compiled-debug-function-name
1353 (compiled-debug-function-compiler-debug-fun debug-function)))
1354 (bogus-debug-function
1355 (bogus-debug-function-%name debug-function))))
1357 ;;; Return a debug-function that represents debug information for function.
1358 (defun function-debug-function (fun)
1359 (ecase (get-type fun)
1360 (#.sb!vm:closure-header-type
1361 (function-debug-function (%closure-function fun)))
1362 (#.sb!vm:funcallable-instance-header-type
1363 (function-debug-function (funcallable-instance-function fun)))
1364 ((#.sb!vm:function-header-type #.sb!vm:closure-function-header-type)
1365 (let* ((name (%function-name fun))
1366 (component (function-code-header fun))
1369 (and (sb!c::compiled-debug-function-p x)
1370 (eq (sb!c::compiled-debug-function-name x) name)
1371 (eq (sb!c::compiled-debug-function-kind x) nil)))
1372 (get-debug-info-function-map
1373 (%code-debug-info component)))))
1375 (make-compiled-debug-function res component)
1376 ;; KLUDGE: comment from CMU CL:
1377 ;; This used to be the non-interpreted branch, but
1378 ;; William wrote it to return the debug-fun of fun's XEP
1379 ;; instead of fun's debug-fun. The above code does this
1380 ;; more correctly, but it doesn't get or eliminate all
1381 ;; appropriate cases. It mostly works, and probably
1382 ;; works for all named functions anyway.
1384 (debug-function-from-pc component
1385 (* (- (function-word-offset fun)
1386 (get-header-data component))
1387 sb!vm:word-bytes)))))))
1389 ;;; Return the kind of the function, which is one of :OPTIONAL,
1390 ;;; :EXTERNAL, TOP-level, :CLEANUP, or NIL.
1391 (defun debug-function-kind (debug-function)
1392 ;; FIXME: This "is one of" information should become part of the function
1393 ;; declamation, not just a doc string
1394 (etypecase debug-function
1395 (compiled-debug-function
1396 (sb!c::compiled-debug-function-kind
1397 (compiled-debug-function-compiler-debug-fun debug-function)))
1398 (bogus-debug-function
1401 ;;; Is there any variable information for DEBUG-FUNCTION?
1402 (defun debug-var-info-available (debug-function)
1403 (not (not (debug-function-debug-vars debug-function))))
1405 ;;; Return a list of debug-vars in debug-function having the same name
1406 ;;; and package as symbol. If symbol is uninterned, then this returns
1407 ;;; a list of debug-vars without package names and with the same name
1408 ;;; as symbol. The result of this function is limited to the
1409 ;;; availability of variable information in debug-function; for
1410 ;;; example, possibly DEBUG-FUNCTION only knows about its arguments.
1411 (defun debug-function-symbol-variables (debug-function symbol)
1412 (let ((vars (ambiguous-debug-vars debug-function (symbol-name symbol)))
1413 (package (and (symbol-package symbol)
1414 (package-name (symbol-package symbol)))))
1415 (delete-if (if (stringp package)
1417 (let ((p (debug-var-package-name var)))
1418 (or (not (stringp p))
1419 (string/= p package))))
1421 (stringp (debug-var-package-name var))))
1424 ;;; Return a list of debug-vars in debug-function whose names contain
1425 ;;; name-prefix-string as an intial substring. The result of this
1426 ;;; function is limited to the availability of variable information in
1427 ;;; debug-function; for example, possibly debug-function only knows
1428 ;;; about its arguments.
1429 (defun ambiguous-debug-vars (debug-function name-prefix-string)
1430 (declare (simple-string name-prefix-string))
1431 (let ((variables (debug-function-debug-vars debug-function)))
1432 (declare (type (or null simple-vector) variables))
1434 (let* ((len (length variables))
1435 (prefix-len (length name-prefix-string))
1436 (pos (find-variable name-prefix-string variables len))
1439 ;; Find names from pos to variable's len that contain prefix.
1440 (do ((i pos (1+ i)))
1442 (let* ((var (svref variables i))
1443 (name (debug-var-symbol-name var))
1444 (name-len (length name)))
1445 (declare (simple-string name))
1446 (when (/= (or (string/= name-prefix-string name
1447 :end1 prefix-len :end2 name-len)
1452 (setq res (nreverse res)))
1455 ;;; This returns a position in variables for one containing name as an
1456 ;;; initial substring. End is the length of variables if supplied.
1457 (defun find-variable (name variables &optional end)
1458 (declare (simple-vector variables)
1459 (simple-string name))
1460 (let ((name-len (length name)))
1461 (position name variables
1462 :test #'(lambda (x y)
1463 (let* ((y (debug-var-symbol-name y))
1465 (declare (simple-string y))
1466 (and (>= y-len name-len)
1467 (string= x y :end1 name-len :end2 name-len))))
1468 :end (or end (length variables)))))
1470 ;;; Return a list representing the lambda-list for DEBUG-FUNCTION. The
1471 ;;; list has the following structure:
1472 ;;; (required-var1 required-var2
1474 ;;; (:optional var3 suppliedp-var4)
1475 ;;; (:optional var5)
1477 ;;; (:rest var6) (:rest var7)
1479 ;;; (:keyword keyword-symbol var8 suppliedp-var9)
1480 ;;; (:keyword keyword-symbol var10)
1483 ;;; Each VARi is a DEBUG-VAR; however it may be the symbol :DELETED if
1484 ;;; it is unreferenced in DEBUG-FUNCTION. This signals a
1485 ;;; LAMBDA-LIST-UNAVAILABLE condition when there is no argument list
1487 (defun debug-function-lambda-list (debug-function)
1488 (etypecase debug-function
1489 (compiled-debug-function
1490 (compiled-debug-function-lambda-list debug-function))
1491 (bogus-debug-function
1494 ;;; Note: If this has to compute the lambda list, it caches it in
1496 (defun compiled-debug-function-lambda-list (debug-function)
1497 (let ((lambda-list (debug-function-%lambda-list debug-function)))
1498 (cond ((eq lambda-list :unparsed)
1499 (multiple-value-bind (args argsp)
1500 (parse-compiled-debug-function-lambda-list debug-function)
1501 (setf (debug-function-%lambda-list debug-function) args)
1504 (debug-signal 'lambda-list-unavailable
1505 :debug-function debug-function))))
1507 ((bogus-debug-function-p debug-function)
1509 ((sb!c::compiled-debug-function-arguments
1510 (compiled-debug-function-compiler-debug-fun
1512 ;; If the packed information is there (whether empty or not) as
1513 ;; opposed to being nil, then returned our cached value (nil).
1516 ;; Our cached value is nil, and the packed lambda-list information
1517 ;; is nil, so we don't have anything available.
1518 (debug-signal 'lambda-list-unavailable
1519 :debug-function debug-function)))))
1521 ;;; COMPILED-DEBUG-FUNCTION-LAMBDA-LIST calls this when a
1522 ;;; compiled-debug-function has no lambda-list information cached. It
1523 ;;; returns the lambda-list as the first value and whether there was
1524 ;;; any argument information as the second value. Therefore, nil and t
1525 ;;; means there were no arguments, but nil and nil means there was no
1526 ;;; argument information.
1527 (defun parse-compiled-debug-function-lambda-list (debug-function)
1528 (let ((args (sb!c::compiled-debug-function-arguments
1529 (compiled-debug-function-compiler-debug-fun
1535 (values (coerce (debug-function-debug-vars debug-function) 'list)
1538 (let ((vars (debug-function-debug-vars debug-function))
1543 (declare (type (or null simple-vector) vars))
1545 (when (>= i len) (return))
1546 (let ((ele (aref args i)))
1551 ;; Deleted required arg at beginning of args array.
1552 (push :deleted res))
1553 (sb!c::optional-args
1556 ;; SUPPLIED-P var immediately following keyword or
1557 ;; optional. Stick the extra var in the result
1558 ;; element representing the keyword or optional,
1559 ;; which is the previous one.
1561 (list (compiled-debug-function-lambda-list-var
1562 args (incf i) vars))))
1565 (compiled-debug-function-lambda-list-var
1566 args (incf i) vars))
1569 ;; Just ignore the fact that the next two args are
1570 ;; the &MORE arg context and count, and act like they
1571 ;; are regular arguments.
1575 (push (list :keyword
1577 (compiled-debug-function-lambda-list-var
1578 args (incf i) vars))
1581 ;; We saw an optional marker, so the following
1582 ;; non-symbols are indexes indicating optional
1584 (push (list :optional (svref vars ele)) res))
1586 ;; Required arg at beginning of args array.
1587 (push (svref vars ele) res))))
1589 (values (nreverse res) t))))))
1591 ;;; This is used in COMPILED-DEBUG-FUNCTION-LAMBDA-LIST.
1592 (defun compiled-debug-function-lambda-list-var (args i vars)
1593 (declare (type (simple-array * (*)) args)
1594 (simple-vector vars))
1595 (let ((ele (aref args i)))
1596 (cond ((not (symbolp ele)) (svref vars ele))
1597 ((eq ele 'sb!c::deleted) :deleted)
1598 (t (error "malformed arguments description")))))
1600 (defun compiled-debug-function-debug-info (debug-fun)
1601 (%code-debug-info (compiled-debug-function-component debug-fun)))
1603 ;;;; unpacking variable and basic block data
1605 (defvar *parsing-buffer*
1606 (make-array 20 :adjustable t :fill-pointer t))
1607 (defvar *other-parsing-buffer*
1608 (make-array 20 :adjustable t :fill-pointer t))
1609 ;;; PARSE-DEBUG-BLOCKS, PARSE-DEBUG-VARS and UNCOMPACT-FUNCTION-MAP
1610 ;;; use this to unpack binary encoded information. It returns the
1611 ;;; values returned by the last form in body.
1613 ;;; This binds buffer-var to *parsing-buffer*, makes sure it starts at
1614 ;;; element zero, and makes sure if we unwind, we nil out any set
1615 ;;; elements for GC purposes.
1617 ;;; This also binds other-var to *other-parsing-buffer* when it is
1618 ;;; supplied, making sure it starts at element zero and that we nil
1619 ;;; out any elements if we unwind.
1621 ;;; This defines the local macro RESULT that takes a buffer, copies
1622 ;;; its elements to a resulting simple-vector, nil's out elements, and
1623 ;;; restarts the buffer at element zero. RESULT returns the
1625 (eval-when (:compile-toplevel :execute)
1626 (sb!xc:defmacro with-parsing-buffer ((buffer-var &optional other-var)
1628 (let ((len (gensym))
1631 (let ((,buffer-var *parsing-buffer*)
1632 ,@(if other-var `((,other-var *other-parsing-buffer*))))
1633 (setf (fill-pointer ,buffer-var) 0)
1634 ,@(if other-var `((setf (fill-pointer ,other-var) 0)))
1635 (macrolet ((result (buf)
1636 `(let* ((,',len (length ,buf))
1637 (,',res (make-array ,',len)))
1638 (replace ,',res ,buf :end1 ,',len :end2 ,',len)
1639 (fill ,buf nil :end ,',len)
1640 (setf (fill-pointer ,buf) 0)
1643 (fill *parsing-buffer* nil)
1644 ,@(if other-var `((fill *other-parsing-buffer* nil))))))
1647 ;;; The argument is a debug internals structure. This returns the
1648 ;;; debug-blocks for debug-function, regardless of whether we have
1649 ;;; unpacked them yet. It signals a no-debug-blocks condition if it
1650 ;;; can't return the blocks.
1651 (defun debug-function-debug-blocks (debug-function)
1652 (let ((blocks (debug-function-blocks debug-function)))
1653 (cond ((eq blocks :unparsed)
1654 (setf (debug-function-blocks debug-function)
1655 (parse-debug-blocks debug-function))
1656 (unless (debug-function-blocks debug-function)
1657 (debug-signal 'no-debug-blocks
1658 :debug-function debug-function))
1659 (debug-function-blocks debug-function))
1662 (debug-signal 'no-debug-blocks
1663 :debug-function debug-function)))))
1665 ;;; This returns a SIMPLE-VECTOR of DEBUG-BLOCKs or NIL. NIL indicates
1666 ;;; there was no basic block information.
1667 (defun parse-debug-blocks (debug-function)
1668 (etypecase debug-function
1669 (compiled-debug-function
1670 (parse-compiled-debug-blocks debug-function))
1671 (bogus-debug-function
1672 (debug-signal 'no-debug-blocks :debug-function debug-function))))
1674 ;;; This does some of the work of PARSE-DEBUG-BLOCKS.
1675 (defun parse-compiled-debug-blocks (debug-function)
1676 (let* ((debug-fun (compiled-debug-function-compiler-debug-fun
1678 (var-count (length (debug-function-debug-vars debug-function)))
1679 (blocks (sb!c::compiled-debug-function-blocks debug-fun))
1680 ;; KLUDGE: 8 is a hard-wired constant in the compiler for the
1681 ;; element size of the packed binary representation of the
1683 (live-set-len (ceiling var-count 8))
1684 (tlf-number (sb!c::compiled-debug-function-tlf-number debug-fun)))
1685 (unless blocks (return-from parse-compiled-debug-blocks nil))
1686 (macrolet ((aref+ (a i) `(prog1 (aref ,a ,i) (incf ,i))))
1687 (with-parsing-buffer (blocks-buffer locations-buffer)
1689 (len (length blocks))
1692 (when (>= i len) (return))
1693 (let ((succ-and-flags (aref+ blocks i))
1695 (declare (type (unsigned-byte 8) succ-and-flags)
1697 (dotimes (k (ldb sb!c::compiled-debug-block-nsucc-byte
1699 (push (sb!c::read-var-integer blocks i) successors))
1701 (dotimes (k (sb!c::read-var-integer blocks i)
1702 (result locations-buffer))
1703 (let ((kind (svref sb!c::*compiled-code-location-kinds*
1706 (sb!c::read-var-integer blocks i)))
1707 (tlf-offset (or tlf-number
1708 (sb!c::read-var-integer blocks
1710 (form-number (sb!c::read-var-integer blocks i))
1711 (live-set (sb!c::read-packed-bit-vector
1712 live-set-len blocks i)))
1713 (vector-push-extend (make-known-code-location
1714 pc debug-function tlf-offset
1715 form-number live-set kind)
1717 (setf last-pc pc))))
1718 (block (make-compiled-debug-block
1719 locations successors
1721 sb!c::compiled-debug-block-elsewhere-p
1722 succ-and-flags))))))
1723 (vector-push-extend block blocks-buffer)
1724 (dotimes (k (length locations))
1725 (setf (code-location-%debug-block (svref locations k))
1727 (let ((res (result blocks-buffer)))
1728 (declare (simple-vector res))
1729 (dotimes (i (length res))
1730 (let* ((block (svref res i))
1732 (dolist (ele (debug-block-successors block))
1733 (push (svref res ele) succs))
1734 (setf (debug-block-successors block) succs)))
1737 ;;; The argument is a debug internals structure. This returns NIL if
1738 ;;; there is no variable information. It returns an empty
1739 ;;; simple-vector if there were no locals in the function. Otherwise
1740 ;;; it returns a SIMPLE-VECTOR of DEBUG-VARs.
1741 (defun debug-function-debug-vars (debug-function)
1742 (let ((vars (debug-function-%debug-vars debug-function)))
1743 (if (eq vars :unparsed)
1744 (setf (debug-function-%debug-vars debug-function)
1745 (etypecase debug-function
1746 (compiled-debug-function
1747 (parse-compiled-debug-vars debug-function))
1748 (bogus-debug-function nil)))
1751 ;;; VARS is the parsed variables for a minimal debug function. We need
1752 ;;; to assign names of the form ARG-NNN. We must pad with leading
1753 ;;; zeros, since the arguments must be in alphabetical order.
1754 (defun assign-minimal-var-names (vars)
1755 (declare (simple-vector vars))
1756 (let* ((len (length vars))
1757 (width (length (format nil "~D" (1- len)))))
1759 (setf (compiled-debug-var-symbol (svref vars i))
1760 (intern (format nil "ARG-~V,'0D" width i)
1761 ;; KLUDGE: It's somewhat nasty to have a bare
1762 ;; package name string here. It would be
1763 ;; nicer to have #.(FIND-PACKAGE "SB!DEBUG")
1764 ;; instead, since then at least it would transform
1765 ;; correctly under package renaming and stuff.
1766 ;; However, genesis can't handle dumped packages..
1769 ;; FIXME: Maybe this could be fixed by moving the
1770 ;; whole debug-int.lisp file to warm init? (after
1771 ;; which dumping a #.(FIND-PACKAGE ..) expression
1772 ;; would work fine) If this is possible, it would
1773 ;; probably be a good thing, since minimizing the
1774 ;; amount of stuff in cold init is basically good.
1775 (or (find-package "SB-DEBUG")
1776 (find-package "SB!DEBUG")))))))
1778 ;;; Parse the packed representation of DEBUG-VARs from
1779 ;;; DEBUG-FUNCTION's SB!C::COMPILED-DEBUG-FUNCTION, returning a vector
1780 ;;; of DEBUG-VARs, or NIL if there was no information to parse.
1781 (defun parse-compiled-debug-vars (debug-function)
1782 (let* ((cdebug-fun (compiled-debug-function-compiler-debug-fun
1784 (packed-vars (sb!c::compiled-debug-function-variables cdebug-fun))
1785 (args-minimal (eq (sb!c::compiled-debug-function-arguments cdebug-fun)
1789 (buffer (make-array 0 :fill-pointer 0 :adjustable t)))
1790 ((>= i (length packed-vars))
1791 (let ((result (coerce buffer 'simple-vector)))
1793 (assign-minimal-var-names result))
1795 (flet ((geti () (prog1 (aref packed-vars i) (incf i))))
1796 (let* ((flags (geti))
1797 (minimal (logtest sb!c::compiled-debug-var-minimal-p flags))
1798 (deleted (logtest sb!c::compiled-debug-var-deleted-p flags))
1799 (live (logtest sb!c::compiled-debug-var-environment-live
1801 (save (logtest sb!c::compiled-debug-var-save-loc-p flags))
1802 (symbol (if minimal nil (geti)))
1803 (id (if (logtest sb!c::compiled-debug-var-id-p flags)
1806 (sc-offset (if deleted 0 (geti)))
1807 (save-sc-offset (if save (geti) nil)))
1808 (aver (not (and args-minimal (not minimal))))
1809 (vector-push-extend (make-compiled-debug-var symbol
1816 ;;;; unpacking minimal debug functions
1818 (eval-when (:compile-toplevel :execute)
1820 ;;; sleazoid "macro" to keep our indentation sane in UNCOMPACT-FUNCTION-MAP
1821 (sb!xc:defmacro make-uncompacted-debug-fun ()
1822 '(sb!c::make-compiled-debug-function
1824 (let ((base (ecase (ldb sb!c::minimal-debug-function-name-style-byte
1826 (#.sb!c::minimal-debug-function-name-symbol
1827 (intern (sb!c::read-var-string map i)
1828 (sb!c::compiled-debug-info-package info)))
1829 (#.sb!c::minimal-debug-function-name-packaged
1830 (let ((pkg (sb!c::read-var-string map i)))
1831 (intern (sb!c::read-var-string map i) pkg)))
1832 (#.sb!c::minimal-debug-function-name-uninterned
1833 (make-symbol (sb!c::read-var-string map i)))
1834 (#.sb!c::minimal-debug-function-name-component
1835 (sb!c::compiled-debug-info-name info)))))
1836 (if (logtest flags sb!c::minimal-debug-function-setf-bit)
1839 :kind (svref sb!c::*minimal-debug-function-kinds*
1840 (ldb sb!c::minimal-debug-function-kind-byte options))
1843 (let ((len (sb!c::read-var-integer map i)))
1844 (prog1 (subseq map i (+ i len))
1846 :arguments (when vars-p :minimal)
1848 (ecase (ldb sb!c::minimal-debug-function-returns-byte options)
1849 (#.sb!c::minimal-debug-function-returns-standard
1851 (#.sb!c::minimal-debug-function-returns-fixed
1853 (#.sb!c::minimal-debug-function-returns-specified
1854 (with-parsing-buffer (buf)
1855 (dotimes (idx (sb!c::read-var-integer map i))
1856 (vector-push-extend (sb!c::read-var-integer map i) buf))
1858 :return-pc (sb!c::read-var-integer map i)
1859 :old-fp (sb!c::read-var-integer map i)
1860 :nfp (when (logtest flags sb!c::minimal-debug-function-nfp-bit)
1861 (sb!c::read-var-integer map i))
1864 (setq code-start-pc (+ code-start-pc (sb!c::read-var-integer map i)))
1865 (+ code-start-pc (sb!c::read-var-integer map i)))
1867 (setq elsewhere-pc (+ elsewhere-pc (sb!c::read-var-integer map i)))))
1871 ;;; Return a normal function map derived from a minimal debug info
1872 ;;; function map. This involves looping parsing
1873 ;;; minimal-debug-functions and then building a vector out of them.
1875 ;;; FIXME: This and its helper macro just above become dead code now
1876 ;;; that we no longer use compacted function maps.
1877 (defun uncompact-function-map (info)
1878 (declare (type sb!c::compiled-debug-info info))
1880 ;; (This is stubified until we solve the problem of representing
1881 ;; debug information in a way which plays nicely with package renaming.)
1882 (error "FIXME: dead code UNCOMPACT-FUNCTION-MAP (was stub)")
1884 (let* ((map (sb!c::compiled-debug-info-function-map info))
1889 (declare (type (simple-array (unsigned-byte 8) (*)) map))
1890 (sb!int:collect ((res))
1892 (when (= i len) (return))
1893 (let* ((options (prog1 (aref map i) (incf i)))
1894 (flags (prog1 (aref map i) (incf i)))
1895 (vars-p (logtest flags
1896 sb!c::minimal-debug-function-variables-bit))
1897 (dfun (make-uncompacted-debug-fun)))
1901 (coerce (cdr (res)) 'simple-vector))))
1903 ;;; a map from minimal DEBUG-INFO function maps to unpacked
1904 ;;; versions thereof
1905 (defvar *uncompacted-function-maps* (make-hash-table :test 'eq))
1907 ;;; Return a FUNCTION-MAP for a given COMPILED-DEBUG-info object. If
1908 ;;; the info is minimal, and has not been parsed, then parse it.
1910 ;;; FIXME: Now that we no longer use the MINIMAL-DEBUG-FUNCTION
1911 ;;; representation, calls to this function can be replaced by calls to
1912 ;;; the bare COMPILED-DEBUG-INFO-FUNCTION-MAP slot accessor function,
1913 ;;; and this function and everything it calls become dead code which
1915 (defun get-debug-info-function-map (info)
1916 (declare (type sb!c::compiled-debug-info info))
1917 (let ((map (sb!c::compiled-debug-info-function-map info)))
1918 (if (simple-vector-p map)
1920 (or (gethash map *uncompacted-function-maps*)
1921 (setf (gethash map *uncompacted-function-maps*)
1922 (uncompact-function-map info))))))
1926 ;;; If we're sure of whether code-location is known, return T or NIL.
1927 ;;; If we're :UNSURE, then try to fill in the code-location's slots.
1928 ;;; This determines whether there is any debug-block information, and
1929 ;;; if code-location is known.
1931 ;;; ??? IF this conses closures every time it's called, then break off the
1932 ;;; :UNSURE part to get the HANDLER-CASE into another function.
1933 (defun code-location-unknown-p (basic-code-location)
1934 (ecase (code-location-%unknown-p basic-code-location)
1938 (setf (code-location-%unknown-p basic-code-location)
1939 (handler-case (not (fill-in-code-location basic-code-location))
1940 (no-debug-blocks () t))))))
1942 ;;; Return the DEBUG-BLOCK containing code-location if it is available.
1943 ;;; Some debug policies inhibit debug-block information, and if none
1944 ;;; is available, then this signals a NO-DEBUG-BLOCKS condition.
1945 (defun code-location-debug-block (basic-code-location)
1946 (let ((block (code-location-%debug-block basic-code-location)))
1947 (if (eq block :unparsed)
1948 (etypecase basic-code-location
1949 (compiled-code-location
1950 (compute-compiled-code-location-debug-block basic-code-location))
1951 ;; (There used to be more cases back before sbcl-0.7.0, when
1952 ;; we did special tricks to debug the IR1 interpreter.)
1956 ;;; Store and return BASIC-CODE-LOCATION's debug-block. We determines
1957 ;;; the correct one using the code-location's pc. We use
1958 ;;; DEBUG-FUNCTION-DEBUG-BLOCKS to return the cached block information
1959 ;;; or signal a NO-DEBUG-BLOCKS condition. The blocks are sorted by
1960 ;;; their first code-location's pc, in ascending order. Therefore, as
1961 ;;; soon as we find a block that starts with a pc greater than
1962 ;;; basic-code-location's pc, we know the previous block contains the
1963 ;;; pc. If we get to the last block, then the code-location is either
1964 ;;; in the second to last block or the last block, and we have to be
1965 ;;; careful in determining this since the last block could be code at
1966 ;;; the end of the function. We have to check for the last block being
1967 ;;; code first in order to see how to compare the code-location's pc.
1968 (defun compute-compiled-code-location-debug-block (basic-code-location)
1969 (let* ((pc (compiled-code-location-pc basic-code-location))
1970 (debug-function (code-location-debug-function
1971 basic-code-location))
1972 (blocks (debug-function-debug-blocks debug-function))
1973 (len (length blocks)))
1974 (declare (simple-vector blocks))
1975 (setf (code-location-%debug-block basic-code-location)
1981 (let ((last (svref blocks end)))
1983 ((debug-block-elsewhere-p last)
1985 (sb!c::compiled-debug-function-elsewhere-pc
1986 (compiled-debug-function-compiler-debug-fun
1988 (svref blocks (1- end))
1991 (compiled-code-location-pc
1992 (svref (compiled-debug-block-code-locations last)
1994 (svref blocks (1- end)))
1996 (declare (type sb!c::index i end))
1998 (compiled-code-location-pc
1999 (svref (compiled-debug-block-code-locations
2002 (return (svref blocks (1- i)))))))))
2004 ;;; Return the CODE-LOCATION's DEBUG-SOURCE.
2005 (defun code-location-debug-source (code-location)
2006 (etypecase code-location
2007 (compiled-code-location
2008 (let* ((info (compiled-debug-function-debug-info
2009 (code-location-debug-function code-location)))
2010 (sources (sb!c::compiled-debug-info-source info))
2011 (len (length sources)))
2012 (declare (list sources))
2014 (debug-signal 'no-debug-blocks :debug-function
2015 (code-location-debug-function code-location)))
2018 (do ((prev sources src)
2019 (src (cdr sources) (cdr src))
2020 (offset (code-location-top-level-form-offset code-location)))
2021 ((null src) (car prev))
2022 (when (< offset (sb!c::debug-source-source-root (car src)))
2023 (return (car prev)))))))
2024 ;; (There used to be more cases back before sbcl-0.7.0, when we
2025 ;; did special tricks to debug the IR1 interpreter.)
2028 ;;; Returns the number of top-level forms before the one containing
2029 ;;; CODE-LOCATION as seen by the compiler in some compilation unit. (A
2030 ;;; compilation unit is not necessarily a single file, see the section
2031 ;;; on debug-sources.)
2032 (defun code-location-top-level-form-offset (code-location)
2033 (when (code-location-unknown-p code-location)
2034 (error 'unknown-code-location :code-location code-location))
2035 (let ((tlf-offset (code-location-%tlf-offset code-location)))
2036 (cond ((eq tlf-offset :unparsed)
2037 (etypecase code-location
2038 (compiled-code-location
2039 (unless (fill-in-code-location code-location)
2040 ;; This check should be unnecessary. We're missing
2041 ;; debug info the compiler should have dumped.
2042 (error "internal error: unknown code location"))
2043 (code-location-%tlf-offset code-location))
2044 ;; (There used to be more cases back before sbcl-0.7.0,,
2045 ;; when we did special tricks to debug the IR1
2050 ;;; Return the number of the form corresponding to CODE-LOCATION. The
2051 ;;; form number is derived by a walking the subforms of a top-level
2052 ;;; form in depth-first order.
2053 (defun code-location-form-number (code-location)
2054 (when (code-location-unknown-p code-location)
2055 (error 'unknown-code-location :code-location code-location))
2056 (let ((form-num (code-location-%form-number code-location)))
2057 (cond ((eq form-num :unparsed)
2058 (etypecase code-location
2059 (compiled-code-location
2060 (unless (fill-in-code-location code-location)
2061 ;; This check should be unnecessary. We're missing
2062 ;; debug info the compiler should have dumped.
2063 (error "internal error: unknown code location"))
2064 (code-location-%form-number code-location))
2065 ;; (There used to be more cases back before sbcl-0.7.0,,
2066 ;; when we did special tricks to debug the IR1
2071 ;;; Return the kind of CODE-LOCATION, one of:
2072 ;;; :INTERPRETED, :UNKNOWN-RETURN, :KNOWN-RETURN, :INTERNAL-ERROR,
2073 ;;; :NON-LOCAL-EXIT, :BLOCK-START, :CALL-SITE, :SINGLE-VALUE-RETURN,
2074 ;;; :NON-LOCAL-ENTRY
2075 (defun code-location-kind (code-location)
2076 (when (code-location-unknown-p code-location)
2077 (error 'unknown-code-location :code-location code-location))
2078 (etypecase code-location
2079 (compiled-code-location
2080 (let ((kind (compiled-code-location-kind code-location)))
2081 (cond ((not (eq kind :unparsed)) kind)
2082 ((not (fill-in-code-location code-location))
2083 ;; This check should be unnecessary. We're missing
2084 ;; debug info the compiler should have dumped.
2085 (error "internal error: unknown code location"))
2087 (compiled-code-location-kind code-location)))))
2088 ;; (There used to be more cases back before sbcl-0.7.0,,
2089 ;; when we did special tricks to debug the IR1
2093 ;;; This returns CODE-LOCATION's live-set if it is available. If
2094 ;;; there is no debug-block information, this returns NIL.
2095 (defun compiled-code-location-live-set (code-location)
2096 (if (code-location-unknown-p code-location)
2098 (let ((live-set (compiled-code-location-%live-set code-location)))
2099 (cond ((eq live-set :unparsed)
2100 (unless (fill-in-code-location code-location)
2101 ;; This check should be unnecessary. We're missing
2102 ;; debug info the compiler should have dumped.
2104 ;; FIXME: This error and comment happen over and over again.
2105 ;; Make them a shared function.
2106 (error "internal error: unknown code location"))
2107 (compiled-code-location-%live-set code-location))
2110 ;;; true if OBJ1 and OBJ2 are the same place in the code
2111 (defun code-location= (obj1 obj2)
2113 (compiled-code-location
2115 (compiled-code-location
2116 (and (eq (code-location-debug-function obj1)
2117 (code-location-debug-function obj2))
2118 (sub-compiled-code-location= obj1 obj2)))
2119 ;; (There used to be more cases back before sbcl-0.7.0,,
2120 ;; when we did special tricks to debug the IR1
2123 ;; (There used to be more cases back before sbcl-0.7.0,,
2124 ;; when we did special tricks to debug the IR1
2127 (defun sub-compiled-code-location= (obj1 obj2)
2128 (= (compiled-code-location-pc obj1)
2129 (compiled-code-location-pc obj2)))
2131 ;;; Fill in CODE-LOCATION's :UNPARSED slots, returning T or NIL
2132 ;;; depending on whether the code-location was known in its
2133 ;;; debug-function's debug-block information. This may signal a
2134 ;;; NO-DEBUG-BLOCKS condition due to DEBUG-FUNCTION-DEBUG-BLOCKS, and
2135 ;;; it assumes the %UNKNOWN-P slot is already set or going to be set.
2136 (defun fill-in-code-location (code-location)
2137 (declare (type compiled-code-location code-location))
2138 (let* ((debug-function (code-location-debug-function code-location))
2139 (blocks (debug-function-debug-blocks debug-function)))
2140 (declare (simple-vector blocks))
2141 (dotimes (i (length blocks) nil)
2142 (let* ((block (svref blocks i))
2143 (locations (compiled-debug-block-code-locations block)))
2144 (declare (simple-vector locations))
2145 (dotimes (j (length locations))
2146 (let ((loc (svref locations j)))
2147 (when (sub-compiled-code-location= code-location loc)
2148 (setf (code-location-%debug-block code-location) block)
2149 (setf (code-location-%tlf-offset code-location)
2150 (code-location-%tlf-offset loc))
2151 (setf (code-location-%form-number code-location)
2152 (code-location-%form-number loc))
2153 (setf (compiled-code-location-%live-set code-location)
2154 (compiled-code-location-%live-set loc))
2155 (setf (compiled-code-location-kind code-location)
2156 (compiled-code-location-kind loc))
2157 (return-from fill-in-code-location t))))))))
2159 ;;;; operations on DEBUG-BLOCKs
2161 ;;; Execute FORMS in a context with CODE-VAR bound to each
2162 ;;; CODE-LOCATION in DEBUG-BLOCK, and return the value of RESULT.
2163 (defmacro do-debug-block-locations ((code-var debug-block &optional result)
2165 (let ((code-locations (gensym))
2167 `(let ((,code-locations (debug-block-code-locations ,debug-block)))
2168 (declare (simple-vector ,code-locations))
2169 (dotimes (,i (length ,code-locations) ,result)
2170 (let ((,code-var (svref ,code-locations ,i)))
2173 ;;; Return the name of the function represented by DEBUG-FUNCTION.
2174 ;;; This may be a string or a cons; do not assume it is a symbol.
2175 (defun debug-block-function-name (debug-block)
2176 (etypecase debug-block
2177 (compiled-debug-block
2178 (let ((code-locs (compiled-debug-block-code-locations debug-block)))
2179 (declare (simple-vector code-locs))
2180 (if (zerop (length code-locs))
2181 "??? Can't get name of debug-block's function."
2182 (debug-function-name
2183 (code-location-debug-function (svref code-locs 0))))))
2184 ;; (There used to be more cases back before sbcl-0.7.0, when we
2185 ;; did special tricks to debug the IR1 interpreter.)
2188 (defun debug-block-code-locations (debug-block)
2189 (etypecase debug-block
2190 (compiled-debug-block
2191 (compiled-debug-block-code-locations debug-block))
2192 ;; (There used to be more cases back before sbcl-0.7.0, when we
2193 ;; did special tricks to debug the IR1 interpreter.)
2196 ;;;; operations on debug variables
2198 (defun debug-var-symbol-name (debug-var)
2199 (symbol-name (debug-var-symbol debug-var)))
2201 ;;; FIXME: Make sure that this isn't called anywhere that it wouldn't
2202 ;;; be acceptable to have NIL returned, or that it's only called on
2203 ;;; DEBUG-VARs whose symbols have non-NIL packages.
2204 (defun debug-var-package-name (debug-var)
2205 (package-name (symbol-package (debug-var-symbol debug-var))))
2207 ;;; Return the value stored for DEBUG-VAR in frame, or if the value is
2208 ;;; not :VALID, then signal an INVALID-VALUE error.
2209 (defun debug-var-valid-value (debug-var frame)
2210 (unless (eq (debug-var-validity debug-var (frame-code-location frame))
2212 (error 'invalid-value :debug-var debug-var :frame frame))
2213 (debug-var-value debug-var frame))
2215 ;;; Returns the value stored for DEBUG-VAR in frame. The value may be
2216 ;;; invalid. This is SETFable.
2217 (defun debug-var-value (debug-var frame)
2218 (etypecase debug-var
2220 (aver (typep frame 'compiled-frame))
2221 (let ((res (access-compiled-debug-var-slot debug-var frame)))
2222 (if (indirect-value-cell-p res)
2223 (value-cell-ref res)
2225 ;; (This function used to be more interesting, with more type
2226 ;; cases here, before the IR1 interpreter went away. It might
2227 ;; become more interesting again if we ever try to generalize the
2228 ;; CMU CL POSSIBLY-AN-INTERPRETED-FRAME thing to elide
2229 ;; internal-to-the-byte-interpreter debug frames the way that CMU
2230 ;; CL elided internal-to-the-IR1-interpreter debug frames.)
2233 ;;; This returns what is stored for the variable represented by
2234 ;;; DEBUG-VAR relative to the FRAME. This may be an indirect value
2235 ;;; cell if the variable is both closed over and set.
2236 (defun access-compiled-debug-var-slot (debug-var frame)
2237 (declare (optimize (speed 1)))
2238 (let ((escaped (compiled-frame-escaped frame)))
2240 (sub-access-debug-var-slot
2241 (frame-pointer frame)
2242 (compiled-debug-var-sc-offset debug-var)
2244 (sub-access-debug-var-slot
2245 (frame-pointer frame)
2246 (or (compiled-debug-var-save-sc-offset debug-var)
2247 (compiled-debug-var-sc-offset debug-var))))))
2249 ;;; a helper function for working with possibly-invalid values:
2250 ;;; Do (MAKE-LISP-OBJ VAL) only if the value looks valid.
2252 ;;; (Such values can arise in registers on machines with conservative
2253 ;;; GC, and might also arise in debug variable locations when
2254 ;;; those variables are invalid.)
2255 (defun make-valid-lisp-obj (val)
2256 (/show0 "entering MAKE-VALID-LISP-OBJ, VAL=..")
2257 #!+sb-show (/hexstr val)
2260 (zerop (logand val 3))
2262 (and (zerop (logand val #xffff0000)) ; Top bits zero
2263 (= (logand val #xff) sb!vm:base-char-type)) ; Char tag
2265 (= val sb!vm:unbound-marker-type)
2268 ;; Check that the pointer is valid. XXX Could do a better
2269 ;; job. FIXME: e.g. by calling out to an is_valid_pointer
2270 ;; routine in the C runtime support code
2271 (or (< sb!vm:read-only-space-start val
2272 (* sb!vm:*read-only-space-free-pointer*
2274 (< sb!vm:static-space-start val
2275 (* sb!vm:*static-space-free-pointer*
2277 (< sb!vm:dynamic-space-start val
2278 (sap-int (dynamic-space-free-pointer))))))
2283 (defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
2284 (macrolet ((with-escaped-value ((var) &body forms)
2286 (let ((,var (sb!vm:context-register
2288 (sb!c:sc-offset-offset sc-offset))))
2290 :invalid-value-for-unescaped-register-storage))
2291 (escaped-float-value (format)
2293 (sb!vm:context-float-register
2295 (sb!c:sc-offset-offset sc-offset)
2297 :invalid-value-for-unescaped-register-storage))
2298 (with-nfp ((var) &body body)
2299 `(let ((,var (if escaped
2301 (sb!vm:context-register escaped
2304 (sb!sys:sap-ref-sap fp (* sb!vm::nfp-save-offset
2307 (sb!vm::make-number-stack-pointer
2308 (sb!sys:sap-ref-32 fp (* sb!vm::nfp-save-offset
2309 sb!vm:word-bytes))))))
2311 (ecase (sb!c:sc-offset-scn sc-offset)
2312 ((#.sb!vm:any-reg-sc-number
2313 #.sb!vm:descriptor-reg-sc-number
2314 #!+rt #.sb!vm:word-pointer-reg-sc-number)
2315 (sb!sys:without-gcing
2316 (with-escaped-value (val) (sb!kernel:make-lisp-obj val))))
2318 (#.sb!vm:base-char-reg-sc-number
2319 (with-escaped-value (val)
2321 (#.sb!vm:sap-reg-sc-number
2322 (with-escaped-value (val)
2323 (sb!sys:int-sap val)))
2324 (#.sb!vm:signed-reg-sc-number
2325 (with-escaped-value (val)
2326 (if (logbitp (1- sb!vm:word-bits) val)
2327 (logior val (ash -1 sb!vm:word-bits))
2329 (#.sb!vm:unsigned-reg-sc-number
2330 (with-escaped-value (val)
2332 (#.sb!vm:non-descriptor-reg-sc-number
2333 (error "Local non-descriptor register access?"))
2334 (#.sb!vm:interior-reg-sc-number
2335 (error "Local interior register access?"))
2336 (#.sb!vm:single-reg-sc-number
2337 (escaped-float-value single-float))
2338 (#.sb!vm:double-reg-sc-number
2339 (escaped-float-value double-float))
2341 (#.sb!vm:long-reg-sc-number
2342 (escaped-float-value long-float))
2343 (#.sb!vm:complex-single-reg-sc-number
2346 (sb!vm:context-float-register
2347 escaped (sb!c:sc-offset-offset sc-offset) 'single-float)
2348 (sb!vm:context-float-register
2349 escaped (1+ (sb!c:sc-offset-offset sc-offset)) 'single-float))
2350 :invalid-value-for-unescaped-register-storage))
2351 (#.sb!vm:complex-double-reg-sc-number
2354 (sb!vm:context-float-register
2355 escaped (sb!c:sc-offset-offset sc-offset) 'double-float)
2356 (sb!vm:context-float-register
2357 escaped (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 2 #-sparc 1)
2359 :invalid-value-for-unescaped-register-storage))
2361 (#.sb!vm:complex-long-reg-sc-number
2364 (sb!vm:context-float-register
2365 escaped (sb!c:sc-offset-offset sc-offset) 'long-float)
2366 (sb!vm:context-float-register
2367 escaped (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4)
2369 :invalid-value-for-unescaped-register-storage))
2370 (#.sb!vm:single-stack-sc-number
2372 (sb!sys:sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset)
2373 sb!vm:word-bytes))))
2374 (#.sb!vm:double-stack-sc-number
2376 (sb!sys:sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset)
2377 sb!vm:word-bytes))))
2379 (#.sb!vm:long-stack-sc-number
2381 (sb!sys:sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset)
2382 sb!vm:word-bytes))))
2383 (#.sb!vm:complex-single-stack-sc-number
2386 (sb!sys:sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset)
2388 (sb!sys:sap-ref-single nfp (* (1+ (sb!c:sc-offset-offset sc-offset))
2389 sb!vm:word-bytes)))))
2390 (#.sb!vm:complex-double-stack-sc-number
2393 (sb!sys:sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset)
2395 (sb!sys:sap-ref-double nfp (* (+ (sb!c:sc-offset-offset sc-offset) 2)
2396 sb!vm:word-bytes)))))
2398 (#.sb!vm:complex-long-stack-sc-number
2401 (sb!sys:sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset)
2403 (sb!sys:sap-ref-long nfp (* (+ (sb!c:sc-offset-offset sc-offset)
2405 sb!vm:word-bytes)))))
2406 (#.sb!vm:control-stack-sc-number
2407 (sb!kernel:stack-ref fp (sb!c:sc-offset-offset sc-offset)))
2408 (#.sb!vm:base-char-stack-sc-number
2410 (code-char (sb!sys:sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
2411 sb!vm:word-bytes)))))
2412 (#.sb!vm:unsigned-stack-sc-number
2414 (sb!sys:sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
2415 sb!vm:word-bytes))))
2416 (#.sb!vm:signed-stack-sc-number
2418 (sb!sys:signed-sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
2419 sb!vm:word-bytes))))
2420 (#.sb!vm:sap-stack-sc-number
2422 (sb!sys:sap-ref-sap nfp (* (sb!c:sc-offset-offset sc-offset)
2423 sb!vm:word-bytes)))))))
2426 (defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
2427 (declare (type system-area-pointer fp))
2428 (/show0 "entering SUB-ACCESS-DEBUG-VAR-SLOT, FP,SC-OFFSET,ESCAPED=..")
2429 (/hexstr fp) (/hexstr sc-offset) (/hexstr escaped)
2430 (macrolet ((with-escaped-value ((var) &body forms)
2432 (let ((,var (sb!vm:context-register
2434 (sb!c:sc-offset-offset sc-offset))))
2435 (/show0 "in escaped case, ,VAR value=..")
2438 :invalid-value-for-unescaped-register-storage))
2439 (escaped-float-value (format)
2441 (sb!vm:context-float-register
2442 escaped (sb!c:sc-offset-offset sc-offset) ',format)
2443 :invalid-value-for-unescaped-register-storage))
2444 (escaped-complex-float-value (format)
2447 (sb!vm:context-float-register
2448 escaped (sb!c:sc-offset-offset sc-offset) ',format)
2449 (sb!vm:context-float-register
2450 escaped (1+ (sb!c:sc-offset-offset sc-offset)) ',format))
2451 :invalid-value-for-unescaped-register-storage)))
2452 (ecase (sb!c:sc-offset-scn sc-offset)
2453 ((#.sb!vm:any-reg-sc-number #.sb!vm:descriptor-reg-sc-number)
2454 (/show0 "case of ANY-REG-SC-NUMBER or DESCRIPTOR-REG-SC-NUMBER")
2456 (with-escaped-value (val)
2459 (make-valid-lisp-obj val))))
2460 (#.sb!vm:base-char-reg-sc-number
2461 (/show0 "case of BASE-CHAR-REG-SC-NUMBER")
2462 (with-escaped-value (val)
2464 (#.sb!vm:sap-reg-sc-number
2465 (/show0 "case of SAP-REG-SC-NUMBER")
2466 (with-escaped-value (val)
2468 (#.sb!vm:signed-reg-sc-number
2469 (/show0 "case of SIGNED-REG-SC-NUMBER")
2470 (with-escaped-value (val)
2471 (if (logbitp (1- sb!vm:word-bits) val)
2472 (logior val (ash -1 sb!vm:word-bits))
2474 (#.sb!vm:unsigned-reg-sc-number
2475 (/show0 "case of UNSIGNED-REG-SC-NUMBER")
2476 (with-escaped-value (val)
2478 (#.sb!vm:single-reg-sc-number
2479 (/show0 "case of SINGLE-REG-SC-NUMBER")
2480 (escaped-float-value single-float))
2481 (#.sb!vm:double-reg-sc-number
2482 (/show0 "case of DOUBLE-REG-SC-NUMBER")
2483 (escaped-float-value double-float))
2485 (#.sb!vm:long-reg-sc-number
2486 (/show0 "case of LONG-REG-SC-NUMBER")
2487 (escaped-float-value long-float))
2488 (#.sb!vm:complex-single-reg-sc-number
2489 (/show0 "case of COMPLEX-SINGLE-REG-SC-NUMBER")
2490 (escaped-complex-float-value single-float))
2491 (#.sb!vm:complex-double-reg-sc-number
2492 (/show0 "case of COMPLEX-DOUBLE-REG-SC-NUMBER")
2493 (escaped-complex-float-value double-float))
2495 (#.sb!vm:complex-long-reg-sc-number
2496 (/show0 "case of COMPLEX-LONG-REG-SC-NUMBER")
2497 (escaped-complex-float-value long-float))
2498 (#.sb!vm:single-stack-sc-number
2499 (/show0 "case of SINGLE-STACK-SC-NUMBER")
2500 (sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2501 sb!vm:word-bytes))))
2502 (#.sb!vm:double-stack-sc-number
2503 (/show0 "case of DOUBLE-STACK-SC-NUMBER")
2504 (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
2505 sb!vm:word-bytes))))
2507 (#.sb!vm:long-stack-sc-number
2508 (/show0 "case of LONG-STACK-SC-NUMBER")
2509 (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
2510 sb!vm:word-bytes))))
2511 (#.sb!vm:complex-single-stack-sc-number
2512 (/show0 "case of COMPLEX-STACK-SC-NUMBER")
2514 (sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2516 (sap-ref-single fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
2517 sb!vm:word-bytes)))))
2518 (#.sb!vm:complex-double-stack-sc-number
2519 (/show0 "case of COMPLEX-DOUBLE-STACK-SC-NUMBER")
2521 (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
2523 (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 4)
2524 sb!vm:word-bytes)))))
2526 (#.sb!vm:complex-long-stack-sc-number
2527 (/show0 "case of COMPLEX-LONG-STACK-SC-NUMBER")
2529 (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
2531 (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 6)
2532 sb!vm:word-bytes)))))
2533 (#.sb!vm:control-stack-sc-number
2534 (/show0 "case of CONTROL-STACK-SC-NUMBER")
2535 (stack-ref fp (sb!c:sc-offset-offset sc-offset)))
2536 (#.sb!vm:base-char-stack-sc-number
2537 (/show0 "case of BASE-CHAR-STACK-SC-NUMBER")
2539 (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2540 sb!vm:word-bytes)))))
2541 (#.sb!vm:unsigned-stack-sc-number
2542 (/show0 "case of UNSIGNED-STACK-SC-NUMBER")
2543 (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2544 sb!vm:word-bytes))))
2545 (#.sb!vm:signed-stack-sc-number
2546 (/show0 "case of SIGNED-STACK-SC-NUMBER")
2547 (signed-sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2548 sb!vm:word-bytes))))
2549 (#.sb!vm:sap-stack-sc-number
2550 (/show0 "case of SAP-STACK-SC-NUMBER")
2551 (sap-ref-sap fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2552 sb!vm:word-bytes)))))))
2554 ;;; This stores value as the value of DEBUG-VAR in FRAME. In the
2555 ;;; COMPILED-DEBUG-VAR case, access the current value to determine if
2556 ;;; it is an indirect value cell. This occurs when the variable is
2557 ;;; both closed over and set.
2558 (defun %set-debug-var-value (debug-var frame value)
2559 (etypecase debug-var
2561 (aver (typep frame 'compiled-frame))
2562 (let ((current-value (access-compiled-debug-var-slot debug-var frame)))
2563 (if (indirect-value-cell-p current-value)
2564 (value-cell-set current-value value)
2565 (set-compiled-debug-var-slot debug-var frame value))))
2566 ;; (This function used to be more interesting, with more type
2567 ;; cases here, before the IR1 interpreter went away. It might
2568 ;; become more interesting again if we ever try to generalize the
2569 ;; CMU CL POSSIBLY-AN-INTERPRETED-FRAME thing to elide
2570 ;; internal-to-the-byte-interpreter debug frames the way that CMU
2571 ;; CL elided internal-to-the-IR1-interpreter debug frames.)
2575 ;;; This stores value for the variable represented by debug-var
2576 ;;; relative to the frame. This assumes the location directly contains
2577 ;;; the variable's value; that is, there is no indirect value cell
2578 ;;; currently there in case the variable is both closed over and set.
2579 (defun set-compiled-debug-var-slot (debug-var frame value)
2580 (let ((escaped (compiled-frame-escaped frame)))
2582 (sub-set-debug-var-slot (frame-pointer frame)
2583 (compiled-debug-var-sc-offset debug-var)
2585 (sub-set-debug-var-slot
2586 (frame-pointer frame)
2587 (or (compiled-debug-var-save-sc-offset debug-var)
2588 (compiled-debug-var-sc-offset debug-var))
2592 (defun sub-set-debug-var-slot (fp sc-offset value &optional escaped)
2593 (macrolet ((set-escaped-value (val)
2595 (setf (sb!vm:context-register
2597 (sb!c:sc-offset-offset sc-offset))
2600 (set-escaped-float-value (format val)
2602 (setf (sb!vm:context-float-register
2604 (sb!c:sc-offset-offset sc-offset)
2608 (with-nfp ((var) &body body)
2609 `(let ((,var (if escaped
2611 (sb!vm:context-register escaped
2615 (* sb!vm::nfp-save-offset
2618 (sb!vm::make-number-stack-pointer
2620 (* sb!vm::nfp-save-offset
2621 sb!vm:word-bytes))))))
2623 (ecase (sb!c:sc-offset-scn sc-offset)
2624 ((#.sb!vm:any-reg-sc-number
2625 #.sb!vm:descriptor-reg-sc-number
2626 #!+rt #.sb!vm:word-pointer-reg-sc-number)
2629 (get-lisp-obj-address value))))
2630 (#.sb!vm:base-char-reg-sc-number
2631 (set-escaped-value (char-code value)))
2632 (#.sb!vm:sap-reg-sc-number
2633 (set-escaped-value (sap-int value)))
2634 (#.sb!vm:signed-reg-sc-number
2635 (set-escaped-value (logand value (1- (ash 1 sb!vm:word-bits)))))
2636 (#.sb!vm:unsigned-reg-sc-number
2637 (set-escaped-value value))
2638 (#.sb!vm:non-descriptor-reg-sc-number
2639 (error "Local non-descriptor register access?"))
2640 (#.sb!vm:interior-reg-sc-number
2641 (error "Local interior register access?"))
2642 (#.sb!vm:single-reg-sc-number
2643 (set-escaped-float-value single-float value))
2644 (#.sb!vm:double-reg-sc-number
2645 (set-escaped-float-value double-float value))
2647 (#.sb!vm:long-reg-sc-number
2648 (set-escaped-float-value long-float value))
2649 (#.sb!vm:complex-single-reg-sc-number
2651 (setf (sb!vm:context-float-register escaped
2652 (sb!c:sc-offset-offset sc-offset)
2655 (setf (sb!vm:context-float-register
2656 escaped (1+ (sb!c:sc-offset-offset sc-offset))
2660 (#.sb!vm:complex-double-reg-sc-number
2662 (setf (sb!vm:context-float-register
2663 escaped (sb!c:sc-offset-offset sc-offset) 'double-float)
2665 (setf (sb!vm:context-float-register
2667 (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 2 #!-sparc 1)
2672 (#.sb!vm:complex-long-reg-sc-number
2674 (setf (sb!vm:context-float-register
2675 escaped (sb!c:sc-offset-offset sc-offset) 'long-float)
2677 (setf (sb!vm:context-float-register
2679 (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4)
2683 (#.sb!vm:single-stack-sc-number
2685 (setf (sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset)
2687 (the single-float value))))
2688 (#.sb!vm:double-stack-sc-number
2690 (setf (sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset)
2692 (the double-float value))))
2694 (#.sb!vm:long-stack-sc-number
2696 (setf (sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset)
2698 (the long-float value))))
2699 (#.sb!vm:complex-single-stack-sc-number
2701 (setf (sap-ref-single
2702 nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:word-bytes))
2703 (the single-float (realpart value)))
2704 (setf (sap-ref-single
2705 nfp (* (1+ (sb!c:sc-offset-offset sc-offset))
2707 (the single-float (realpart value)))))
2708 (#.sb!vm:complex-double-stack-sc-number
2710 (setf (sap-ref-double
2711 nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:word-bytes))
2712 (the double-float (realpart value)))
2713 (setf (sap-ref-double
2714 nfp (* (+ (sb!c:sc-offset-offset sc-offset) 2)
2716 (the double-float (realpart value)))))
2718 (#.sb!vm:complex-long-stack-sc-number
2721 nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:word-bytes))
2722 (the long-float (realpart value)))
2724 nfp (* (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4)
2726 (the long-float (realpart value)))))
2727 (#.sb!vm:control-stack-sc-number
2728 (setf (stack-ref fp (sb!c:sc-offset-offset sc-offset)) value))
2729 (#.sb!vm:base-char-stack-sc-number
2731 (setf (sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
2733 (char-code (the character value)))))
2734 (#.sb!vm:unsigned-stack-sc-number
2736 (setf (sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
2738 (the (unsigned-byte 32) value))))
2739 (#.sb!vm:signed-stack-sc-number
2741 (setf (signed-sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
2743 (the (signed-byte 32) value))))
2744 (#.sb!vm:sap-stack-sc-number
2746 (setf (sap-ref-sap nfp (* (sb!c:sc-offset-offset sc-offset)
2748 (the system-area-pointer value)))))))
2751 (defun sub-set-debug-var-slot (fp sc-offset value &optional escaped)
2752 (macrolet ((set-escaped-value (val)
2754 (setf (sb!vm:context-register
2756 (sb!c:sc-offset-offset sc-offset))
2759 (ecase (sb!c:sc-offset-scn sc-offset)
2760 ((#.sb!vm:any-reg-sc-number #.sb!vm:descriptor-reg-sc-number)
2763 (get-lisp-obj-address value))))
2764 (#.sb!vm:base-char-reg-sc-number
2765 (set-escaped-value (char-code value)))
2766 (#.sb!vm:sap-reg-sc-number
2767 (set-escaped-value (sap-int value)))
2768 (#.sb!vm:signed-reg-sc-number
2769 (set-escaped-value (logand value (1- (ash 1 sb!vm:word-bits)))))
2770 (#.sb!vm:unsigned-reg-sc-number
2771 (set-escaped-value value))
2772 (#.sb!vm:single-reg-sc-number
2773 #+nil ;; don't have escaped floats.
2774 (set-escaped-float-value single-float value))
2775 (#.sb!vm:double-reg-sc-number
2776 #+nil ;; don't have escaped floats -- still in npx?
2777 (set-escaped-float-value double-float value))
2779 (#.sb!vm:long-reg-sc-number
2780 #+nil ;; don't have escaped floats -- still in npx?
2781 (set-escaped-float-value long-float value))
2782 (#.sb!vm:single-stack-sc-number
2783 (setf (sap-ref-single
2784 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2786 (the single-float value)))
2787 (#.sb!vm:double-stack-sc-number
2788 (setf (sap-ref-double
2789 fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
2791 (the double-float value)))
2793 (#.sb!vm:long-stack-sc-number
2795 fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
2797 (the long-float value)))
2798 (#.sb!vm:complex-single-stack-sc-number
2799 (setf (sap-ref-single
2800 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2802 (realpart (the (complex single-float) value)))
2803 (setf (sap-ref-single
2804 fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
2806 (imagpart (the (complex single-float) value))))
2807 (#.sb!vm:complex-double-stack-sc-number
2808 (setf (sap-ref-double
2809 fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
2811 (realpart (the (complex double-float) value)))
2812 (setf (sap-ref-double
2813 fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 4)
2815 (imagpart (the (complex double-float) value))))
2817 (#.sb!vm:complex-long-stack-sc-number
2819 fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
2821 (realpart (the (complex long-float) value)))
2823 fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 6)
2825 (imagpart (the (complex long-float) value))))
2826 (#.sb!vm:control-stack-sc-number
2827 (setf (stack-ref fp (sb!c:sc-offset-offset sc-offset)) value))
2828 (#.sb!vm:base-char-stack-sc-number
2829 (setf (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2831 (char-code (the character value))))
2832 (#.sb!vm:unsigned-stack-sc-number
2833 (setf (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2835 (the (unsigned-byte 32) value)))
2836 (#.sb!vm:signed-stack-sc-number
2837 (setf (signed-sap-ref-32
2838 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) sb!vm:word-bytes)))
2839 (the (signed-byte 32) value)))
2840 (#.sb!vm:sap-stack-sc-number
2841 (setf (sap-ref-sap fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2843 (the system-area-pointer value))))))
2845 ;;; The method for setting and accessing COMPILED-DEBUG-VAR values use
2846 ;;; this to determine if the value stored is the actual value or an
2847 ;;; indirection cell.
2848 (defun indirect-value-cell-p (x)
2849 (and (= (get-lowtag x) sb!vm:other-pointer-type)
2850 (= (get-type x) sb!vm:value-cell-header-type)))
2852 ;;; Return three values reflecting the validity of DEBUG-VAR's value
2853 ;;; at BASIC-CODE-LOCATION:
2854 ;;; :VALID The value is known to be available.
2855 ;;; :INVALID The value is known to be unavailable.
2856 ;;; :UNKNOWN The value's availability is unknown.
2858 ;;; If the variable is always alive, then it is valid. If the
2859 ;;; code-location is unknown, then the variable's validity is
2860 ;;; :unknown. Once we've called CODE-LOCATION-UNKNOWN-P, we know the
2861 ;;; live-set information has been cached in the code-location.
2862 (defun debug-var-validity (debug-var basic-code-location)
2863 (etypecase debug-var
2865 (compiled-debug-var-validity debug-var basic-code-location))
2866 ;; (There used to be more cases back before sbcl-0.7.0, when
2867 ;; we did special tricks to debug the IR1 interpreter.)
2870 ;;; This is the method for DEBUG-VAR-VALIDITY for COMPILED-DEBUG-VARs.
2871 ;;; For safety, make sure basic-code-location is what we think.
2872 (defun compiled-debug-var-validity (debug-var basic-code-location)
2873 (declare (type compiled-code-location basic-code-location))
2874 (cond ((debug-var-alive-p debug-var)
2875 (let ((debug-fun (code-location-debug-function basic-code-location)))
2876 (if (>= (compiled-code-location-pc basic-code-location)
2877 (sb!c::compiled-debug-function-start-pc
2878 (compiled-debug-function-compiler-debug-fun debug-fun)))
2881 ((code-location-unknown-p basic-code-location) :unknown)
2883 (let ((pos (position debug-var
2884 (debug-function-debug-vars
2885 (code-location-debug-function
2886 basic-code-location)))))
2888 (error 'unknown-debug-var
2889 :debug-var debug-var
2891 (code-location-debug-function basic-code-location)))
2892 ;; There must be live-set info since basic-code-location is known.
2893 (if (zerop (sbit (compiled-code-location-live-set
2894 basic-code-location)
2901 ;;; This code produces and uses what we call source-paths. A
2902 ;;; source-path is a list whose first element is a form number as
2903 ;;; returned by CODE-LOCATION-FORM-NUMBER and whose last element is a
2904 ;;; top-level-form number as returned by
2905 ;;; CODE-LOCATION-TOP-LEVEL-FORM-NUMBER. The elements from the last to
2906 ;;; the first, exclusively, are the numbered subforms into which to
2907 ;;; descend. For example:
2909 ;;; (let ((a (aref x 3)))
2911 ;;; The call to AREF in this example is form number 5. Assuming this
2912 ;;; DEFUN is the 11'th top-level-form, the source-path for the AREF
2913 ;;; call is as follows:
2915 ;;; Given the DEFUN, 3 gets you the LET, 1 gets you the bindings, 0
2916 ;;; gets the first binding, and 1 gets the AREF form.
2918 ;;; temporary buffer used to build form-number => source-path translation in
2919 ;;; FORM-NUMBER-TRANSLATIONS
2920 (defvar *form-number-temp* (make-array 10 :fill-pointer 0 :adjustable t))
2922 ;;; table used to detect CAR circularities in FORM-NUMBER-TRANSLATIONS
2923 (defvar *form-number-circularity-table* (make-hash-table :test 'eq))
2925 ;;; This returns a table mapping form numbers to source-paths. A source-path
2926 ;;; indicates a descent into the top-level-form form, going directly to the
2927 ;;; subform corressponding to the form number.
2929 ;;; The vector elements are in the same format as the compiler's
2930 ;;; NODE-SOURCE-PATH; that is, the first element is the form number and
2931 ;;; the last is the top-level-form number.
2932 (defun form-number-translations (form tlf-number)
2933 (clrhash *form-number-circularity-table*)
2934 (setf (fill-pointer *form-number-temp*) 0)
2935 (sub-translate-form-numbers form (list tlf-number))
2936 (coerce *form-number-temp* 'simple-vector))
2937 (defun sub-translate-form-numbers (form path)
2938 (unless (gethash form *form-number-circularity-table*)
2939 (setf (gethash form *form-number-circularity-table*) t)
2940 (vector-push-extend (cons (fill-pointer *form-number-temp*) path)
2945 (declare (fixnum pos))
2948 (when (atom subform) (return))
2949 (let ((fm (car subform)))
2951 (sub-translate-form-numbers fm (cons pos path)))
2953 (setq subform (cdr subform))
2954 (when (eq subform trail) (return)))))
2958 (setq trail (cdr trail)))))))
2960 ;;; FORM is a top-level form, and path is a source-path into it. This
2961 ;;; returns the form indicated by the source-path. Context is the
2962 ;;; number of enclosing forms to return instead of directly returning
2963 ;;; the source-path form. When context is non-zero, the form returned
2964 ;;; contains a marker, #:****HERE****, immediately before the form
2965 ;;; indicated by path.
2966 (defun source-path-context (form path context)
2967 (declare (type unsigned-byte context))
2968 ;; Get to the form indicated by path or the enclosing form indicated
2969 ;; by context and path.
2970 (let ((path (reverse (butlast (cdr path)))))
2971 (dotimes (i (- (length path) context))
2972 (let ((index (first path)))
2973 (unless (and (listp form) (< index (length form)))
2974 (error "Source path no longer exists."))
2975 (setq form (elt form index))
2976 (setq path (rest path))))
2977 ;; Recursively rebuild the source form resulting from the above
2978 ;; descent, copying the beginning of each subform up to the next
2979 ;; subform we descend into according to path. At the bottom of the
2980 ;; recursion, we return the form indicated by path preceded by our
2981 ;; marker, and this gets spliced into the resulting list structure
2982 ;; on the way back up.
2983 (labels ((frob (form path level)
2984 (if (or (zerop level) (null path))
2987 `(#:***here*** ,form))
2988 (let ((n (first path)))
2989 (unless (and (listp form) (< n (length form)))
2990 (error "Source path no longer exists."))
2991 (let ((res (frob (elt form n) (rest path) (1- level))))
2992 (nconc (subseq form 0 n)
2993 (cons res (nthcdr (1+ n) form))))))))
2994 (frob form path context))))
2996 ;;;; PREPROCESS-FOR-EVAL
2998 ;;; Return a function of one argument that evaluates form in the
2999 ;;; lexical context of the BASIC-CODE-LOCATION LOC, or signal a
3000 ;;; NO-DEBUG-VARS condition when the LOC's DEBUG-FUNCTION has no
3001 ;;; DEBUG-VAR information available.
3003 ;;; The returned function takes the frame to get values from as its
3004 ;;; argument, and it returns the values of FORM. The returned function
3005 ;;; can signal the following conditions: INVALID-VALUE,
3006 ;;; AMBIGUOUS-VARIABLE-NAME, and FRAME-FUNCTION-MISMATCH.
3007 (defun preprocess-for-eval (form loc)
3008 (declare (type code-location loc))
3009 (let ((n-frame (gensym))
3010 (fun (code-location-debug-function loc)))
3011 (unless (debug-var-info-available fun)
3012 (debug-signal 'no-debug-vars :debug-function fun))
3013 (sb!int:collect ((binds)
3015 (do-debug-function-variables (var fun)
3016 (let ((validity (debug-var-validity var loc)))
3017 (unless (eq validity :invalid)
3018 (let* ((sym (debug-var-symbol var))
3019 (found (assoc sym (binds))))
3021 (setf (second found) :ambiguous)
3022 (binds (list sym validity var)))))))
3023 (dolist (bind (binds))
3024 (let ((name (first bind))
3026 (ecase (second bind)
3028 (specs `(,name (debug-var-value ',var ,n-frame))))
3030 (specs `(,name (debug-signal 'invalid-value :debug-var ',var
3033 (specs `(,name (debug-signal 'ambiguous-variable-name :name ',name
3034 :frame ,n-frame)))))))
3035 (let ((res (coerce `(lambda (,n-frame)
3036 (declare (ignorable ,n-frame))
3037 (symbol-macrolet ,(specs) ,form))
3040 ;; This prevents these functions from being used in any
3041 ;; location other than a function return location, so
3042 ;; maybe this should only check whether frame's
3043 ;; debug-function is the same as loc's.
3044 (unless (code-location= (frame-code-location frame) loc)
3045 (debug-signal 'frame-function-mismatch
3046 :code-location loc :form form :frame frame))
3047 (funcall res frame))))))
3051 ;;;; user-visible interface
3053 ;;; Create and return a breakpoint. When program execution encounters
3054 ;;; the breakpoint, the system calls HOOK-FUNCTION. HOOK-FUNCTION takes the
3055 ;;; current frame for the function in which the program is running and the
3056 ;;; breakpoint object.
3058 ;;; WHAT and KIND determine where in a function the system invokes
3059 ;;; HOOK-FUNCTION. WHAT is either a code-location or a debug-function.
3060 ;;; KIND is one of :CODE-LOCATION, :FUNCTION-START, or :FUNCTION-END.
3061 ;;; Since the starts and ends of functions may not have code-locations
3062 ;;; representing them, designate these places by supplying WHAT as a
3063 ;;; debug-function and KIND indicating the :FUNCTION-START or
3064 ;;; :FUNCTION-END. When WHAT is a debug-function and kind is
3065 ;;; :FUNCTION-END, then hook-function must take two additional
3066 ;;; arguments, a list of values returned by the function and a
3067 ;;; FUNCTION-END-COOKIE.
3069 ;;; INFO is information supplied by and used by the user.
3071 ;;; FUNCTION-END-COOKIE is a function. To implement :FUNCTION-END
3072 ;;; breakpoints, the system uses starter breakpoints to establish the
3073 ;;; :FUNCTION-END breakpoint for each invocation of the function. Upon
3074 ;;; each entry, the system creates a unique cookie to identify the
3075 ;;; invocation, and when the user supplies a function for this
3076 ;;; argument, the system invokes it on the frame and the cookie. The
3077 ;;; system later invokes the :FUNCTION-END breakpoint hook on the same
3078 ;;; cookie. The user may save the cookie for comparison in the hook
3081 ;;; Signal an error if WHAT is an unknown code-location.
3082 (defun make-breakpoint (hook-function what
3083 &key (kind :code-location) info function-end-cookie)
3086 (when (code-location-unknown-p what)
3087 (error "cannot make a breakpoint at an unknown code location: ~S"
3089 (aver (eq kind :code-location))
3090 (let ((bpt (%make-breakpoint hook-function what kind info)))
3092 (compiled-code-location
3093 ;; This slot is filled in due to calling CODE-LOCATION-UNKNOWN-P.
3094 (when (eq (compiled-code-location-kind what) :unknown-return)
3095 (let ((other-bpt (%make-breakpoint hook-function what
3096 :unknown-return-partner
3098 (setf (breakpoint-unknown-return-partner bpt) other-bpt)
3099 (setf (breakpoint-unknown-return-partner other-bpt) bpt))))
3100 ;; (There used to be more cases back before sbcl-0.7.0,,
3101 ;; when we did special tricks to debug the IR1
3105 (compiled-debug-function
3108 (%make-breakpoint hook-function what kind info))
3110 (unless (eq (sb!c::compiled-debug-function-returns
3111 (compiled-debug-function-compiler-debug-fun what))
3113 (error ":FUNCTION-END breakpoints are currently unsupported ~
3114 for the known return convention."))
3116 (let* ((bpt (%make-breakpoint hook-function what kind info))
3117 (starter (compiled-debug-function-end-starter what)))
3119 (setf starter (%make-breakpoint #'list what :function-start nil))
3120 (setf (breakpoint-hook-function starter)
3121 (function-end-starter-hook starter what))
3122 (setf (compiled-debug-function-end-starter what) starter))
3123 (setf (breakpoint-start-helper bpt) starter)
3124 (push bpt (breakpoint-%info starter))
3125 (setf (breakpoint-cookie-fun bpt) function-end-cookie)
3128 ;;; These are unique objects created upon entry into a function by a
3129 ;;; :FUNCTION-END breakpoint's starter hook. These are only created
3130 ;;; when users supply :FUNCTION-END-COOKIE to MAKE-BREAKPOINT. Also,
3131 ;;; the :FUNCTION-END breakpoint's hook is called on the same cookie
3132 ;;; when it is created.
3133 (defstruct (function-end-cookie
3134 (:print-object (lambda (obj str)
3135 (print-unreadable-object (obj str :type t))))
3136 (:constructor make-function-end-cookie (bogus-lra debug-fun))
3138 ;; a pointer to the bogus-lra created for :FUNCTION-END breakpoints
3140 ;; the debug-function associated with the cookie
3143 ;;; This maps bogus-lra-components to cookies, so that
3144 ;;; HANDLE-FUNCTION-END-BREAKPOINT can find the appropriate cookie for the
3145 ;;; breakpoint hook.
3146 (defvar *function-end-cookies* (make-hash-table :test 'eq))
3148 ;;; This returns a hook function for the start helper breakpoint
3149 ;;; associated with a :FUNCTION-END breakpoint. The returned function
3150 ;;; makes a fake LRA that all returns go through, and this piece of
3151 ;;; fake code actually breaks. Upon return from the break, the code
3152 ;;; provides the returnee with any values. Since the returned function
3153 ;;; effectively activates FUN-END-BPT on each entry to DEBUG-FUN's
3154 ;;; function, we must establish breakpoint-data about FUN-END-BPT.
3155 (defun function-end-starter-hook (starter-bpt debug-fun)
3156 (declare (type breakpoint starter-bpt)
3157 (type compiled-debug-function debug-fun))
3158 #'(lambda (frame breakpoint)
3159 (declare (ignore breakpoint)
3161 (let ((lra-sc-offset
3162 (sb!c::compiled-debug-function-return-pc
3163 (compiled-debug-function-compiler-debug-fun debug-fun))))
3164 (multiple-value-bind (lra component offset)
3166 (get-context-value frame
3167 #!-gengc sb!vm::lra-save-offset
3168 #!+gengc sb!vm::ra-save-offset
3170 (setf (get-context-value frame
3171 #!-gengc sb!vm::lra-save-offset
3172 #!+gengc sb!vm::ra-save-offset
3175 (let ((end-bpts (breakpoint-%info starter-bpt)))
3176 (let ((data (breakpoint-data component offset)))
3177 (setf (breakpoint-data-breakpoints data) end-bpts)
3178 (dolist (bpt end-bpts)
3179 (setf (breakpoint-internal-data bpt) data)))
3180 (let ((cookie (make-function-end-cookie lra debug-fun)))
3181 (setf (gethash component *function-end-cookies*) cookie)
3182 (dolist (bpt end-bpts)
3183 (let ((fun (breakpoint-cookie-fun bpt)))
3184 (when fun (funcall fun frame cookie))))))))))
3186 ;;; This takes a FUNCTION-END-COOKIE and a frame, and it returns
3187 ;;; whether the cookie is still valid. A cookie becomes invalid when
3188 ;;; the frame that established the cookie has exited. Sometimes cookie
3189 ;;; holders are unaware of cookie invalidation because their
3190 ;;; :FUNCTION-END breakpoint hooks didn't run due to THROW'ing.
3192 ;;; This takes a frame as an efficiency hack since the user probably
3193 ;;; has a frame object in hand when using this routine, and it saves
3194 ;;; repeated parsing of the stack and consing when asking whether a
3195 ;;; series of cookies is valid.
3196 (defun function-end-cookie-valid-p (frame cookie)
3197 (let ((lra (function-end-cookie-bogus-lra cookie))
3198 (lra-sc-offset (sb!c::compiled-debug-function-return-pc
3199 (compiled-debug-function-compiler-debug-fun
3200 (function-end-cookie-debug-fun cookie)))))
3201 (do ((frame frame (frame-down frame)))
3203 (when (and (compiled-frame-p frame)
3205 (get-context-value frame
3206 #!-gengc sb!vm::lra-save-offset
3207 #!+gengc sb!vm::ra-save-offset
3211 ;;;; ACTIVATE-BREAKPOINT
3213 ;;; Cause the system to invoke the breakpoint's hook-function until
3214 ;;; the next call to DEACTIVATE-BREAKPOINT or DELETE-BREAKPOINT. The
3215 ;;; system invokes breakpoint hook functions in the opposite order
3216 ;;; that you activate them.
3217 (defun activate-breakpoint (breakpoint)
3218 (when (eq (breakpoint-status breakpoint) :deleted)
3219 (error "cannot activate a deleted breakpoint: ~S" breakpoint))
3220 (unless (eq (breakpoint-status breakpoint) :active)
3221 (ecase (breakpoint-kind breakpoint)
3223 (let ((loc (breakpoint-what breakpoint)))
3225 (compiled-code-location
3226 (activate-compiled-code-location-breakpoint breakpoint)
3227 (let ((other (breakpoint-unknown-return-partner breakpoint)))
3229 (activate-compiled-code-location-breakpoint other))))
3230 ;; (There used to be more cases back before sbcl-0.7.0, when
3231 ;; we did special tricks to debug the IR1 interpreter.)
3234 (etypecase (breakpoint-what breakpoint)
3235 (compiled-debug-function
3236 (activate-compiled-function-start-breakpoint breakpoint))
3237 ;; (There used to be more cases back before sbcl-0.7.0, when
3238 ;; we did special tricks to debug the IR1 interpreter.)
3241 (etypecase (breakpoint-what breakpoint)
3242 (compiled-debug-function
3243 (let ((starter (breakpoint-start-helper breakpoint)))
3244 (unless (eq (breakpoint-status starter) :active)
3245 ;; may already be active by some other :FUNCTION-END breakpoint
3246 (activate-compiled-function-start-breakpoint starter)))
3247 (setf (breakpoint-status breakpoint) :active))
3248 ;; (There used to be more cases back before sbcl-0.7.0, when
3249 ;; we did special tricks to debug the IR1 interpreter.)
3253 (defun activate-compiled-code-location-breakpoint (breakpoint)
3254 (declare (type breakpoint breakpoint))
3255 (let ((loc (breakpoint-what breakpoint)))
3256 (declare (type compiled-code-location loc))
3257 (sub-activate-breakpoint
3259 (breakpoint-data (compiled-debug-function-component
3260 (code-location-debug-function loc))
3261 (+ (compiled-code-location-pc loc)
3262 (if (or (eq (breakpoint-kind breakpoint)
3263 :unknown-return-partner)
3264 (eq (compiled-code-location-kind loc)
3265 :single-value-return))
3266 sb!vm:single-value-return-byte-offset
3269 (defun activate-compiled-function-start-breakpoint (breakpoint)
3270 (declare (type breakpoint breakpoint))
3271 (let ((debug-fun (breakpoint-what breakpoint)))
3272 (sub-activate-breakpoint
3274 (breakpoint-data (compiled-debug-function-component debug-fun)
3275 (sb!c::compiled-debug-function-start-pc
3276 (compiled-debug-function-compiler-debug-fun
3279 (defun sub-activate-breakpoint (breakpoint data)
3280 (declare (type breakpoint breakpoint)
3281 (type breakpoint-data data))
3282 (setf (breakpoint-status breakpoint) :active)
3284 (unless (breakpoint-data-breakpoints data)
3285 (setf (breakpoint-data-instruction data)
3287 (breakpoint-install (get-lisp-obj-address
3288 (breakpoint-data-component data))
3289 (breakpoint-data-offset data)))))
3290 (setf (breakpoint-data-breakpoints data)
3291 (append (breakpoint-data-breakpoints data) (list breakpoint)))
3292 (setf (breakpoint-internal-data breakpoint) data)))
3294 ;;;; DEACTIVATE-BREAKPOINT
3296 ;;; Stop the system from invoking the breakpoint's hook-function.
3297 (defun deactivate-breakpoint (breakpoint)
3298 (when (eq (breakpoint-status breakpoint) :active)
3300 (let ((loc (breakpoint-what breakpoint)))
3302 ((or compiled-code-location compiled-debug-function)
3303 (deactivate-compiled-breakpoint breakpoint)
3304 (let ((other (breakpoint-unknown-return-partner breakpoint)))
3306 (deactivate-compiled-breakpoint other))))
3307 ;; (There used to be more cases back before sbcl-0.7.0, when
3308 ;; we did special tricks to debug the IR1 interpreter.)
3312 (defun deactivate-compiled-breakpoint (breakpoint)
3313 (if (eq (breakpoint-kind breakpoint) :function-end)
3314 (let ((starter (breakpoint-start-helper breakpoint)))
3315 (unless (find-if #'(lambda (bpt)
3316 (and (not (eq bpt breakpoint))
3317 (eq (breakpoint-status bpt) :active)))
3318 (breakpoint-%info starter))
3319 (deactivate-compiled-breakpoint starter)))
3320 (let* ((data (breakpoint-internal-data breakpoint))
3321 (bpts (delete breakpoint (breakpoint-data-breakpoints data))))
3322 (setf (breakpoint-internal-data breakpoint) nil)
3323 (setf (breakpoint-data-breakpoints data) bpts)
3326 (breakpoint-remove (get-lisp-obj-address
3327 (breakpoint-data-component data))
3328 (breakpoint-data-offset data)
3329 (breakpoint-data-instruction data)))
3330 (delete-breakpoint-data data))))
3331 (setf (breakpoint-status breakpoint) :inactive)
3334 ;;;; BREAKPOINT-INFO
3336 ;;; Return the user-maintained info associated with breakpoint. This
3338 (defun breakpoint-info (breakpoint)
3339 (breakpoint-%info breakpoint))
3340 (defun %set-breakpoint-info (breakpoint value)
3341 (setf (breakpoint-%info breakpoint) value)
3342 (let ((other (breakpoint-unknown-return-partner breakpoint)))
3344 (setf (breakpoint-%info other) value))))
3346 ;;;; BREAKPOINT-ACTIVE-P and DELETE-BREAKPOINT
3348 (defun breakpoint-active-p (breakpoint)
3349 (ecase (breakpoint-status breakpoint)
3351 ((:inactive :deleted) nil)))
3353 ;;; Free system storage and remove computational overhead associated
3354 ;;; with breakpoint. After calling this, breakpoint is completely
3355 ;;; impotent and can never become active again.
3356 (defun delete-breakpoint (breakpoint)
3357 (let ((status (breakpoint-status breakpoint)))
3358 (unless (eq status :deleted)
3359 (when (eq status :active)
3360 (deactivate-breakpoint breakpoint))
3361 (setf (breakpoint-status breakpoint) :deleted)
3362 (let ((other (breakpoint-unknown-return-partner breakpoint)))
3364 (setf (breakpoint-status other) :deleted)))
3365 (when (eq (breakpoint-kind breakpoint) :function-end)
3366 (let* ((starter (breakpoint-start-helper breakpoint))
3367 (breakpoints (delete breakpoint
3368 (the list (breakpoint-info starter)))))
3369 (setf (breakpoint-info starter) breakpoints)
3371 (delete-breakpoint starter)
3372 (setf (compiled-debug-function-end-starter
3373 (breakpoint-what breakpoint))
3377 ;;;; C call out stubs
3379 ;;; This actually installs the break instruction in the component. It
3380 ;;; returns the overwritten bits. You must call this in a context in
3381 ;;; which GC is disabled, so that Lisp doesn't move objects around
3382 ;;; that C is pointing to.
3383 (sb!alien:def-alien-routine "breakpoint_install" sb!c-call:unsigned-long
3384 (code-obj sb!c-call:unsigned-long)
3385 (pc-offset sb!c-call:int))
3387 ;;; This removes the break instruction and replaces the original
3388 ;;; instruction. You must call this in a context in which GC is disabled
3389 ;;; so Lisp doesn't move objects around that C is pointing to.
3390 (sb!alien:def-alien-routine "breakpoint_remove" sb!c-call:void
3391 (code-obj sb!c-call:unsigned-long)
3392 (pc-offset sb!c-call:int)
3393 (old-inst sb!c-call:unsigned-long))
3395 (sb!alien:def-alien-routine "breakpoint_do_displaced_inst" sb!c-call:void
3396 (scp (* os-context-t))
3397 (orig-inst sb!c-call:unsigned-long))
3399 ;;;; breakpoint handlers (layer between C and exported interface)
3401 ;;; This maps components to a mapping of offsets to breakpoint-datas.
3402 (defvar *component-breakpoint-offsets* (make-hash-table :test 'eq))
3404 ;;; This returns the breakpoint-data associated with component cross
3405 ;;; offset. If none exists, this makes one, installs it, and returns it.
3406 (defun breakpoint-data (component offset &optional (create t))
3407 (flet ((install-breakpoint-data ()
3409 (let ((data (make-breakpoint-data component offset)))
3410 (push (cons offset data)
3411 (gethash component *component-breakpoint-offsets*))
3413 (let ((offsets (gethash component *component-breakpoint-offsets*)))
3415 (let ((data (assoc offset offsets)))
3418 (install-breakpoint-data)))
3419 (install-breakpoint-data)))))
3421 ;;; We use this when there are no longer any active breakpoints
3422 ;;; corresponding to data.
3423 (defun delete-breakpoint-data (data)
3424 (let* ((component (breakpoint-data-component data))
3425 (offsets (delete (breakpoint-data-offset data)
3426 (gethash component *component-breakpoint-offsets*)
3429 (setf (gethash component *component-breakpoint-offsets*) offsets)
3430 (remhash component *component-breakpoint-offsets*)))
3433 ;;; The C handler for interrupts calls this when it has a
3434 ;;; debugging-tool break instruction. This does NOT handle all breaks;
3435 ;;; for example, it does not handle breaks for internal errors.
3436 (defun handle-breakpoint (offset component signal-context)
3437 (/show0 "entering HANDLE-BREAKPOINT")
3438 (let ((data (breakpoint-data component offset nil)))
3440 (error "unknown breakpoint in ~S at offset ~S"
3441 (debug-function-name (debug-function-from-pc component offset))
3443 (let ((breakpoints (breakpoint-data-breakpoints data)))
3444 (if (or (null breakpoints)
3445 (eq (breakpoint-kind (car breakpoints)) :function-end))
3446 (handle-function-end-breakpoint-aux breakpoints data signal-context)
3447 (handle-breakpoint-aux breakpoints data
3448 offset component signal-context)))))
3450 ;;; This holds breakpoint-datas while invoking the breakpoint hooks
3451 ;;; associated with that particular component and location. While they
3452 ;;; are executing, if we hit the location again, we ignore the
3453 ;;; breakpoint to avoid infinite recursion. Function-end breakpoints
3454 ;;; must work differently since the breakpoint-data is unique for each
3456 (defvar *executing-breakpoint-hooks* nil)
3458 ;;; This handles code-location and debug-function :FUNCTION-START
3460 (defun handle-breakpoint-aux (breakpoints data offset component signal-context)
3461 (/show0 "entering HANDLE-BREAKPOINT-AUX")
3463 (error "internal error: breakpoint that nobody wants"))
3464 (unless (member data *executing-breakpoint-hooks*)
3465 (let ((*executing-breakpoint-hooks* (cons data
3466 *executing-breakpoint-hooks*)))
3467 (invoke-breakpoint-hooks breakpoints component offset)))
3468 ;; At this point breakpoints may not hold the same list as
3469 ;; BREAKPOINT-DATA-BREAKPOINTS since invoking hooks may have allowed
3470 ;; a breakpoint deactivation. In fact, if all breakpoints were
3471 ;; deactivated then data is invalid since it was deleted and so the
3472 ;; correct one must be looked up if it is to be used. If there are
3473 ;; no more breakpoints active at this location, then the normal
3474 ;; instruction has been put back, and we do not need to
3475 ;; DO-DISPLACED-INST.
3476 (let ((data (breakpoint-data component offset nil)))
3477 (when (and data (breakpoint-data-breakpoints data))
3478 ;; The breakpoint is still active, so we need to execute the
3479 ;; displaced instruction and leave the breakpoint instruction
3480 ;; behind. The best way to do this is different on each machine,
3481 ;; so we just leave it up to the C code.
3482 (breakpoint-do-displaced-inst signal-context
3483 (breakpoint-data-instruction data))
3484 ;; Some platforms have no usable sigreturn() call. If your
3485 ;; implementation of arch_do_displaced_inst() doesn't sigreturn(),
3486 ;; add it to this list.
3487 #!-(or hpux irix x86 alpha)
3488 (error "BREAKPOINT-DO-DISPLACED-INST returned?"))))
3490 (defun invoke-breakpoint-hooks (breakpoints component offset)
3491 (let* ((debug-fun (debug-function-from-pc component offset))
3492 (frame (do ((f (top-frame) (frame-down f)))
3493 ((eq debug-fun (frame-debug-function f)) f))))
3494 (dolist (bpt breakpoints)
3495 (funcall (breakpoint-hook-function bpt)
3497 ;; If this is an :UNKNOWN-RETURN-PARTNER, then pass the
3498 ;; hook function the original breakpoint, so that users
3499 ;; aren't forced to confront the fact that some
3500 ;; breakpoints really are two.
3501 (if (eq (breakpoint-kind bpt) :unknown-return-partner)
3502 (breakpoint-unknown-return-partner bpt)
3505 (defun handle-function-end-breakpoint (offset component context)
3506 (/show0 "entering HANDLE-FUNCTION-END-BREAKPOINT")
3507 (let ((data (breakpoint-data component offset nil)))
3509 (error "unknown breakpoint in ~S at offset ~S"
3510 (debug-function-name (debug-function-from-pc component offset))
3512 (let ((breakpoints (breakpoint-data-breakpoints data)))
3514 (aver (eq (breakpoint-kind (car breakpoints)) :function-end))
3515 (handle-function-end-breakpoint-aux breakpoints data context)))))
3517 ;;; Either HANDLE-BREAKPOINT calls this for :FUNCTION-END breakpoints
3518 ;;; [old C code] or HANDLE-FUNCTION-END-BREAKPOINT calls this directly
3520 (defun handle-function-end-breakpoint-aux (breakpoints data signal-context)
3521 (/show0 "entering HANDLE-FUNCTION-END-BREAKPOINT-AUX")
3522 (delete-breakpoint-data data)
3525 (declare (optimize (inhibit-warnings 3)))
3526 (sb!alien:sap-alien signal-context (* os-context-t))))
3527 (frame (do ((cfp (sb!vm:context-register scp sb!vm::cfp-offset))
3528 (f (top-frame) (frame-down f)))
3529 ((= cfp (sap-int (frame-pointer f))) f)
3530 (declare (type (unsigned-byte #.sb!vm:word-bits) cfp))))
3531 (component (breakpoint-data-component data))
3532 (cookie (gethash component *function-end-cookies*)))
3533 (remhash component *function-end-cookies*)
3534 (dolist (bpt breakpoints)
3535 (funcall (breakpoint-hook-function bpt)
3537 (get-function-end-breakpoint-values scp)
3540 (defun get-function-end-breakpoint-values (scp)
3541 (let ((ocfp (int-sap (sb!vm:context-register
3543 #!-x86 sb!vm::ocfp-offset
3544 #!+x86 sb!vm::ebx-offset)))
3545 (nargs (make-lisp-obj
3546 (sb!vm:context-register scp sb!vm::nargs-offset)))
3547 (reg-arg-offsets '#.sb!vm::*register-arg-offsets*)
3550 (dotimes (arg-num nargs)
3551 (push (if reg-arg-offsets
3553 (sb!vm:context-register scp (pop reg-arg-offsets)))
3554 (stack-ref ocfp arg-num))
3556 (nreverse results)))
3558 ;;;; MAKE-BOGUS-LRA (used for :FUNCTION-END breakpoints)
3560 (defconstant bogus-lra-constants
3562 (defconstant known-return-p-slot
3563 (+ sb!vm:code-constants-offset #!-x86 1 #!+x86 2))
3565 ;;; Make a bogus LRA object that signals a breakpoint trap when
3566 ;;; returned to. If the breakpoint trap handler returns, REAL-LRA is
3567 ;;; returned to. Three values are returned: the bogus LRA object, the
3568 ;;; code component it is part of, and the PC offset for the trap
3570 (defun make-bogus-lra (real-lra &optional known-return-p)
3572 (let* ((src-start (foreign-symbol-address "function_end_breakpoint_guts"))
3573 (src-end (foreign-symbol-address "function_end_breakpoint_end"))
3574 (trap-loc (foreign-symbol-address "function_end_breakpoint_trap"))
3575 (length (sap- src-end src-start))
3578 #!-(and x86 gencgc) sb!c:allocate-code-object
3579 #!+(and x86 gencgc) sb!c::allocate-dynamic-code-object
3580 (1+ bogus-lra-constants)
3582 (dst-start (code-instructions code-object)))
3583 (declare (type system-area-pointer
3584 src-start src-end dst-start trap-loc)
3585 (type index length))
3586 (setf (%code-debug-info code-object) :bogus-lra)
3587 (setf (code-header-ref code-object sb!vm:code-trace-table-offset-slot)
3590 (setf (code-header-ref code-object real-lra-slot) real-lra)
3592 (multiple-value-bind (offset code) (compute-lra-data-from-pc real-lra)
3593 (setf (code-header-ref code-object real-lra-slot) code)
3594 (setf (code-header-ref code-object (1+ real-lra-slot)) offset))
3595 (setf (code-header-ref code-object known-return-p-slot)
3597 (system-area-copy src-start 0 dst-start 0 (* length sb!vm:byte-bits))
3598 (sb!vm:sanctify-for-execution code-object)
3600 (values dst-start code-object (sap- trap-loc src-start))
3602 (let ((new-lra (make-lisp-obj (+ (sap-int dst-start)
3603 sb!vm:other-pointer-type))))
3606 (logandc2 (+ sb!vm:code-constants-offset bogus-lra-constants 1)
3608 (sb!vm:sanctify-for-execution code-object)
3609 (values new-lra code-object (sap- trap-loc src-start))))))
3613 ;;; This appears here because it cannot go with the DEBUG-FUNCTION
3614 ;;; interface since DO-DEBUG-BLOCK-LOCATIONS isn't defined until after
3615 ;;; the DEBUG-FUNCTION routines.
3617 ;;; Return a code-location before the body of a function and after all
3618 ;;; the arguments are in place; or if that location can't be
3619 ;;; determined due to a lack of debug information, return NIL.
3620 (defun debug-function-start-location (debug-fun)
3621 (etypecase debug-fun
3622 (compiled-debug-function
3623 (code-location-from-pc debug-fun
3624 (sb!c::compiled-debug-function-start-pc
3625 (compiled-debug-function-compiler-debug-fun
3628 ;; (There used to be more cases back before sbcl-0.7.0, when
3629 ;; we did special tricks to debug the IR1 interpreter.)
3632 (defun print-code-locations (function)
3633 (let ((debug-fun (function-debug-function function)))
3634 (do-debug-function-blocks (block debug-fun)
3635 (do-debug-block-locations (loc block)
3636 (fill-in-code-location loc)
3637 (format t "~S code location at ~D"
3638 (compiled-code-location-kind loc)
3639 (compiled-code-location-pc loc))
3640 (sb!debug::print-code-location-source-form loc 0)