1 ;;;; the implementation of the programmer's interface to writing
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
15 ;;; FIXME: There are an awful lot of package prefixes in this code.
16 ;;; Couldn't we have SB-DI use the SB-C and SB-VM packages?
20 ;;;; The interface to building debugging tools signals conditions that
21 ;;;; prevent it from adhering to its contract. These are
22 ;;;; serious-conditions because the program using the interface must
23 ;;;; handle them before it can correctly continue execution. These
24 ;;;; debugging conditions are not errors since it is no fault of the
25 ;;;; programmers that the conditions occur. The interface does not
26 ;;;; provide for programs to detect these situations other than
27 ;;;; calling a routine that detects them and signals a condition. For
28 ;;;; example, programmers call A which may fail to return successfully
29 ;;;; due to a lack of debug information, and there is no B the they
30 ;;;; could have called to realize A would fail. It is not an error to
31 ;;;; have called A, but it is an error for the program to then ignore
32 ;;;; the signal generated by A since it cannot continue without A's
33 ;;;; correctly returning a value or performing some operation.
35 ;;;; Use DEBUG-SIGNAL to signal these conditions.
37 (define-condition debug-condition (serious-condition)
41 "All DEBUG-CONDITIONs inherit from this type. These are serious conditions
42 that must be handled, but they are not programmer errors."))
44 (define-condition no-debug-fun-returns (debug-condition)
45 ((debug-fun :reader no-debug-fun-returns-debug-fun
49 "The system could not return values from a frame with DEBUG-FUN since
50 it lacked information about returning values.")
51 (:report (lambda (condition stream)
52 (let ((fun (debug-fun-fun
53 (no-debug-fun-returns-debug-fun condition))))
55 "~&Cannot return values from ~:[frame~;~:*~S~] since ~
56 the debug information lacks details about returning ~
60 (define-condition no-debug-blocks (debug-condition)
61 ((debug-fun :reader no-debug-blocks-debug-fun
64 (:documentation "The debug-fun has no debug-block information.")
65 (:report (lambda (condition stream)
66 (format stream "~&~S has no debug-block information."
67 (no-debug-blocks-debug-fun condition)))))
69 (define-condition no-debug-vars (debug-condition)
70 ((debug-fun :reader no-debug-vars-debug-fun
73 (:documentation "The DEBUG-FUN has no DEBUG-VAR information.")
74 (:report (lambda (condition stream)
75 (format stream "~&~S has no debug variable information."
76 (no-debug-vars-debug-fun condition)))))
78 (define-condition lambda-list-unavailable (debug-condition)
79 ((debug-fun :reader lambda-list-unavailable-debug-fun
83 "The DEBUG-FUN has no lambda list since argument DEBUG-VARs are
85 (:report (lambda (condition stream)
86 (format stream "~&~S has no lambda-list information available."
87 (lambda-list-unavailable-debug-fun condition)))))
89 (define-condition invalid-value (debug-condition)
90 ((debug-var :reader invalid-value-debug-var :initarg :debug-var)
91 (frame :reader invalid-value-frame :initarg :frame))
92 (:report (lambda (condition stream)
93 (format stream "~&~S has :invalid or :unknown value in ~S."
94 (invalid-value-debug-var condition)
95 (invalid-value-frame condition)))))
97 (define-condition ambiguous-var-name (debug-condition)
98 ((name :reader ambiguous-var-name-name :initarg :name)
99 (frame :reader ambiguous-var-name-frame :initarg :frame))
100 (:report (lambda (condition stream)
101 (format stream "~&~S names more than one valid variable in ~S."
102 (ambiguous-var-name-name condition)
103 (ambiguous-var-name-frame condition)))))
105 ;;;; errors and DEBUG-SIGNAL
107 ;;; The debug-internals code tries to signal all programmer errors as
108 ;;; subtypes of DEBUG-ERROR. There are calls to ERROR signalling
109 ;;; SIMPLE-ERRORs, but these dummy checks in the code and shouldn't
112 ;;; While under development, this code also signals errors in code
113 ;;; branches that remain unimplemented.
115 (define-condition debug-error (error) ()
118 "All programmer errors from using the interface for building debugging
119 tools inherit from this type."))
121 (define-condition unhandled-debug-condition (debug-error)
122 ((condition :reader unhandled-debug-condition-condition :initarg :condition))
123 (:report (lambda (condition stream)
124 (format stream "~&unhandled DEBUG-CONDITION:~%~A"
125 (unhandled-debug-condition-condition condition)))))
127 (define-condition unknown-code-location (debug-error)
128 ((code-location :reader unknown-code-location-code-location
129 :initarg :code-location))
130 (:report (lambda (condition stream)
131 (format stream "~&invalid use of an unknown code-location: ~S"
132 (unknown-code-location-code-location condition)))))
134 (define-condition unknown-debug-var (debug-error)
135 ((debug-var :reader unknown-debug-var-debug-var :initarg :debug-var)
136 (debug-fun :reader unknown-debug-var-debug-fun
137 :initarg :debug-fun))
138 (:report (lambda (condition stream)
139 (format stream "~&~S is not in ~S."
140 (unknown-debug-var-debug-var condition)
141 (unknown-debug-var-debug-fun condition)))))
143 (define-condition invalid-control-stack-pointer (debug-error)
145 (:report (lambda (condition stream)
146 (declare (ignore condition))
148 (write-string "invalid control stack pointer" stream))))
150 (define-condition frame-fun-mismatch (debug-error)
151 ((code-location :reader frame-fun-mismatch-code-location
152 :initarg :code-location)
153 (frame :reader frame-fun-mismatch-frame :initarg :frame)
154 (form :reader frame-fun-mismatch-form :initarg :form))
155 (:report (lambda (condition stream)
158 "~&Form was preprocessed for ~S,~% but called on ~S:~% ~S"
159 (frame-fun-mismatch-code-location condition)
160 (frame-fun-mismatch-frame condition)
161 (frame-fun-mismatch-form condition)))))
163 ;;; This signals debug-conditions. If they go unhandled, then signal
164 ;;; an UNHANDLED-DEBUG-CONDITION error.
166 ;;; ??? Get SIGNAL in the right package!
167 (defmacro debug-signal (datum &rest arguments)
168 `(let ((condition (make-condition ,datum ,@arguments)))
170 (error 'unhandled-debug-condition :condition condition)))
174 ;;;; Most of these structures model information stored in internal
175 ;;;; data structures created by the compiler. Whenever comments
176 ;;;; preface an object or type with "compiler", they refer to the
177 ;;;; internal compiler thing, not to the object or type with the same
178 ;;;; name in the "SB-DI" package.
182 ;;; These exist for caching data stored in packed binary form in
183 ;;; compiler DEBUG-FUNs.
184 (defstruct (debug-var (:constructor nil)
186 ;; the name of the variable
187 (symbol (missing-arg) :type symbol)
188 ;; a unique integer identification relative to other variables with the same
191 ;; Does the variable always have a valid value?
192 (alive-p nil :type boolean))
193 (def!method print-object ((debug-var debug-var) stream)
194 (print-unreadable-object (debug-var stream :type t :identity t)
197 (debug-var-symbol debug-var)
198 (debug-var-id debug-var))))
201 (setf (fdocumentation 'debug-var-id 'function)
202 "Return the integer that makes DEBUG-VAR's name and package unique
203 with respect to other DEBUG-VARs in the same function.")
205 (defstruct (compiled-debug-var
207 (:constructor make-compiled-debug-var
208 (symbol id alive-p sc-offset save-sc-offset))
210 ;; storage class and offset (unexported)
211 (sc-offset nil :type sb!c:sc-offset)
212 ;; storage class and offset when saved somewhere
213 (save-sc-offset nil :type (or sb!c:sc-offset null)))
217 ;;; These represent call frames on the stack.
218 (defstruct (frame (:constructor nil)
220 ;; the next frame up, or NIL when top frame
221 (up nil :type (or frame null))
222 ;; the previous frame down, or NIL when the bottom frame. Before
223 ;; computing the next frame down, this slot holds the frame pointer
224 ;; to the control stack for the given frame. This lets us get the
225 ;; next frame down and the return-pc for that frame.
226 (%down :unparsed :type (or frame (member nil :unparsed)))
227 ;; the DEBUG-FUN for the function whose call this frame represents
228 (debug-fun nil :type debug-fun)
229 ;; the CODE-LOCATION where the frame's DEBUG-FUN will continue
230 ;; running when program execution returns to this frame. If someone
231 ;; interrupted this frame, the result could be an unknown
233 (code-location nil :type code-location)
234 ;; an a-list of catch-tags to code-locations
235 (%catches :unparsed :type (or list (member :unparsed)))
236 ;; pointer to frame on control stack (unexported)
238 ;; This is the frame's number for prompt printing. Top is zero.
239 (number 0 :type index))
241 (defstruct (compiled-frame
243 (:constructor make-compiled-frame
244 (pointer up debug-fun code-location number
247 ;; This indicates whether someone interrupted the frame.
248 ;; (unexported). If escaped, this is a pointer to the state that was
249 ;; saved when we were interrupted, an os_context_t, i.e. the third
250 ;; argument to an SA_SIGACTION-style signal handler.
252 (def!method print-object ((obj compiled-frame) str)
253 (print-unreadable-object (obj str :type t)
255 "~S~:[~;, interrupted~]"
256 (debug-fun-name (frame-debug-fun obj))
257 (compiled-frame-escaped obj))))
261 ;;; These exist for caching data stored in packed binary form in
262 ;;; compiler DEBUG-FUNs. *COMPILED-DEBUG-FUNS* maps a SB!C::DEBUG-FUN
263 ;;; to a DEBUG-FUN. There should only be one DEBUG-FUN in existence
264 ;;; for any function; that is, all CODE-LOCATIONs and other objects
265 ;;; that reference DEBUG-FUNs point to unique objects. This is
266 ;;; due to the overhead in cached information.
267 (defstruct (debug-fun (:constructor nil)
269 ;; some representation of the function arguments. See
270 ;; DEBUG-FUN-LAMBDA-LIST.
271 ;; NOTE: must parse vars before parsing arg list stuff.
272 (%lambda-list :unparsed)
273 ;; cached DEBUG-VARS information (unexported).
274 ;; These are sorted by their name.
275 (%debug-vars :unparsed :type (or simple-vector null (member :unparsed)))
276 ;; cached debug-block information. This is NIL when we have tried to
277 ;; parse the packed binary info, but none is available.
278 (blocks :unparsed :type (or simple-vector null (member :unparsed)))
279 ;; the actual function if available
280 (%function :unparsed :type (or null function (member :unparsed))))
281 (def!method print-object ((obj debug-fun) stream)
282 (print-unreadable-object (obj stream :type t)
283 (prin1 (debug-fun-name obj) stream)))
285 (defstruct (compiled-debug-fun
287 (:constructor %make-compiled-debug-fun
288 (compiler-debug-fun component))
290 ;; compiler's dumped DEBUG-FUN information (unexported)
291 (compiler-debug-fun nil :type sb!c::compiled-debug-fun)
292 ;; code object (unexported).
294 ;; the :FUN-START breakpoint (if any) used to facilitate
295 ;; function end breakpoints
296 (end-starter nil :type (or null breakpoint)))
298 ;;; This maps SB!C::COMPILED-DEBUG-FUNs to
299 ;;; COMPILED-DEBUG-FUNs, so we can get at cached stuff and not
300 ;;; duplicate COMPILED-DEBUG-FUN structures.
301 (defvar *compiled-debug-funs* (make-hash-table :test 'eq))
303 ;;; Make a COMPILED-DEBUG-FUN for a SB!C::COMPILER-DEBUG-FUN
304 ;;; and its component. This maps the latter to the former in
305 ;;; *COMPILED-DEBUG-FUNS*. If there already is a
306 ;;; COMPILED-DEBUG-FUN, then this returns it from
307 ;;; *COMPILED-DEBUG-FUNS*.
308 (defun make-compiled-debug-fun (compiler-debug-fun component)
309 (or (gethash compiler-debug-fun *compiled-debug-funs*)
310 (setf (gethash compiler-debug-fun *compiled-debug-funs*)
311 (%make-compiled-debug-fun compiler-debug-fun component))))
313 (defstruct (bogus-debug-fun
315 (:constructor make-bogus-debug-fun
324 (defvar *ir1-lambda-debug-fun* (make-hash-table :test 'eq))
328 ;;; These exist for caching data stored in packed binary form in compiler
330 (defstruct (debug-block (:constructor nil)
332 ;; Code-locations where execution continues after this block.
333 (successors nil :type list)
334 ;; This indicates whether the block is a special glob of code shared
335 ;; by various functions and tucked away elsewhere in a component.
336 ;; This kind of block has no start code-location. This slot is in
337 ;; all debug-blocks since it is an exported interface.
338 (elsewhere-p nil :type boolean))
339 (def!method print-object ((obj debug-block) str)
340 (print-unreadable-object (obj str :type t)
341 (prin1 (debug-block-fun-name obj) str)))
344 (setf (fdocumentation 'debug-block-successors 'function)
345 "Return the list of possible code-locations where execution may continue
346 when the basic-block represented by debug-block completes its execution.")
349 (setf (fdocumentation 'debug-block-elsewhere-p 'function)
350 "Return whether debug-block represents elsewhere code.")
352 (defstruct (compiled-debug-block (:include debug-block)
354 make-compiled-debug-block
355 (code-locations successors elsewhere-p))
357 ;; code-location information for the block
358 (code-locations nil :type simple-vector))
360 (defvar *ir1-block-debug-block* (make-hash-table :test 'eq))
364 ;;; This is an internal structure that manages information about a
365 ;;; breakpoint locations. See *COMPONENT-BREAKPOINT-OFFSETS*.
366 (defstruct (breakpoint-data (:constructor make-breakpoint-data
369 ;; This is the component in which the breakpoint lies.
371 ;; This is the byte offset into the component.
372 (offset nil :type index)
373 ;; The original instruction replaced by the breakpoint.
374 (instruction nil :type (or null sb!vm::word))
375 ;; A list of user breakpoints at this location.
376 (breakpoints nil :type list))
377 (def!method print-object ((obj breakpoint-data) str)
378 (print-unreadable-object (obj str :type t)
379 (format str "~S at ~S"
381 (debug-fun-from-pc (breakpoint-data-component obj)
382 (breakpoint-data-offset obj)))
383 (breakpoint-data-offset obj))))
385 (defstruct (breakpoint (:constructor %make-breakpoint
386 (hook-fun what kind %info))
388 ;; This is the function invoked when execution encounters the
389 ;; breakpoint. It takes a frame, the breakpoint, and optionally a
390 ;; list of values. Values are supplied for :FUN-END breakpoints as
391 ;; values to return for the function containing the breakpoint.
392 ;; :FUN-END breakpoint hook functions also take a cookie argument.
393 ;; See the COOKIE-FUN slot.
394 (hook-fun (required-arg) :type function)
395 ;; CODE-LOCATION or DEBUG-FUN
396 (what nil :type (or code-location debug-fun))
397 ;; :CODE-LOCATION, :FUN-START, or :FUN-END for that kind
398 ;; of breakpoint. :UNKNOWN-RETURN-PARTNER if this is the partner of
399 ;; a :code-location breakpoint at an :UNKNOWN-RETURN code-location.
400 (kind nil :type (member :code-location :fun-start :fun-end
401 :unknown-return-partner))
402 ;; Status helps the user and the implementation.
403 (status :inactive :type (member :active :inactive :deleted))
404 ;; This is a backpointer to a breakpoint-data.
405 (internal-data nil :type (or null breakpoint-data))
406 ;; With code-locations whose type is :UNKNOWN-RETURN, there are
407 ;; really two breakpoints: one at the multiple-value entry point,
408 ;; and one at the single-value entry point. This slot holds the
409 ;; breakpoint for the other one, or NIL if this isn't at an
410 ;; :UNKNOWN-RETURN code location.
411 (unknown-return-partner nil :type (or null breakpoint))
412 ;; :FUN-END breakpoints use a breakpoint at the :FUN-START
413 ;; to establish the end breakpoint upon function entry. We do this
414 ;; by frobbing the LRA to jump to a special piece of code that
415 ;; breaks and provides the return values for the returnee. This slot
416 ;; points to the start breakpoint, so we can activate, deactivate,
418 (start-helper nil :type (or null breakpoint))
419 ;; This is a hook users supply to get a dynamically unique cookie
420 ;; for identifying :FUN-END breakpoint executions. That is, if
421 ;; there is one :FUN-END breakpoint, but there may be multiple
422 ;; pending calls of its function on the stack. This function takes
423 ;; the cookie, and the hook function takes the cookie too.
424 (cookie-fun nil :type (or null function))
425 ;; This slot users can set with whatever information they find useful.
427 (def!method print-object ((obj breakpoint) str)
428 (let ((what (breakpoint-what obj)))
429 (print-unreadable-object (obj str :type t)
434 (debug-fun (debug-fun-name what)))
437 (debug-fun (breakpoint-kind obj)))))))
441 (defstruct (code-location (:constructor nil)
443 ;; the DEBUG-FUN containing this CODE-LOCATION
444 (debug-fun nil :type debug-fun)
445 ;; This is initially :UNSURE. Upon first trying to access an
446 ;; :UNPARSED slot, if the data is unavailable, then this becomes T,
447 ;; and the code-location is unknown. If the data is available, this
448 ;; becomes NIL, a known location. We can't use a separate type
449 ;; code-location for this since we must return code-locations before
450 ;; we can tell whether they're known or unknown. For example, when
451 ;; parsing the stack, we don't want to unpack all the variables and
452 ;; blocks just to make frames.
453 (%unknown-p :unsure :type (member t nil :unsure))
454 ;; the DEBUG-BLOCK containing CODE-LOCATION. XXX Possibly toss this
455 ;; out and just find it in the blocks cache in DEBUG-FUN.
456 (%debug-block :unparsed :type (or debug-block (member :unparsed)))
457 ;; This is the number of forms processed by the compiler or loader
458 ;; before the top level form containing this code-location.
459 (%tlf-offset :unparsed :type (or index (member :unparsed)))
460 ;; This is the depth-first number of the node that begins
461 ;; code-location within its top level form.
462 (%form-number :unparsed :type (or index (member :unparsed))))
463 (def!method print-object ((obj code-location) str)
464 (print-unreadable-object (obj str :type t)
465 (prin1 (debug-fun-name (code-location-debug-fun obj))
468 (defstruct (compiled-code-location
469 (:include code-location)
470 (:constructor make-known-code-location
471 (pc debug-fun %tlf-offset %form-number
472 %live-set kind step-info &aux (%unknown-p nil)))
473 (:constructor make-compiled-code-location (pc debug-fun))
475 ;; an index into DEBUG-FUN's component slot
477 ;; a bit-vector indexed by a variable's position in
478 ;; DEBUG-FUN-DEBUG-VARS indicating whether the variable has a
479 ;; valid value at this code-location. (unexported).
480 (%live-set :unparsed :type (or simple-bit-vector (member :unparsed)))
481 ;; (unexported) To see SB!C::LOCATION-KIND, do
482 ;; (SB!KERNEL:TYPE-EXPAND 'SB!C::LOCATION-KIND).
483 (kind :unparsed :type (or (member :unparsed) sb!c::location-kind))
484 (step-info :unparsed :type (or (member :unparsed :foo) simple-string)))
488 ;;; Return the number of top level forms processed by the compiler
489 ;;; before compiling this source. If this source is uncompiled, this
490 ;;; is zero. This may be zero even if the source is compiled since the
491 ;;; first form in the first file compiled in one compilation, for
492 ;;; example, must have a root number of zero -- the compiler saw no
493 ;;; other top level forms before it.
494 (defun debug-source-root-number (debug-source)
495 (sb!c::debug-source-source-root debug-source))
499 ;;; This is used in FIND-ESCAPED-FRAME and with the bogus components
500 ;;; and LRAs used for :FUN-END breakpoints. When a component's
501 ;;; debug-info slot is :BOGUS-LRA, then the REAL-LRA-SLOT contains the
502 ;;; real component to continue executing, as opposed to the bogus
503 ;;; component which appeared in some frame's LRA location.
504 (defconstant real-lra-slot sb!vm:code-constants-offset)
506 ;;; These are magically converted by the compiler.
507 (defun current-sp () (current-sp))
508 (defun current-fp () (current-fp))
509 (defun stack-ref (s n) (stack-ref s n))
510 (defun %set-stack-ref (s n value) (%set-stack-ref s n value))
511 (defun fun-code-header (fun) (fun-code-header fun))
512 (defun lra-code-header (lra) (lra-code-header lra))
513 (defun %make-lisp-obj (value) (%make-lisp-obj value))
514 (defun get-lisp-obj-address (thing) (get-lisp-obj-address thing))
515 (defun fun-word-offset (fun) (fun-word-offset fun))
517 #!-sb-fluid (declaim (inline control-stack-pointer-valid-p))
518 (defun control-stack-pointer-valid-p (x)
519 (declare (type system-area-pointer x))
520 (let* (#!-stack-grows-downward-not-upward
522 (descriptor-sap *control-stack-start*))
523 #!+stack-grows-downward-not-upward
525 (descriptor-sap *control-stack-end*)))
526 #!-stack-grows-downward-not-upward
527 (and (sap< x (current-sp))
528 (sap<= control-stack-start x)
529 (zerop (logand (sap-int x) sb!vm:fixnum-tag-mask)))
530 #!+stack-grows-downward-not-upward
531 (and (sap>= x (current-sp))
532 (sap> control-stack-end x)
533 (zerop (logand (sap-int x) sb!vm:fixnum-tag-mask)))))
535 (declaim (inline component-ptr-from-pc))
536 (sb!alien:define-alien-routine component-ptr-from-pc (system-area-pointer)
537 (pc system-area-pointer))
540 (sb!alien:define-alien-routine valid-lisp-pointer-p sb!alien:int
541 (pointer system-area-pointer))
543 (declaim (inline component-from-component-ptr))
544 (defun component-from-component-ptr (component-ptr)
545 (declare (type system-area-pointer component-ptr))
546 (make-lisp-obj (logior (sap-int component-ptr)
547 sb!vm:other-pointer-lowtag)))
549 ;;;; (OR X86 X86-64) support
551 (defun compute-lra-data-from-pc (pc)
552 (declare (type system-area-pointer pc))
553 (let ((component-ptr (component-ptr-from-pc pc)))
554 (unless (sap= component-ptr (int-sap #x0))
555 (let* ((code (component-from-component-ptr component-ptr))
556 (code-header-len (* (get-header-data code) sb!vm:n-word-bytes))
557 (pc-offset (- (sap-int pc)
558 (- (get-lisp-obj-address code)
559 sb!vm:other-pointer-lowtag)
561 ; (format t "c-lra-fpc ~A ~A ~A~%" pc code pc-offset)
562 (values pc-offset code)))))
567 (defconstant sb!vm::nargs-offset #.sb!vm::ecx-offset)
569 ;;; Check for a valid return address - it could be any valid C/Lisp
572 ;;; XXX Could be a little smarter.
573 #!-sb-fluid (declaim (inline ra-pointer-valid-p))
574 (defun ra-pointer-valid-p (ra)
575 (declare (type system-area-pointer ra))
577 ;; not the first page (which is unmapped)
579 ;; FIXME: Where is this documented? Is it really true of every CPU
580 ;; architecture? Is it even necessarily true in current SBCL?
581 (>= (sap-int ra) 4096)
582 ;; not a Lisp stack pointer
583 (not (control-stack-pointer-valid-p ra))))
585 ;;; Try to find a valid previous stack. This is complex on the x86 as
586 ;;; it can jump between C and Lisp frames. To help find a valid frame
587 ;;; it searches backwards.
589 ;;; XXX Should probably check whether it has reached the bottom of the
592 ;;; XXX Should handle interrupted frames, both Lisp and C. At present
593 ;;; it manages to find a fp trail, see linux hack below.
594 (declaim (maybe-inline x86-call-context))
595 (defun x86-call-context (fp)
596 (declare (type system-area-pointer fp))
603 ((not (control-stack-pointer-valid-p fp))
606 ;; Check the two possible frame pointers.
607 (let ((lisp-ocfp (sap-ref-sap fp (- (* (1+ ocfp-save-offset)
608 sb!vm::n-word-bytes))))
609 (lisp-ra (sap-ref-sap fp (- (* (1+ return-pc-save-offset)
610 sb!vm::n-word-bytes))))
611 (c-ocfp (sap-ref-sap fp (* 0 sb!vm:n-word-bytes)))
612 (c-ra (sap-ref-sap fp (* 1 sb!vm:n-word-bytes))))
613 (cond ((and (sap> lisp-ocfp fp)
614 (control-stack-pointer-valid-p lisp-ocfp)
615 (ra-pointer-valid-p lisp-ra)
617 (control-stack-pointer-valid-p c-ocfp)
618 (ra-pointer-valid-p c-ra))
619 ;; Look forward another step to check their validity.
620 (let ((lisp-ok (handle lisp-ocfp))
621 (c-ok (handle c-ocfp)))
622 (cond ((and lisp-ok c-ok)
623 ;; Both still seem valid - choose the lisp frame.
625 (if (sap> lisp-ocfp c-ocfp)
626 (values t lisp-ra lisp-ocfp)
627 (values t c-ra c-ocfp))
629 (values t lisp-ra lisp-ocfp))
631 ;; The lisp convention is looking good.
632 (values t lisp-ra lisp-ocfp))
634 ;; The C convention is looking good.
635 (values t c-ra c-ocfp))
637 ;; Neither seems right?
639 ((and (sap> lisp-ocfp fp)
640 (control-stack-pointer-valid-p lisp-ocfp)
641 (ra-pointer-valid-p lisp-ra))
642 ;; The lisp convention is looking good.
643 (values t lisp-ra lisp-ocfp))
644 ((and (sap> c-ocfp fp)
645 (control-stack-pointer-valid-p c-ocfp)
646 #!-linux (ra-pointer-valid-p c-ra))
647 ;; The C convention is looking good.
648 (values t c-ra c-ocfp))
655 ;;; Convert the descriptor into a SAP. The bits all stay the same, we just
656 ;;; change our notion of what we think they are.
657 #!-sb-fluid (declaim (inline descriptor-sap))
658 (defun descriptor-sap (x)
659 (int-sap (get-lisp-obj-address x)))
661 ;;; Return the top frame of the control stack as it was before calling
664 (/noshow0 "entering TOP-FRAME")
665 (multiple-value-bind (fp pc) (%caller-frame-and-pc)
666 (compute-calling-frame (descriptor-sap fp) pc nil)))
668 ;;; Flush all of the frames above FRAME, and renumber all the frames
670 (defun flush-frames-above (frame)
671 (setf (frame-up frame) nil)
672 (do ((number 0 (1+ number))
673 (frame frame (frame-%down frame)))
674 ((not (frame-p frame)))
675 (setf (frame-number frame) number)))
677 ;;; Return the frame immediately below FRAME on the stack; or when
678 ;;; FRAME is the bottom of the stack, return NIL.
679 (defun frame-down (frame)
680 (/noshow0 "entering FRAME-DOWN")
681 ;; We have to access the old-fp and return-pc out of frame and pass
682 ;; them to COMPUTE-CALLING-FRAME.
683 (let ((down (frame-%down frame)))
684 (if (eq down :unparsed)
685 (let ((debug-fun (frame-debug-fun frame)))
686 (/noshow0 "in DOWN :UNPARSED case")
687 (setf (frame-%down frame)
690 (let ((c-d-f (compiled-debug-fun-compiler-debug-fun
692 (compute-calling-frame
695 frame ocfp-save-offset
696 (sb!c::compiled-debug-fun-old-fp c-d-f)))
698 frame lra-save-offset
699 (sb!c::compiled-debug-fun-return-pc c-d-f))
702 (let ((fp (frame-pointer frame)))
703 (when (control-stack-pointer-valid-p fp)
705 (multiple-value-bind (ok ra ofp) (x86-call-context fp)
707 (compute-calling-frame ofp ra frame)))
709 (compute-calling-frame
711 (sap-ref-sap fp (* ocfp-save-offset
715 (sap-ref-32 fp (* ocfp-save-offset
716 sb!vm:n-word-bytes)))
718 (stack-ref fp lra-save-offset)
723 ;;; Get the old FP or return PC out of FRAME. STACK-SLOT is the
724 ;;; standard save location offset on the stack. LOC is the saved
725 ;;; SC-OFFSET describing the main location.
726 (defun get-context-value (frame stack-slot loc)
727 (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
728 (type sb!c:sc-offset loc))
729 (let ((pointer (frame-pointer frame))
730 (escaped (compiled-frame-escaped frame)))
732 (sub-access-debug-var-slot pointer loc escaped)
734 (stack-ref pointer stack-slot)
738 (stack-ref pointer stack-slot))
740 (sap-ref-sap pointer (- (* (1+ stack-slot)
741 sb!vm::n-word-bytes))))))))
743 (defun (setf get-context-value) (value frame stack-slot loc)
744 (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
745 (type sb!c:sc-offset loc))
746 (let ((pointer (frame-pointer frame))
747 (escaped (compiled-frame-escaped frame)))
749 (sub-set-debug-var-slot pointer loc value escaped)
751 (setf (stack-ref pointer stack-slot) value)
755 (setf (stack-ref pointer stack-slot) value))
757 (setf (sap-ref-sap pointer (- (* (1+ stack-slot)
758 sb!vm::n-word-bytes))) value))))))
760 (defun foreign-function-backtrace-name (sap)
761 (let ((name (sap-foreign-symbol sap)))
763 (format nil "foreign function: ~A" name)
764 (format nil "foreign function: #x~X" (sap-int sap)))))
766 ;;; This returns a frame for the one existing in time immediately
767 ;;; prior to the frame referenced by current-fp. This is current-fp's
768 ;;; caller or the next frame down the control stack. If there is no
769 ;;; down frame, this returns NIL for the bottom of the stack. UP-FRAME
770 ;;; is the up link for the resulting frame object, and it is null when
771 ;;; we call this to get the top of the stack.
773 ;;; The current frame contains the pointer to the temporally previous
774 ;;; frame we want, and the current frame contains the pc at which we
775 ;;; will continue executing upon returning to that previous frame.
777 ;;; Note: Sometimes LRA is actually a fixnum. This happens when lisp
778 ;;; calls into C. In this case, the code object is stored on the stack
779 ;;; after the LRA, and the LRA is the word offset.
781 (defun compute-calling-frame (caller lra up-frame)
782 (declare (type system-area-pointer caller))
783 (when (control-stack-pointer-valid-p caller)
784 (multiple-value-bind (code pc-offset escaped)
786 (multiple-value-bind (word-offset code)
788 (let ((fp (frame-pointer up-frame)))
790 (stack-ref fp (1+ lra-save-offset))))
791 (values (get-header-data lra)
792 (lra-code-header lra)))
795 (* (1+ (- word-offset (get-header-data code)))
798 (values :foreign-function
801 (find-escaped-frame caller))
802 (if (and (code-component-p code)
803 (eq (%code-debug-info code) :bogus-lra))
804 (let ((real-lra (code-header-ref code real-lra-slot)))
805 (compute-calling-frame caller real-lra up-frame))
806 (let ((d-fun (case code
808 (make-bogus-debug-fun
809 "undefined function"))
811 (make-bogus-debug-fun
812 (foreign-function-backtrace-name
813 (int-sap (get-lisp-obj-address lra)))))
815 (make-bogus-debug-fun
816 "bogus stack frame"))
818 (debug-fun-from-pc code pc-offset)))))
819 (make-compiled-frame caller up-frame d-fun
820 (code-location-from-pc d-fun pc-offset
822 (if up-frame (1+ (frame-number up-frame)) 0)
826 (defun compute-calling-frame (caller ra up-frame)
827 (declare (type system-area-pointer caller ra))
828 (/noshow0 "entering COMPUTE-CALLING-FRAME")
829 (when (control-stack-pointer-valid-p caller)
831 ;; First check for an escaped frame.
832 (multiple-value-bind (code pc-offset escaped) (find-escaped-frame caller)
835 ;; If it's escaped it may be a function end breakpoint trap.
836 (when (and (code-component-p code)
837 (eq (%code-debug-info code) :bogus-lra))
838 ;; If :bogus-lra grab the real lra.
839 (setq pc-offset (code-header-ref
840 code (1+ real-lra-slot)))
841 (setq code (code-header-ref code real-lra-slot))
844 (multiple-value-setq (pc-offset code)
845 (compute-lra-data-from-pc ra))
847 (setf code :foreign-function
849 (let ((d-fun (case code
851 (make-bogus-debug-fun
852 "undefined function"))
854 (make-bogus-debug-fun
855 (foreign-function-backtrace-name ra)))
857 (make-bogus-debug-fun
858 "bogus stack frame"))
860 (debug-fun-from-pc code pc-offset)))))
861 (/noshow0 "returning MAKE-COMPILED-FRAME from COMPUTE-CALLING-FRAME")
862 (make-compiled-frame caller up-frame d-fun
863 (code-location-from-pc d-fun pc-offset
865 (if up-frame (1+ (frame-number up-frame)) 0)
868 (defun nth-interrupt-context (n)
869 (declare (type (unsigned-byte 32) n)
870 (optimize (speed 3) (safety 0)))
871 (sb!alien:sap-alien (sb!vm::current-thread-offset-sap
872 (+ sb!vm::thread-interrupt-contexts-offset n))
876 (defun find-escaped-frame (frame-pointer)
877 (declare (type system-area-pointer frame-pointer))
878 (/noshow0 "entering FIND-ESCAPED-FRAME")
879 (dotimes (index *free-interrupt-context-index* (values nil 0 nil))
880 (/noshow0 "at head of WITH-ALIEN")
881 (let ((context (nth-interrupt-context index)))
882 (/noshow0 "got CONTEXT")
883 (when (= (sap-int frame-pointer)
884 (sb!vm:context-register context sb!vm::cfp-offset))
886 (/noshow0 "in WITHOUT-GCING")
887 (let* ((component-ptr (component-ptr-from-pc
888 (sb!vm:context-pc context)))
889 (code (unless (sap= component-ptr (int-sap #x0))
890 (component-from-component-ptr component-ptr))))
891 (/noshow0 "got CODE")
893 (return (values code 0 context)))
894 (let* ((code-header-len (* (get-header-data code)
897 (- (sap-int (sb!vm:context-pc context))
898 (- (get-lisp-obj-address code)
899 sb!vm:other-pointer-lowtag)
901 (/noshow "got PC-OFFSET")
902 (unless (<= 0 pc-offset
903 (* (code-header-ref code sb!vm:code-code-size-slot)
905 ;; We were in an assembly routine. Therefore, use the
908 ;; FIXME: Should this be WARN or ERROR or what?
909 (format t "** pc-offset ~S not in code obj ~S?~%"
911 (/noshow0 "returning from FIND-ESCAPED-FRAME")
913 (values code pc-offset context)))))))))
916 (defun find-escaped-frame (frame-pointer)
917 (declare (type system-area-pointer frame-pointer))
918 (dotimes (index *free-interrupt-context-index* (values nil 0 nil))
919 (let ((scp (nth-interrupt-context index)))
920 (when (= (sap-int frame-pointer)
921 (sb!vm:context-register scp sb!vm::cfp-offset))
923 (let ((code (code-object-from-bits
924 (sb!vm:context-register scp sb!vm::code-offset))))
926 (return (values code 0 scp)))
927 (let* ((code-header-len (* (get-header-data code)
930 (- (sap-int (sb!vm:context-pc scp))
931 (- (get-lisp-obj-address code)
932 sb!vm:other-pointer-lowtag)
934 (let ((code-size (* (code-header-ref code
935 sb!vm:code-code-size-slot)
936 sb!vm:n-word-bytes)))
937 (unless (<= 0 pc-offset code-size)
938 ;; We were in an assembly routine.
939 (multiple-value-bind (new-pc-offset computed-return)
940 (find-pc-from-assembly-fun code scp)
941 (setf pc-offset new-pc-offset)
942 (unless (<= 0 pc-offset code-size)
944 "Set PC-OFFSET to zero and continue backtrace."
947 "~@<PC-OFFSET (~D) not in code object. Frame details:~
948 ~2I~:@_PC: #X~X~:@_CODE: ~S~:@_CODE FUN: ~S~:@_LRA: ~
949 #X~X~:@_COMPUTED RETURN: #X~X.~:>"
952 (sap-int (sb!vm:context-pc scp))
954 (%code-entry-points code)
955 (sb!vm:context-register scp sb!vm::lra-offset)
957 ;; We failed to pinpoint where PC is, but set
958 ;; pc-offset to 0 to keep the backtrace from
960 (setf pc-offset 0)))))
962 (if (eq (%code-debug-info code) :bogus-lra)
963 (let ((real-lra (code-header-ref code
965 (values (lra-code-header real-lra)
966 (get-header-data real-lra)
968 (values code pc-offset scp))))))))))
971 (defun find-pc-from-assembly-fun (code scp)
972 "Finds the PC for the return from an assembly routine properly.
973 For some architectures (such as PPC) this will not be the $LRA
975 (let ((return-machine-address (sb!vm::return-machine-address scp))
976 (code-header-len (* (get-header-data code) sb!vm:n-word-bytes)))
977 (values (- return-machine-address
978 (- (get-lisp-obj-address code)
979 sb!vm:other-pointer-lowtag)
981 return-machine-address)))
983 ;;; Find the code object corresponding to the object represented by
984 ;;; bits and return it. We assume bogus functions correspond to the
985 ;;; undefined-function.
987 (defun code-object-from-bits (bits)
988 (declare (type (unsigned-byte 32) bits))
989 (let ((object (make-lisp-obj bits nil)))
990 (if (functionp object)
991 (or (fun-code-header object)
993 (let ((lowtag (lowtag-of object)))
994 (when (= lowtag sb!vm:other-pointer-lowtag)
995 (let ((widetag (widetag-of object)))
996 (cond ((= widetag sb!vm:code-header-widetag)
998 ((= widetag sb!vm:return-pc-header-widetag)
999 (lra-code-header object))
1003 ;;;; frame utilities
1005 ;;; This returns a COMPILED-DEBUG-FUN for COMPONENT and PC. We fetch the
1006 ;;; SB!C::DEBUG-INFO and run down its FUN-MAP to get a
1007 ;;; SB!C::COMPILED-DEBUG-FUN from the PC. The result only needs to
1008 ;;; reference the COMPONENT, for function constants, and the
1009 ;;; SB!C::COMPILED-DEBUG-FUN.
1010 (defun debug-fun-from-pc (component pc)
1011 (let ((info (%code-debug-info component)))
1014 ;; FIXME: It seems that most of these (at least on x86) are
1015 ;; actually assembler routines, and could be named by looking
1016 ;; at the sb-fasl:*assembler-routines*.
1017 (make-bogus-debug-fun "no debug information for frame"))
1018 ((eq info :bogus-lra)
1019 (make-bogus-debug-fun "function end breakpoint"))
1021 (let* ((fun-map (sb!c::compiled-debug-info-fun-map info))
1022 (len (length fun-map)))
1023 (declare (type simple-vector fun-map))
1025 (make-compiled-debug-fun (svref fun-map 0) component)
1028 (>= pc (sb!c::compiled-debug-fun-elsewhere-pc
1029 (svref fun-map 0)))))
1030 (declare (type sb!int:index i))
1033 (< pc (if elsewhere-p
1034 (sb!c::compiled-debug-fun-elsewhere-pc
1035 (svref fun-map (1+ i)))
1036 (svref fun-map i))))
1037 (return (make-compiled-debug-fun
1038 (svref fun-map (1- i))
1042 ;;; This returns a code-location for the COMPILED-DEBUG-FUN,
1043 ;;; DEBUG-FUN, and the pc into its code vector. If we stopped at a
1044 ;;; breakpoint, find the CODE-LOCATION for that breakpoint. Otherwise,
1045 ;;; make an :UNSURE code location, so it can be filled in when we
1046 ;;; figure out what is going on.
1047 (defun code-location-from-pc (debug-fun pc escaped)
1048 (or (and (compiled-debug-fun-p debug-fun)
1050 (let ((data (breakpoint-data
1051 (compiled-debug-fun-component debug-fun)
1053 (when (and data (breakpoint-data-breakpoints data))
1054 (let ((what (breakpoint-what
1055 (first (breakpoint-data-breakpoints data)))))
1056 (when (compiled-code-location-p what)
1058 (make-compiled-code-location pc debug-fun)))
1060 ;;; Return an alist mapping catch tags to CODE-LOCATIONs. These are
1061 ;;; CODE-LOCATIONs at which execution would continue with frame as the
1062 ;;; top frame if someone threw to the corresponding tag.
1063 (defun frame-catches (frame)
1064 (let ((catch (descriptor-sap sb!vm:*current-catch-block*))
1065 (reversed-result nil)
1066 (fp (frame-pointer frame)))
1067 (loop until (zerop (sap-int catch))
1068 finally (return (nreverse reversed-result))
1073 (* sb!vm:catch-block-current-cont-slot
1074 sb!vm:n-word-bytes))
1078 (* sb!vm:catch-block-current-cont-slot
1079 sb!vm:n-word-bytes))))
1080 (let* (#!-(or x86 x86-64)
1081 (lra (stack-ref catch sb!vm:catch-block-entry-pc-slot))
1084 catch (* sb!vm:catch-block-entry-pc-slot
1085 sb!vm:n-word-bytes)))
1088 (stack-ref catch sb!vm:catch-block-current-code-slot))
1090 (component (component-from-component-ptr
1091 (component-ptr-from-pc ra)))
1094 (* (- (1+ (get-header-data lra))
1095 (get-header-data component))
1099 (- (get-lisp-obj-address component)
1100 sb!vm:other-pointer-lowtag)
1101 (* (get-header-data component) sb!vm:n-word-bytes))))
1102 (push (cons #!-(or x86 x86-64)
1103 (stack-ref catch sb!vm:catch-block-tag-slot)
1106 (sap-ref-word catch (* sb!vm:catch-block-tag-slot
1107 sb!vm:n-word-bytes)))
1108 (make-compiled-code-location
1109 offset (frame-debug-fun frame)))
1114 (* sb!vm:catch-block-previous-catch-slot
1115 sb!vm:n-word-bytes))
1119 (* sb!vm:catch-block-previous-catch-slot
1120 sb!vm:n-word-bytes)))))))
1122 ;;; Modify the value of the OLD-TAG catches in FRAME to NEW-TAG
1123 (defun replace-frame-catch-tag (frame old-tag new-tag)
1124 (let ((catch (descriptor-sap sb!vm:*current-catch-block*))
1125 (fp (frame-pointer frame)))
1126 (loop until (zerop (sap-int catch))
1130 (* sb!vm:catch-block-current-cont-slot
1131 sb!vm:n-word-bytes))
1135 (* sb!vm:catch-block-current-cont-slot
1136 sb!vm:n-word-bytes))))
1139 (stack-ref catch sb!vm:catch-block-tag-slot)
1142 (sap-ref-word catch (* sb!vm:catch-block-tag-slot
1143 sb!vm:n-word-bytes)))))
1144 (when (eq current-tag old-tag)
1146 (setf (stack-ref catch sb!vm:catch-block-tag-slot) new-tag)
1148 (setf (sap-ref-word catch (* sb!vm:catch-block-tag-slot
1149 sb!vm:n-word-bytes))
1150 (get-lisp-obj-address new-tag)))))
1154 (* sb!vm:catch-block-previous-catch-slot
1155 sb!vm:n-word-bytes))
1159 (* sb!vm:catch-block-previous-catch-slot
1160 sb!vm:n-word-bytes)))))))
1164 ;;;; operations on DEBUG-FUNs
1166 ;;; Execute the forms in a context with BLOCK-VAR bound to each
1167 ;;; DEBUG-BLOCK in DEBUG-FUN successively. Result is an optional
1168 ;;; form to execute for return values, and DO-DEBUG-FUN-BLOCKS
1169 ;;; returns nil if there is no result form. This signals a
1170 ;;; NO-DEBUG-BLOCKS condition when the DEBUG-FUN lacks
1171 ;;; DEBUG-BLOCK information.
1172 (defmacro do-debug-fun-blocks ((block-var debug-fun &optional result)
1174 (let ((blocks (gensym))
1176 `(let ((,blocks (debug-fun-debug-blocks ,debug-fun)))
1177 (declare (simple-vector ,blocks))
1178 (dotimes (,i (length ,blocks) ,result)
1179 (let ((,block-var (svref ,blocks ,i)))
1182 ;;; Execute body in a context with VAR bound to each DEBUG-VAR in
1183 ;;; DEBUG-FUN. This returns the value of executing result (defaults to
1184 ;;; nil). This may iterate over only some of DEBUG-FUN's variables or
1185 ;;; none depending on debug policy; for example, possibly the
1186 ;;; compilation only preserved argument information.
1187 (defmacro do-debug-fun-vars ((var debug-fun &optional result) &body body)
1188 (let ((vars (gensym))
1190 `(let ((,vars (debug-fun-debug-vars ,debug-fun)))
1191 (declare (type (or null simple-vector) ,vars))
1193 (dotimes (,i (length ,vars) ,result)
1194 (let ((,var (svref ,vars ,i)))
1198 ;;; Return the object of type FUNCTION associated with the DEBUG-FUN,
1199 ;;; or NIL if the function is unavailable or is non-existent as a user
1200 ;;; callable function object.
1201 (defun debug-fun-fun (debug-fun)
1202 (let ((cached-value (debug-fun-%function debug-fun)))
1203 (if (eq cached-value :unparsed)
1204 (setf (debug-fun-%function debug-fun)
1205 (etypecase debug-fun
1208 (compiled-debug-fun-component debug-fun))
1210 (sb!c::compiled-debug-fun-start-pc
1211 (compiled-debug-fun-compiler-debug-fun debug-fun))))
1212 (do ((entry (%code-entry-points component)
1213 (%simple-fun-next entry)))
1216 (sb!c::compiled-debug-fun-start-pc
1217 (compiled-debug-fun-compiler-debug-fun
1218 (fun-debug-fun entry))))
1220 (bogus-debug-fun nil)))
1223 ;;; Return the name of the function represented by DEBUG-FUN. This may
1224 ;;; be a string or a cons; do not assume it is a symbol.
1225 (defun debug-fun-name (debug-fun)
1226 (declare (type debug-fun debug-fun))
1227 (etypecase debug-fun
1229 (sb!c::compiled-debug-fun-name
1230 (compiled-debug-fun-compiler-debug-fun debug-fun)))
1232 (bogus-debug-fun-%name debug-fun))))
1234 ;;; Return a DEBUG-FUN that represents debug information for FUN.
1235 (defun fun-debug-fun (fun)
1236 (declare (type function fun))
1237 (ecase (widetag-of fun)
1238 (#.sb!vm:closure-header-widetag
1239 (fun-debug-fun (%closure-fun fun)))
1240 (#.sb!vm:funcallable-instance-header-widetag
1241 (fun-debug-fun (funcallable-instance-fun fun)))
1242 (#.sb!vm:simple-fun-header-widetag
1243 (let* ((name (%simple-fun-name fun))
1244 (component (fun-code-header fun))
1247 (and (sb!c::compiled-debug-fun-p x)
1248 (eq (sb!c::compiled-debug-fun-name x) name)
1249 (eq (sb!c::compiled-debug-fun-kind x) nil)))
1250 (sb!c::compiled-debug-info-fun-map
1251 (%code-debug-info component)))))
1253 (make-compiled-debug-fun res component)
1254 ;; KLUDGE: comment from CMU CL:
1255 ;; This used to be the non-interpreted branch, but
1256 ;; William wrote it to return the debug-fun of fun's XEP
1257 ;; instead of fun's debug-fun. The above code does this
1258 ;; more correctly, but it doesn't get or eliminate all
1259 ;; appropriate cases. It mostly works, and probably
1260 ;; works for all named functions anyway.
1262 (debug-fun-from-pc component
1263 (* (- (fun-word-offset fun)
1264 (get-header-data component))
1265 sb!vm:n-word-bytes)))))))
1267 ;;; Return the kind of the function, which is one of :OPTIONAL,
1268 ;;; :EXTERNAL, :TOPLEVEL, :CLEANUP, or NIL.
1269 (defun debug-fun-kind (debug-fun)
1270 ;; FIXME: This "is one of" information should become part of the function
1271 ;; declamation, not just a doc string
1272 (etypecase debug-fun
1274 (sb!c::compiled-debug-fun-kind
1275 (compiled-debug-fun-compiler-debug-fun debug-fun)))
1279 ;;; Is there any variable information for DEBUG-FUN?
1280 (defun debug-var-info-available (debug-fun)
1281 (not (not (debug-fun-debug-vars debug-fun))))
1283 ;;; Return a list of DEBUG-VARs in DEBUG-FUN having the same name
1284 ;;; and package as SYMBOL. If SYMBOL is uninterned, then this returns
1285 ;;; a list of DEBUG-VARs without package names and with the same name
1286 ;;; as symbol. The result of this function is limited to the
1287 ;;; availability of variable information in DEBUG-FUN; for
1288 ;;; example, possibly DEBUG-FUN only knows about its arguments.
1289 (defun debug-fun-symbol-vars (debug-fun symbol)
1290 (let ((vars (ambiguous-debug-vars debug-fun (symbol-name symbol)))
1291 (package (and (symbol-package symbol)
1292 (package-name (symbol-package symbol)))))
1293 (delete-if (if (stringp package)
1295 (let ((p (debug-var-package-name var)))
1296 (or (not (stringp p))
1297 (string/= p package))))
1299 (stringp (debug-var-package-name var))))
1302 ;;; Return a list of DEBUG-VARs in DEBUG-FUN whose names contain
1303 ;;; NAME-PREFIX-STRING as an initial substring. The result of this
1304 ;;; function is limited to the availability of variable information in
1305 ;;; debug-fun; for example, possibly debug-fun only knows
1306 ;;; about its arguments.
1307 (defun ambiguous-debug-vars (debug-fun name-prefix-string)
1308 (declare (simple-string name-prefix-string))
1309 (let ((variables (debug-fun-debug-vars debug-fun)))
1310 (declare (type (or null simple-vector) variables))
1312 (let* ((len (length variables))
1313 (prefix-len (length name-prefix-string))
1314 (pos (find-var name-prefix-string variables len))
1317 ;; Find names from pos to variable's len that contain prefix.
1318 (do ((i pos (1+ i)))
1320 (let* ((var (svref variables i))
1321 (name (debug-var-symbol-name var))
1322 (name-len (length name)))
1323 (declare (simple-string name))
1324 (when (/= (or (string/= name-prefix-string name
1325 :end1 prefix-len :end2 name-len)
1330 (setq res (nreverse res)))
1333 ;;; This returns a position in VARIABLES for one containing NAME as an
1334 ;;; initial substring. END is the length of VARIABLES if supplied.
1335 (defun find-var (name variables &optional end)
1336 (declare (simple-vector variables)
1337 (simple-string name))
1338 (let ((name-len (length name)))
1339 (position name variables
1341 (let* ((y (debug-var-symbol-name y))
1343 (declare (simple-string y))
1344 (and (>= y-len name-len)
1345 (string= x y :end1 name-len :end2 name-len))))
1346 :end (or end (length variables)))))
1348 ;;; Return a list representing the lambda-list for DEBUG-FUN. The
1349 ;;; list has the following structure:
1350 ;;; (required-var1 required-var2
1352 ;;; (:optional var3 suppliedp-var4)
1353 ;;; (:optional var5)
1355 ;;; (:rest var6) (:rest var7)
1357 ;;; (:keyword keyword-symbol var8 suppliedp-var9)
1358 ;;; (:keyword keyword-symbol var10)
1361 ;;; Each VARi is a DEBUG-VAR; however it may be the symbol :DELETED if
1362 ;;; it is unreferenced in DEBUG-FUN. This signals a
1363 ;;; LAMBDA-LIST-UNAVAILABLE condition when there is no argument list
1365 (defun debug-fun-lambda-list (debug-fun)
1366 (etypecase debug-fun
1367 (compiled-debug-fun (compiled-debug-fun-lambda-list debug-fun))
1368 (bogus-debug-fun nil)))
1370 ;;; Note: If this has to compute the lambda list, it caches it in DEBUG-FUN.
1371 (defun compiled-debug-fun-lambda-list (debug-fun)
1372 (let ((lambda-list (debug-fun-%lambda-list debug-fun)))
1373 (cond ((eq lambda-list :unparsed)
1374 (multiple-value-bind (args argsp)
1375 (parse-compiled-debug-fun-lambda-list debug-fun)
1376 (setf (debug-fun-%lambda-list debug-fun) args)
1379 (debug-signal 'lambda-list-unavailable
1380 :debug-fun debug-fun))))
1382 ((bogus-debug-fun-p debug-fun)
1384 ((sb!c::compiled-debug-fun-arguments
1385 (compiled-debug-fun-compiler-debug-fun debug-fun))
1386 ;; If the packed information is there (whether empty or not) as
1387 ;; opposed to being nil, then returned our cached value (nil).
1390 ;; Our cached value is nil, and the packed lambda-list information
1391 ;; is nil, so we don't have anything available.
1392 (debug-signal 'lambda-list-unavailable
1393 :debug-fun debug-fun)))))
1395 ;;; COMPILED-DEBUG-FUN-LAMBDA-LIST calls this when a
1396 ;;; COMPILED-DEBUG-FUN has no lambda list information cached. It
1397 ;;; returns the lambda list as the first value and whether there was
1398 ;;; any argument information as the second value. Therefore,
1399 ;;; (VALUES NIL T) means there were no arguments, but (VALUES NIL NIL)
1400 ;;; means there was no argument information.
1401 (defun parse-compiled-debug-fun-lambda-list (debug-fun)
1402 (let ((args (sb!c::compiled-debug-fun-arguments
1403 (compiled-debug-fun-compiler-debug-fun debug-fun))))
1408 (values (coerce (debug-fun-debug-vars debug-fun) 'list)
1411 (let ((vars (debug-fun-debug-vars debug-fun))
1416 (declare (type (or null simple-vector) vars))
1418 (when (>= i len) (return))
1419 (let ((ele (aref args i)))
1424 ;; Deleted required arg at beginning of args array.
1425 (push :deleted res))
1426 (sb!c::optional-args
1429 ;; SUPPLIED-P var immediately following keyword or
1430 ;; optional. Stick the extra var in the result
1431 ;; element representing the keyword or optional,
1432 ;; which is the previous one.
1434 ;; FIXME: NCONC used for side-effect: the effect is defined,
1435 ;; but this is bad style no matter what.
1437 (list (compiled-debug-fun-lambda-list-var
1438 args (incf i) vars))))
1441 (compiled-debug-fun-lambda-list-var
1442 args (incf i) vars))
1445 ;; Just ignore the fact that the next two args are
1446 ;; the &MORE arg context and count, and act like they
1447 ;; are regular arguments.
1451 (push (list :keyword
1453 (compiled-debug-fun-lambda-list-var
1454 args (incf i) vars))
1457 ;; We saw an optional marker, so the following
1458 ;; non-symbols are indexes indicating optional
1460 (push (list :optional (svref vars ele)) res))
1462 ;; Required arg at beginning of args array.
1463 (push (svref vars ele) res))))
1465 (values (nreverse res) t))))))
1467 ;;; This is used in COMPILED-DEBUG-FUN-LAMBDA-LIST.
1468 (defun compiled-debug-fun-lambda-list-var (args i vars)
1469 (declare (type (simple-array * (*)) args)
1470 (simple-vector vars))
1471 (let ((ele (aref args i)))
1472 (cond ((not (symbolp ele)) (svref vars ele))
1473 ((eq ele 'sb!c::deleted) :deleted)
1474 (t (error "malformed arguments description")))))
1476 (defun compiled-debug-fun-debug-info (debug-fun)
1477 (%code-debug-info (compiled-debug-fun-component debug-fun)))
1479 ;;;; unpacking variable and basic block data
1481 (defvar *parsing-buffer*
1482 (make-array 20 :adjustable t :fill-pointer t))
1483 (defvar *other-parsing-buffer*
1484 (make-array 20 :adjustable t :fill-pointer t))
1485 ;;; PARSE-DEBUG-BLOCKS and PARSE-DEBUG-VARS
1486 ;;; use this to unpack binary encoded information. It returns the
1487 ;;; values returned by the last form in body.
1489 ;;; This binds buffer-var to *parsing-buffer*, makes sure it starts at
1490 ;;; element zero, and makes sure if we unwind, we nil out any set
1491 ;;; elements for GC purposes.
1493 ;;; This also binds other-var to *other-parsing-buffer* when it is
1494 ;;; supplied, making sure it starts at element zero and that we nil
1495 ;;; out any elements if we unwind.
1497 ;;; This defines the local macro RESULT that takes a buffer, copies
1498 ;;; its elements to a resulting simple-vector, nil's out elements, and
1499 ;;; restarts the buffer at element zero. RESULT returns the
1501 (eval-when (:compile-toplevel :execute)
1502 (sb!xc:defmacro with-parsing-buffer ((buffer-var &optional other-var)
1504 (let ((len (gensym))
1507 (let ((,buffer-var *parsing-buffer*)
1508 ,@(if other-var `((,other-var *other-parsing-buffer*))))
1509 (setf (fill-pointer ,buffer-var) 0)
1510 ,@(if other-var `((setf (fill-pointer ,other-var) 0)))
1511 (macrolet ((result (buf)
1512 `(let* ((,',len (length ,buf))
1513 (,',res (make-array ,',len)))
1514 (replace ,',res ,buf :end1 ,',len :end2 ,',len)
1515 (fill ,buf nil :end ,',len)
1516 (setf (fill-pointer ,buf) 0)
1519 (fill *parsing-buffer* nil)
1520 ,@(if other-var `((fill *other-parsing-buffer* nil))))))
1523 ;;; The argument is a debug internals structure. This returns the
1524 ;;; DEBUG-BLOCKs for DEBUG-FUN, regardless of whether we have unpacked
1525 ;;; them yet. It signals a NO-DEBUG-BLOCKS condition if it can't
1526 ;;; return the blocks.
1527 (defun debug-fun-debug-blocks (debug-fun)
1528 (let ((blocks (debug-fun-blocks debug-fun)))
1529 (cond ((eq blocks :unparsed)
1530 (setf (debug-fun-blocks debug-fun)
1531 (parse-debug-blocks debug-fun))
1532 (unless (debug-fun-blocks debug-fun)
1533 (debug-signal 'no-debug-blocks
1534 :debug-fun debug-fun))
1535 (debug-fun-blocks debug-fun))
1538 (debug-signal 'no-debug-blocks
1539 :debug-fun debug-fun)))))
1541 ;;; Return a SIMPLE-VECTOR of DEBUG-BLOCKs or NIL. NIL indicates there
1542 ;;; was no basic block information.
1543 (defun parse-debug-blocks (debug-fun)
1544 (etypecase debug-fun
1546 (parse-compiled-debug-blocks debug-fun))
1548 (debug-signal 'no-debug-blocks :debug-fun debug-fun))))
1550 ;;; This does some of the work of PARSE-DEBUG-BLOCKS.
1551 (defun parse-compiled-debug-blocks (debug-fun)
1552 (let* ((var-count (length (debug-fun-debug-vars debug-fun)))
1553 (compiler-debug-fun (compiled-debug-fun-compiler-debug-fun
1555 (blocks (sb!c::compiled-debug-fun-blocks compiler-debug-fun))
1556 ;; KLUDGE: 8 is a hard-wired constant in the compiler for the
1557 ;; element size of the packed binary representation of the
1559 (live-set-len (ceiling var-count 8))
1560 (tlf-number (sb!c::compiled-debug-fun-tlf-number compiler-debug-fun)))
1562 (return-from parse-compiled-debug-blocks nil))
1563 (macrolet ((aref+ (a i) `(prog1 (aref ,a ,i) (incf ,i))))
1564 (with-parsing-buffer (blocks-buffer locations-buffer)
1566 (len (length blocks))
1569 (when (>= i len) (return))
1570 (let ((succ-and-flags (aref+ blocks i))
1572 (declare (type (unsigned-byte 8) succ-and-flags)
1574 (dotimes (k (ldb sb!c::compiled-debug-block-nsucc-byte
1576 (push (sb!c:read-var-integer blocks i) successors))
1578 (dotimes (k (sb!c:read-var-integer blocks i)
1579 (result locations-buffer))
1580 (let ((kind (svref sb!c::*compiled-code-location-kinds*
1583 (sb!c:read-var-integer blocks i)))
1584 (tlf-offset (or tlf-number
1585 (sb!c:read-var-integer blocks i)))
1586 (form-number (sb!c:read-var-integer blocks i))
1587 (live-set (sb!c:read-packed-bit-vector
1588 live-set-len blocks i))
1589 (step-info (sb!c:read-var-string blocks i)))
1590 (vector-push-extend (make-known-code-location
1591 pc debug-fun tlf-offset
1592 form-number live-set kind
1595 (setf last-pc pc))))
1596 (block (make-compiled-debug-block
1597 locations successors
1599 sb!c::compiled-debug-block-elsewhere-p
1600 succ-and-flags))))))
1601 (vector-push-extend block blocks-buffer)
1602 (dotimes (k (length locations))
1603 (setf (code-location-%debug-block (svref locations k))
1605 (let ((res (result blocks-buffer)))
1606 (declare (simple-vector res))
1607 (dotimes (i (length res))
1608 (let* ((block (svref res i))
1610 (dolist (ele (debug-block-successors block))
1611 (push (svref res ele) succs))
1612 (setf (debug-block-successors block) succs)))
1615 ;;; The argument is a debug internals structure. This returns NIL if
1616 ;;; there is no variable information. It returns an empty
1617 ;;; simple-vector if there were no locals in the function. Otherwise
1618 ;;; it returns a SIMPLE-VECTOR of DEBUG-VARs.
1619 (defun debug-fun-debug-vars (debug-fun)
1620 (let ((vars (debug-fun-%debug-vars debug-fun)))
1621 (if (eq vars :unparsed)
1622 (setf (debug-fun-%debug-vars debug-fun)
1623 (etypecase debug-fun
1625 (parse-compiled-debug-vars debug-fun))
1626 (bogus-debug-fun nil)))
1629 ;;; VARS is the parsed variables for a minimal debug function. We need
1630 ;;; to assign names of the form ARG-NNN. We must pad with leading
1631 ;;; zeros, since the arguments must be in alphabetical order.
1632 (defun assign-minimal-var-names (vars)
1633 (declare (simple-vector vars))
1634 (let* ((len (length vars))
1635 (width (length (format nil "~W" (1- len)))))
1637 (without-package-locks
1638 (setf (compiled-debug-var-symbol (svref vars i))
1639 (intern (format nil "ARG-~V,'0D" width i)
1640 ;; KLUDGE: It's somewhat nasty to have a bare
1641 ;; package name string here. It would be
1642 ;; nicer to have #.(FIND-PACKAGE "SB!DEBUG")
1643 ;; instead, since then at least it would transform
1644 ;; correctly under package renaming and stuff.
1645 ;; However, genesis can't handle dumped packages..
1648 ;; FIXME: Maybe this could be fixed by moving the
1649 ;; whole debug-int.lisp file to warm init? (after
1650 ;; which dumping a #.(FIND-PACKAGE ..) expression
1651 ;; would work fine) If this is possible, it would
1652 ;; probably be a good thing, since minimizing the
1653 ;; amount of stuff in cold init is basically good.
1654 (or (find-package "SB-DEBUG")
1655 (find-package "SB!DEBUG"))))))))
1657 ;;; Parse the packed representation of DEBUG-VARs from
1658 ;;; DEBUG-FUN's SB!C::COMPILED-DEBUG-FUN, returning a vector
1659 ;;; of DEBUG-VARs, or NIL if there was no information to parse.
1660 (defun parse-compiled-debug-vars (debug-fun)
1661 (let* ((cdebug-fun (compiled-debug-fun-compiler-debug-fun
1663 (packed-vars (sb!c::compiled-debug-fun-vars cdebug-fun))
1664 (args-minimal (eq (sb!c::compiled-debug-fun-arguments cdebug-fun)
1668 (buffer (make-array 0 :fill-pointer 0 :adjustable t)))
1669 ((>= i (length packed-vars))
1670 (let ((result (coerce buffer 'simple-vector)))
1672 (assign-minimal-var-names result))
1674 (flet ((geti () (prog1 (aref packed-vars i) (incf i))))
1675 (let* ((flags (geti))
1676 (minimal (logtest sb!c::compiled-debug-var-minimal-p flags))
1677 (deleted (logtest sb!c::compiled-debug-var-deleted-p flags))
1678 (live (logtest sb!c::compiled-debug-var-environment-live
1680 (save (logtest sb!c::compiled-debug-var-save-loc-p flags))
1681 (symbol (if minimal nil (geti)))
1682 (id (if (logtest sb!c::compiled-debug-var-id-p flags)
1685 (sc-offset (if deleted 0 (geti)))
1686 (save-sc-offset (if save (geti) nil)))
1687 (aver (not (and args-minimal (not minimal))))
1688 (vector-push-extend (make-compiled-debug-var symbol
1697 ;;; If we're sure of whether code-location is known, return T or NIL.
1698 ;;; If we're :UNSURE, then try to fill in the code-location's slots.
1699 ;;; This determines whether there is any debug-block information, and
1700 ;;; if code-location is known.
1702 ;;; ??? IF this conses closures every time it's called, then break off the
1703 ;;; :UNSURE part to get the HANDLER-CASE into another function.
1704 (defun code-location-unknown-p (basic-code-location)
1705 (ecase (code-location-%unknown-p basic-code-location)
1709 (setf (code-location-%unknown-p basic-code-location)
1710 (handler-case (not (fill-in-code-location basic-code-location))
1711 (no-debug-blocks () t))))))
1713 ;;; Return the DEBUG-BLOCK containing code-location if it is available.
1714 ;;; Some debug policies inhibit debug-block information, and if none
1715 ;;; is available, then this signals a NO-DEBUG-BLOCKS condition.
1716 (defun code-location-debug-block (basic-code-location)
1717 (let ((block (code-location-%debug-block basic-code-location)))
1718 (if (eq block :unparsed)
1719 (etypecase basic-code-location
1720 (compiled-code-location
1721 (compute-compiled-code-location-debug-block basic-code-location))
1722 ;; (There used to be more cases back before sbcl-0.7.0, when
1723 ;; we did special tricks to debug the IR1 interpreter.)
1727 ;;; Store and return BASIC-CODE-LOCATION's debug-block. We determines
1728 ;;; the correct one using the code-location's pc. We use
1729 ;;; DEBUG-FUN-DEBUG-BLOCKS to return the cached block information
1730 ;;; or signal a NO-DEBUG-BLOCKS condition. The blocks are sorted by
1731 ;;; their first code-location's pc, in ascending order. Therefore, as
1732 ;;; soon as we find a block that starts with a pc greater than
1733 ;;; basic-code-location's pc, we know the previous block contains the
1734 ;;; pc. If we get to the last block, then the code-location is either
1735 ;;; in the second to last block or the last block, and we have to be
1736 ;;; careful in determining this since the last block could be code at
1737 ;;; the end of the function. We have to check for the last block being
1738 ;;; code first in order to see how to compare the code-location's pc.
1739 (defun compute-compiled-code-location-debug-block (basic-code-location)
1740 (let* ((pc (compiled-code-location-pc basic-code-location))
1741 (debug-fun (code-location-debug-fun
1742 basic-code-location))
1743 (blocks (debug-fun-debug-blocks debug-fun))
1744 (len (length blocks)))
1745 (declare (simple-vector blocks))
1746 (setf (code-location-%debug-block basic-code-location)
1752 (let ((last (svref blocks end)))
1754 ((debug-block-elsewhere-p last)
1756 (sb!c::compiled-debug-fun-elsewhere-pc
1757 (compiled-debug-fun-compiler-debug-fun
1759 (svref blocks (1- end))
1762 (compiled-code-location-pc
1763 (svref (compiled-debug-block-code-locations last)
1765 (svref blocks (1- end)))
1767 (declare (type index i end))
1769 (compiled-code-location-pc
1770 (svref (compiled-debug-block-code-locations
1773 (return (svref blocks (1- i)))))))))
1775 ;;; Return the CODE-LOCATION's DEBUG-SOURCE.
1776 (defun code-location-debug-source (code-location)
1777 (let ((info (compiled-debug-fun-debug-info
1778 (code-location-debug-fun code-location))))
1779 (or (sb!c::debug-info-source info)
1780 (debug-signal 'no-debug-blocks :debug-fun
1781 (code-location-debug-fun code-location)))))
1783 ;;; Returns the number of top level forms before the one containing
1784 ;;; CODE-LOCATION as seen by the compiler in some compilation unit. (A
1785 ;;; compilation unit is not necessarily a single file, see the section
1786 ;;; on debug-sources.)
1787 (defun code-location-toplevel-form-offset (code-location)
1788 (when (code-location-unknown-p code-location)
1789 (error 'unknown-code-location :code-location code-location))
1790 (let ((tlf-offset (code-location-%tlf-offset code-location)))
1791 (cond ((eq tlf-offset :unparsed)
1792 (etypecase code-location
1793 (compiled-code-location
1794 (unless (fill-in-code-location code-location)
1795 ;; This check should be unnecessary. We're missing
1796 ;; debug info the compiler should have dumped.
1797 (bug "unknown code location"))
1798 (code-location-%tlf-offset code-location))
1799 ;; (There used to be more cases back before sbcl-0.7.0,,
1800 ;; when we did special tricks to debug the IR1
1805 ;;; Return the number of the form corresponding to CODE-LOCATION. The
1806 ;;; form number is derived by a walking the subforms of a top level
1807 ;;; form in depth-first order.
1808 (defun code-location-form-number (code-location)
1809 (when (code-location-unknown-p code-location)
1810 (error 'unknown-code-location :code-location code-location))
1811 (let ((form-num (code-location-%form-number code-location)))
1812 (cond ((eq form-num :unparsed)
1813 (etypecase code-location
1814 (compiled-code-location
1815 (unless (fill-in-code-location code-location)
1816 ;; This check should be unnecessary. We're missing
1817 ;; debug info the compiler should have dumped.
1818 (bug "unknown code location"))
1819 (code-location-%form-number code-location))
1820 ;; (There used to be more cases back before sbcl-0.7.0,,
1821 ;; when we did special tricks to debug the IR1
1826 ;;; Return the kind of CODE-LOCATION, one of:
1827 ;;; :INTERPRETED, :UNKNOWN-RETURN, :KNOWN-RETURN, :INTERNAL-ERROR,
1828 ;;; :NON-LOCAL-EXIT, :BLOCK-START, :CALL-SITE, :SINGLE-VALUE-RETURN,
1829 ;;; :NON-LOCAL-ENTRY
1830 (defun code-location-kind (code-location)
1831 (when (code-location-unknown-p code-location)
1832 (error 'unknown-code-location :code-location code-location))
1833 (etypecase code-location
1834 (compiled-code-location
1835 (let ((kind (compiled-code-location-kind code-location)))
1836 (cond ((not (eq kind :unparsed)) kind)
1837 ((not (fill-in-code-location code-location))
1838 ;; This check should be unnecessary. We're missing
1839 ;; debug info the compiler should have dumped.
1840 (bug "unknown code location"))
1842 (compiled-code-location-kind code-location)))))
1843 ;; (There used to be more cases back before sbcl-0.7.0,,
1844 ;; when we did special tricks to debug the IR1
1848 ;;; This returns CODE-LOCATION's live-set if it is available. If
1849 ;;; there is no debug-block information, this returns NIL.
1850 (defun compiled-code-location-live-set (code-location)
1851 (if (code-location-unknown-p code-location)
1853 (let ((live-set (compiled-code-location-%live-set code-location)))
1854 (cond ((eq live-set :unparsed)
1855 (unless (fill-in-code-location code-location)
1856 ;; This check should be unnecessary. We're missing
1857 ;; debug info the compiler should have dumped.
1859 ;; FIXME: This error and comment happen over and over again.
1860 ;; Make them a shared function.
1861 (bug "unknown code location"))
1862 (compiled-code-location-%live-set code-location))
1865 ;;; true if OBJ1 and OBJ2 are the same place in the code
1866 (defun code-location= (obj1 obj2)
1868 (compiled-code-location
1870 (compiled-code-location
1871 (and (eq (code-location-debug-fun obj1)
1872 (code-location-debug-fun obj2))
1873 (sub-compiled-code-location= obj1 obj2)))
1874 ;; (There used to be more cases back before sbcl-0.7.0,,
1875 ;; when we did special tricks to debug the IR1
1878 ;; (There used to be more cases back before sbcl-0.7.0,,
1879 ;; when we did special tricks to debug IR1-interpreted code.)
1881 (defun sub-compiled-code-location= (obj1 obj2)
1882 (= (compiled-code-location-pc obj1)
1883 (compiled-code-location-pc obj2)))
1885 ;;; Fill in CODE-LOCATION's :UNPARSED slots, returning T or NIL
1886 ;;; depending on whether the code-location was known in its
1887 ;;; DEBUG-FUN's debug-block information. This may signal a
1888 ;;; NO-DEBUG-BLOCKS condition due to DEBUG-FUN-DEBUG-BLOCKS, and
1889 ;;; it assumes the %UNKNOWN-P slot is already set or going to be set.
1890 (defun fill-in-code-location (code-location)
1891 (declare (type compiled-code-location code-location))
1892 (let* ((debug-fun (code-location-debug-fun code-location))
1893 (blocks (debug-fun-debug-blocks debug-fun)))
1894 (declare (simple-vector blocks))
1895 (dotimes (i (length blocks) nil)
1896 (let* ((block (svref blocks i))
1897 (locations (compiled-debug-block-code-locations block)))
1898 (declare (simple-vector locations))
1899 (dotimes (j (length locations))
1900 (let ((loc (svref locations j)))
1901 (when (sub-compiled-code-location= code-location loc)
1902 (setf (code-location-%debug-block code-location) block)
1903 (setf (code-location-%tlf-offset code-location)
1904 (code-location-%tlf-offset loc))
1905 (setf (code-location-%form-number code-location)
1906 (code-location-%form-number loc))
1907 (setf (compiled-code-location-%live-set code-location)
1908 (compiled-code-location-%live-set loc))
1909 (setf (compiled-code-location-kind code-location)
1910 (compiled-code-location-kind loc))
1911 (setf (compiled-code-location-step-info code-location)
1912 (compiled-code-location-step-info loc))
1913 (return-from fill-in-code-location t))))))))
1915 ;;;; operations on DEBUG-BLOCKs
1917 ;;; Execute FORMS in a context with CODE-VAR bound to each
1918 ;;; CODE-LOCATION in DEBUG-BLOCK, and return the value of RESULT.
1919 (defmacro do-debug-block-locations ((code-var debug-block &optional result)
1921 (let ((code-locations (gensym))
1923 `(let ((,code-locations (debug-block-code-locations ,debug-block)))
1924 (declare (simple-vector ,code-locations))
1925 (dotimes (,i (length ,code-locations) ,result)
1926 (let ((,code-var (svref ,code-locations ,i)))
1929 ;;; Return the name of the function represented by DEBUG-FUN.
1930 ;;; This may be a string or a cons; do not assume it is a symbol.
1931 (defun debug-block-fun-name (debug-block)
1932 (etypecase debug-block
1933 (compiled-debug-block
1934 (let ((code-locs (compiled-debug-block-code-locations debug-block)))
1935 (declare (simple-vector code-locs))
1936 (if (zerop (length code-locs))
1937 "??? Can't get name of debug-block's function."
1939 (code-location-debug-fun (svref code-locs 0))))))
1940 ;; (There used to be more cases back before sbcl-0.7.0, when we
1941 ;; did special tricks to debug the IR1 interpreter.)
1944 (defun debug-block-code-locations (debug-block)
1945 (etypecase debug-block
1946 (compiled-debug-block
1947 (compiled-debug-block-code-locations debug-block))
1948 ;; (There used to be more cases back before sbcl-0.7.0, when we
1949 ;; did special tricks to debug the IR1 interpreter.)
1952 ;;;; operations on debug variables
1954 (defun debug-var-symbol-name (debug-var)
1955 (symbol-name (debug-var-symbol debug-var)))
1957 ;;; FIXME: Make sure that this isn't called anywhere that it wouldn't
1958 ;;; be acceptable to have NIL returned, or that it's only called on
1959 ;;; DEBUG-VARs whose symbols have non-NIL packages.
1960 (defun debug-var-package-name (debug-var)
1961 (package-name (symbol-package (debug-var-symbol debug-var))))
1963 ;;; Return the value stored for DEBUG-VAR in frame, or if the value is
1964 ;;; not :VALID, then signal an INVALID-VALUE error.
1965 (defun debug-var-valid-value (debug-var frame)
1966 (unless (eq (debug-var-validity debug-var (frame-code-location frame))
1968 (error 'invalid-value :debug-var debug-var :frame frame))
1969 (debug-var-value debug-var frame))
1971 ;;; Returns the value stored for DEBUG-VAR in frame. The value may be
1972 ;;; invalid. This is SETFable.
1973 (defun debug-var-value (debug-var frame)
1974 (aver (typep frame 'compiled-frame))
1975 (let ((res (access-compiled-debug-var-slot debug-var frame)))
1976 (if (indirect-value-cell-p res)
1977 (value-cell-ref res)
1980 ;;; This returns what is stored for the variable represented by
1981 ;;; DEBUG-VAR relative to the FRAME. This may be an indirect value
1982 ;;; cell if the variable is both closed over and set.
1983 (defun access-compiled-debug-var-slot (debug-var frame)
1984 (declare (optimize (speed 1)))
1985 (let ((escaped (compiled-frame-escaped frame)))
1987 (sub-access-debug-var-slot
1988 (frame-pointer frame)
1989 (compiled-debug-var-sc-offset debug-var)
1991 (sub-access-debug-var-slot
1992 (frame-pointer frame)
1993 (or (compiled-debug-var-save-sc-offset debug-var)
1994 (compiled-debug-var-sc-offset debug-var))))))
1996 ;;; a helper function for working with possibly-invalid values:
1997 ;;; Do (%MAKE-LISP-OBJ VAL) only if the value looks valid.
1999 ;;; (Such values can arise in registers on machines with conservative
2000 ;;; GC, and might also arise in debug variable locations when
2001 ;;; those variables are invalid.)
2002 (defun make-lisp-obj (val &optional (errorp t))
2005 (zerop (logand val sb!vm:fixnum-tag-mask))
2006 ;; immediate single float, 64-bit only
2007 #!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or))
2008 (= (logand val #xff) sb!vm:single-float-widetag)
2010 (and (zerop (logandc2 val #x1fffffff)) ; Top bits zero
2011 (= (logand val #xff) sb!vm:character-widetag)) ; char tag
2013 (= val sb!vm:unbound-marker-widetag)
2016 (not (zerop (valid-lisp-pointer-p (int-sap val))))
2017 ;; FIXME: There is no fundamental reason not to use the above
2018 ;; function on other platforms as well, but I didn't have
2019 ;; others available while doing this. --NS 2007-06-21
2021 (and (logbitp 0 val)
2022 (or (< sb!vm:read-only-space-start val
2023 (* sb!vm:*read-only-space-free-pointer*
2024 sb!vm:n-word-bytes))
2025 (< sb!vm:static-space-start val
2026 (* sb!vm:*static-space-free-pointer*
2027 sb!vm:n-word-bytes))
2028 (< (current-dynamic-space-start) val
2029 (sap-int (dynamic-space-free-pointer))))))
2030 (values (%make-lisp-obj val) t)
2032 (error "~S is not a valid argument to ~S"
2034 (values (make-unprintable-object (format nil "invalid object #x~X" val))
2038 (defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
2039 (macrolet ((with-escaped-value ((var) &body forms)
2041 (let ((,var (sb!vm:context-register
2043 (sb!c:sc-offset-offset sc-offset))))
2045 :invalid-value-for-unescaped-register-storage))
2046 (escaped-float-value (format)
2048 (sb!vm:context-float-register
2050 (sb!c:sc-offset-offset sc-offset)
2052 :invalid-value-for-unescaped-register-storage))
2053 (with-nfp ((var) &body body)
2054 `(let ((,var (if escaped
2056 (sb!vm:context-register escaped
2059 (sb!sys:sap-ref-sap fp (* nfp-save-offset
2060 sb!vm:n-word-bytes))
2062 (sb!vm::make-number-stack-pointer
2063 (sb!sys:sap-ref-32 fp (* nfp-save-offset
2064 sb!vm:n-word-bytes))))))
2066 (ecase (sb!c:sc-offset-scn sc-offset)
2067 ((#.sb!vm:any-reg-sc-number
2068 #.sb!vm:descriptor-reg-sc-number
2069 #!+rt #.sb!vm:word-pointer-reg-sc-number)
2070 (sb!sys:without-gcing
2071 (with-escaped-value (val)
2072 (make-lisp-obj val nil))))
2073 (#.sb!vm:character-reg-sc-number
2074 (with-escaped-value (val)
2076 (#.sb!vm:sap-reg-sc-number
2077 (with-escaped-value (val)
2078 (sb!sys:int-sap val)))
2079 (#.sb!vm:signed-reg-sc-number
2080 (with-escaped-value (val)
2081 (if (logbitp (1- sb!vm:n-word-bits) val)
2082 (logior val (ash -1 sb!vm:n-word-bits))
2084 (#.sb!vm:unsigned-reg-sc-number
2085 (with-escaped-value (val)
2087 (#.sb!vm:non-descriptor-reg-sc-number
2088 (error "Local non-descriptor register access?"))
2089 (#.sb!vm:interior-reg-sc-number
2090 (error "Local interior register access?"))
2091 (#.sb!vm:single-reg-sc-number
2092 (escaped-float-value single-float))
2093 (#.sb!vm:double-reg-sc-number
2094 (escaped-float-value double-float))
2096 (#.sb!vm:long-reg-sc-number
2097 (escaped-float-value long-float))
2098 (#.sb!vm:complex-single-reg-sc-number
2101 (sb!vm:context-float-register
2102 escaped (sb!c:sc-offset-offset sc-offset) 'single-float)
2103 (sb!vm:context-float-register
2104 escaped (1+ (sb!c:sc-offset-offset sc-offset)) 'single-float))
2105 :invalid-value-for-unescaped-register-storage))
2106 (#.sb!vm:complex-double-reg-sc-number
2109 (sb!vm:context-float-register
2110 escaped (sb!c:sc-offset-offset sc-offset) 'double-float)
2111 (sb!vm:context-float-register
2112 escaped (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 2 #!-sparc 1)
2114 :invalid-value-for-unescaped-register-storage))
2116 (#.sb!vm:complex-long-reg-sc-number
2119 (sb!vm:context-float-register
2120 escaped (sb!c:sc-offset-offset sc-offset) 'long-float)
2121 (sb!vm:context-float-register
2122 escaped (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4)
2124 :invalid-value-for-unescaped-register-storage))
2125 (#.sb!vm:single-stack-sc-number
2127 (sb!sys:sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset)
2128 sb!vm:n-word-bytes))))
2129 (#.sb!vm:double-stack-sc-number
2131 (sb!sys:sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset)
2132 sb!vm:n-word-bytes))))
2134 (#.sb!vm:long-stack-sc-number
2136 (sb!sys:sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset)
2137 sb!vm:n-word-bytes))))
2138 (#.sb!vm:complex-single-stack-sc-number
2141 (sb!sys:sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset)
2142 sb!vm:n-word-bytes))
2143 (sb!sys:sap-ref-single nfp (* (1+ (sb!c:sc-offset-offset sc-offset))
2144 sb!vm:n-word-bytes)))))
2145 (#.sb!vm:complex-double-stack-sc-number
2148 (sb!sys:sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset)
2149 sb!vm:n-word-bytes))
2150 (sb!sys:sap-ref-double nfp (* (+ (sb!c:sc-offset-offset sc-offset) 2)
2151 sb!vm:n-word-bytes)))))
2153 (#.sb!vm:complex-long-stack-sc-number
2156 (sb!sys:sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset)
2157 sb!vm:n-word-bytes))
2158 (sb!sys:sap-ref-long nfp (* (+ (sb!c:sc-offset-offset sc-offset)
2160 sb!vm:n-word-bytes)))))
2161 (#.sb!vm:control-stack-sc-number
2162 (sb!kernel:stack-ref fp (sb!c:sc-offset-offset sc-offset)))
2163 (#.sb!vm:character-stack-sc-number
2165 (code-char (sb!sys:sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
2166 sb!vm:n-word-bytes)))))
2167 (#.sb!vm:unsigned-stack-sc-number
2169 (sb!sys:sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
2170 sb!vm:n-word-bytes))))
2171 (#.sb!vm:signed-stack-sc-number
2173 (sb!sys:signed-sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
2174 sb!vm:n-word-bytes))))
2175 (#.sb!vm:sap-stack-sc-number
2177 (sb!sys:sap-ref-sap nfp (* (sb!c:sc-offset-offset sc-offset)
2178 sb!vm:n-word-bytes)))))))
2181 (defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
2182 (declare (type system-area-pointer fp))
2183 (macrolet ((with-escaped-value ((var) &body forms)
2185 (let ((,var (sb!vm:context-register
2187 (sb!c:sc-offset-offset sc-offset))))
2189 :invalid-value-for-unescaped-register-storage))
2190 (escaped-float-value (format)
2192 (sb!vm:context-float-register
2193 escaped (sb!c:sc-offset-offset sc-offset) ',format)
2194 :invalid-value-for-unescaped-register-storage))
2195 (escaped-complex-float-value (format)
2198 (sb!vm:context-float-register
2199 escaped (sb!c:sc-offset-offset sc-offset) ',format)
2200 (sb!vm:context-float-register
2201 escaped (1+ (sb!c:sc-offset-offset sc-offset)) ',format))
2202 :invalid-value-for-unescaped-register-storage)))
2203 (ecase (sb!c:sc-offset-scn sc-offset)
2204 ((#.sb!vm:any-reg-sc-number #.sb!vm:descriptor-reg-sc-number)
2206 (with-escaped-value (val)
2207 (make-lisp-obj val nil))))
2208 (#.sb!vm:character-reg-sc-number
2209 (with-escaped-value (val)
2211 (#.sb!vm:sap-reg-sc-number
2212 (with-escaped-value (val)
2214 (#.sb!vm:signed-reg-sc-number
2215 (with-escaped-value (val)
2216 (if (logbitp (1- sb!vm:n-word-bits) val)
2217 (logior val (ash -1 sb!vm:n-word-bits))
2219 (#.sb!vm:unsigned-reg-sc-number
2220 (with-escaped-value (val)
2222 (#.sb!vm:single-reg-sc-number
2223 (escaped-float-value single-float))
2224 (#.sb!vm:double-reg-sc-number
2225 (escaped-float-value double-float))
2227 (#.sb!vm:long-reg-sc-number
2228 (escaped-float-value long-float))
2229 (#.sb!vm:complex-single-reg-sc-number
2230 (escaped-complex-float-value single-float))
2231 (#.sb!vm:complex-double-reg-sc-number
2232 (escaped-complex-float-value double-float))
2234 (#.sb!vm:complex-long-reg-sc-number
2235 (escaped-complex-float-value long-float))
2236 (#.sb!vm:single-stack-sc-number
2237 (sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2238 sb!vm:n-word-bytes))))
2239 (#.sb!vm:double-stack-sc-number
2240 (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
2241 sb!vm:n-word-bytes))))
2243 (#.sb!vm:long-stack-sc-number
2244 (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
2245 sb!vm:n-word-bytes))))
2246 (#.sb!vm:complex-single-stack-sc-number
2248 (sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2249 sb!vm:n-word-bytes)))
2250 (sap-ref-single fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
2251 sb!vm:n-word-bytes)))))
2252 (#.sb!vm:complex-double-stack-sc-number
2254 (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
2255 sb!vm:n-word-bytes)))
2256 (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 4)
2257 sb!vm:n-word-bytes)))))
2259 (#.sb!vm:complex-long-stack-sc-number
2261 (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
2262 sb!vm:n-word-bytes)))
2263 (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 6)
2264 sb!vm:n-word-bytes)))))
2265 (#.sb!vm:control-stack-sc-number
2266 (stack-ref fp (sb!c:sc-offset-offset sc-offset)))
2267 (#.sb!vm:character-stack-sc-number
2269 (sap-ref-word fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2270 sb!vm:n-word-bytes)))))
2271 (#.sb!vm:unsigned-stack-sc-number
2272 (sap-ref-word fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2273 sb!vm:n-word-bytes))))
2274 (#.sb!vm:signed-stack-sc-number
2275 (signed-sap-ref-word fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2276 sb!vm:n-word-bytes))))
2277 (#.sb!vm:sap-stack-sc-number
2278 (sap-ref-sap fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2279 sb!vm:n-word-bytes)))))))
2281 ;;; This stores value as the value of DEBUG-VAR in FRAME. In the
2282 ;;; COMPILED-DEBUG-VAR case, access the current value to determine if
2283 ;;; it is an indirect value cell. This occurs when the variable is
2284 ;;; both closed over and set.
2285 (defun %set-debug-var-value (debug-var frame new-value)
2286 (aver (typep frame 'compiled-frame))
2287 (let ((old-value (access-compiled-debug-var-slot debug-var frame)))
2288 (if (indirect-value-cell-p old-value)
2289 (value-cell-set old-value new-value)
2290 (set-compiled-debug-var-slot debug-var frame new-value)))
2293 ;;; This stores VALUE for the variable represented by debug-var
2294 ;;; relative to the frame. This assumes the location directly contains
2295 ;;; the variable's value; that is, there is no indirect value cell
2296 ;;; currently there in case the variable is both closed over and set.
2297 (defun set-compiled-debug-var-slot (debug-var frame value)
2298 (let ((escaped (compiled-frame-escaped frame)))
2300 (sub-set-debug-var-slot (frame-pointer frame)
2301 (compiled-debug-var-sc-offset debug-var)
2303 (sub-set-debug-var-slot
2304 (frame-pointer frame)
2305 (or (compiled-debug-var-save-sc-offset debug-var)
2306 (compiled-debug-var-sc-offset debug-var))
2310 (defun sub-set-debug-var-slot (fp sc-offset value &optional escaped)
2311 (macrolet ((set-escaped-value (val)
2313 (setf (sb!vm:context-register
2315 (sb!c:sc-offset-offset sc-offset))
2318 (set-escaped-float-value (format val)
2320 (setf (sb!vm:context-float-register
2322 (sb!c:sc-offset-offset sc-offset)
2326 (with-nfp ((var) &body body)
2327 `(let ((,var (if escaped
2329 (sb!vm:context-register escaped
2334 sb!vm:n-word-bytes))
2336 (sb!vm::make-number-stack-pointer
2339 sb!vm:n-word-bytes))))))
2341 (ecase (sb!c:sc-offset-scn sc-offset)
2342 ((#.sb!vm:any-reg-sc-number
2343 #.sb!vm:descriptor-reg-sc-number
2344 #!+rt #.sb!vm:word-pointer-reg-sc-number)
2347 (get-lisp-obj-address value))))
2348 (#.sb!vm:character-reg-sc-number
2349 (set-escaped-value (char-code value)))
2350 (#.sb!vm:sap-reg-sc-number
2351 (set-escaped-value (sap-int value)))
2352 (#.sb!vm:signed-reg-sc-number
2353 (set-escaped-value (logand value (1- (ash 1 sb!vm:n-word-bits)))))
2354 (#.sb!vm:unsigned-reg-sc-number
2355 (set-escaped-value value))
2356 (#.sb!vm:non-descriptor-reg-sc-number
2357 (error "Local non-descriptor register access?"))
2358 (#.sb!vm:interior-reg-sc-number
2359 (error "Local interior register access?"))
2360 (#.sb!vm:single-reg-sc-number
2361 (set-escaped-float-value single-float value))
2362 (#.sb!vm:double-reg-sc-number
2363 (set-escaped-float-value double-float value))
2365 (#.sb!vm:long-reg-sc-number
2366 (set-escaped-float-value long-float value))
2367 (#.sb!vm:complex-single-reg-sc-number
2369 (setf (sb!vm:context-float-register escaped
2370 (sb!c:sc-offset-offset sc-offset)
2373 (setf (sb!vm:context-float-register
2374 escaped (1+ (sb!c:sc-offset-offset sc-offset))
2378 (#.sb!vm:complex-double-reg-sc-number
2380 (setf (sb!vm:context-float-register
2381 escaped (sb!c:sc-offset-offset sc-offset) 'double-float)
2383 (setf (sb!vm:context-float-register
2385 (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 2 #!-sparc 1)
2390 (#.sb!vm:complex-long-reg-sc-number
2392 (setf (sb!vm:context-float-register
2393 escaped (sb!c:sc-offset-offset sc-offset) 'long-float)
2395 (setf (sb!vm:context-float-register
2397 (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4)
2401 (#.sb!vm:single-stack-sc-number
2403 (setf (sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset)
2404 sb!vm:n-word-bytes))
2405 (the single-float value))))
2406 (#.sb!vm:double-stack-sc-number
2408 (setf (sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset)
2409 sb!vm:n-word-bytes))
2410 (the double-float value))))
2412 (#.sb!vm:long-stack-sc-number
2414 (setf (sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset)
2415 sb!vm:n-word-bytes))
2416 (the long-float value))))
2417 (#.sb!vm:complex-single-stack-sc-number
2419 (setf (sap-ref-single
2420 nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes))
2421 (the single-float (realpart value)))
2422 (setf (sap-ref-single
2423 nfp (* (1+ (sb!c:sc-offset-offset sc-offset))
2424 sb!vm:n-word-bytes))
2425 (the single-float (realpart value)))))
2426 (#.sb!vm:complex-double-stack-sc-number
2428 (setf (sap-ref-double
2429 nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes))
2430 (the double-float (realpart value)))
2431 (setf (sap-ref-double
2432 nfp (* (+ (sb!c:sc-offset-offset sc-offset) 2)
2433 sb!vm:n-word-bytes))
2434 (the double-float (realpart value)))))
2436 (#.sb!vm:complex-long-stack-sc-number
2439 nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes))
2440 (the long-float (realpart value)))
2442 nfp (* (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4)
2443 sb!vm:n-word-bytes))
2444 (the long-float (realpart value)))))
2445 (#.sb!vm:control-stack-sc-number
2446 (setf (stack-ref fp (sb!c:sc-offset-offset sc-offset)) value))
2447 (#.sb!vm:character-stack-sc-number
2449 (setf (sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
2450 sb!vm:n-word-bytes))
2451 (char-code (the character value)))))
2452 (#.sb!vm:unsigned-stack-sc-number
2454 (setf (sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
2455 sb!vm:n-word-bytes))
2456 (the (unsigned-byte 32) value))))
2457 (#.sb!vm:signed-stack-sc-number
2459 (setf (signed-sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
2460 sb!vm:n-word-bytes))
2461 (the (signed-byte 32) value))))
2462 (#.sb!vm:sap-stack-sc-number
2464 (setf (sap-ref-sap nfp (* (sb!c:sc-offset-offset sc-offset)
2465 sb!vm:n-word-bytes))
2466 (the system-area-pointer value)))))))
2469 (defun sub-set-debug-var-slot (fp sc-offset value &optional escaped)
2470 (macrolet ((set-escaped-value (val)
2472 (setf (sb!vm:context-register
2474 (sb!c:sc-offset-offset sc-offset))
2477 (ecase (sb!c:sc-offset-scn sc-offset)
2478 ((#.sb!vm:any-reg-sc-number #.sb!vm:descriptor-reg-sc-number)
2481 (get-lisp-obj-address value))))
2482 (#.sb!vm:character-reg-sc-number
2483 (set-escaped-value (char-code value)))
2484 (#.sb!vm:sap-reg-sc-number
2485 (set-escaped-value (sap-int value)))
2486 (#.sb!vm:signed-reg-sc-number
2487 (set-escaped-value (logand value (1- (ash 1 sb!vm:n-word-bits)))))
2488 (#.sb!vm:unsigned-reg-sc-number
2489 (set-escaped-value value))
2490 (#.sb!vm:single-reg-sc-number
2491 #+nil ;; don't have escaped floats.
2492 (set-escaped-float-value single-float value))
2493 (#.sb!vm:double-reg-sc-number
2494 #+nil ;; don't have escaped floats -- still in npx?
2495 (set-escaped-float-value double-float value))
2497 (#.sb!vm:long-reg-sc-number
2498 #+nil ;; don't have escaped floats -- still in npx?
2499 (set-escaped-float-value long-float value))
2500 (#.sb!vm:single-stack-sc-number
2501 (setf (sap-ref-single
2502 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2503 sb!vm:n-word-bytes)))
2504 (the single-float value)))
2505 (#.sb!vm:double-stack-sc-number
2506 (setf (sap-ref-double
2507 fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
2508 sb!vm:n-word-bytes)))
2509 (the double-float value)))
2511 (#.sb!vm:long-stack-sc-number
2513 fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
2514 sb!vm:n-word-bytes)))
2515 (the long-float value)))
2516 (#.sb!vm:complex-single-stack-sc-number
2517 (setf (sap-ref-single
2518 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2519 sb!vm:n-word-bytes)))
2520 (realpart (the (complex single-float) value)))
2521 (setf (sap-ref-single
2522 fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
2523 sb!vm:n-word-bytes)))
2524 (imagpart (the (complex single-float) value))))
2525 (#.sb!vm:complex-double-stack-sc-number
2526 (setf (sap-ref-double
2527 fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
2528 sb!vm:n-word-bytes)))
2529 (realpart (the (complex double-float) value)))
2530 (setf (sap-ref-double
2531 fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 4)
2532 sb!vm:n-word-bytes)))
2533 (imagpart (the (complex double-float) value))))
2535 (#.sb!vm:complex-long-stack-sc-number
2537 fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
2538 sb!vm:n-word-bytes)))
2539 (realpart (the (complex long-float) value)))
2541 fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 6)
2542 sb!vm:n-word-bytes)))
2543 (imagpart (the (complex long-float) value))))
2544 (#.sb!vm:control-stack-sc-number
2545 (setf (stack-ref fp (sb!c:sc-offset-offset sc-offset)) value))
2546 (#.sb!vm:character-stack-sc-number
2547 (setf (sap-ref-word fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2548 sb!vm:n-word-bytes)))
2549 (char-code (the character value))))
2550 (#.sb!vm:unsigned-stack-sc-number
2551 (setf (sap-ref-word fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2552 sb!vm:n-word-bytes)))
2553 (the sb!vm:word value)))
2554 (#.sb!vm:signed-stack-sc-number
2555 (setf (signed-sap-ref-word
2556 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2557 sb!vm:n-word-bytes)))
2558 (the (signed-byte #.sb!vm:n-word-bits) value)))
2559 (#.sb!vm:sap-stack-sc-number
2560 (setf (sap-ref-sap fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2561 sb!vm:n-word-bytes)))
2562 (the system-area-pointer value))))))
2564 ;;; The method for setting and accessing COMPILED-DEBUG-VAR values use
2565 ;;; this to determine if the value stored is the actual value or an
2566 ;;; indirection cell.
2567 (defun indirect-value-cell-p (x)
2568 (and (= (lowtag-of x) sb!vm:other-pointer-lowtag)
2569 (= (widetag-of x) sb!vm:value-cell-header-widetag)))
2571 ;;; Return three values reflecting the validity of DEBUG-VAR's value
2572 ;;; at BASIC-CODE-LOCATION:
2573 ;;; :VALID The value is known to be available.
2574 ;;; :INVALID The value is known to be unavailable.
2575 ;;; :UNKNOWN The value's availability is unknown.
2577 ;;; If the variable is always alive, then it is valid. If the
2578 ;;; code-location is unknown, then the variable's validity is
2579 ;;; :unknown. Once we've called CODE-LOCATION-UNKNOWN-P, we know the
2580 ;;; live-set information has been cached in the code-location.
2581 (defun debug-var-validity (debug-var basic-code-location)
2582 (etypecase debug-var
2584 (compiled-debug-var-validity debug-var basic-code-location))
2585 ;; (There used to be more cases back before sbcl-0.7.0, when
2586 ;; we did special tricks to debug the IR1 interpreter.)
2589 ;;; This is the method for DEBUG-VAR-VALIDITY for COMPILED-DEBUG-VARs.
2590 ;;; For safety, make sure basic-code-location is what we think.
2591 (defun compiled-debug-var-validity (debug-var basic-code-location)
2592 (declare (type compiled-code-location basic-code-location))
2593 (cond ((debug-var-alive-p debug-var)
2594 (let ((debug-fun (code-location-debug-fun basic-code-location)))
2595 (if (>= (compiled-code-location-pc basic-code-location)
2596 (sb!c::compiled-debug-fun-start-pc
2597 (compiled-debug-fun-compiler-debug-fun debug-fun)))
2600 ((code-location-unknown-p basic-code-location) :unknown)
2602 (let ((pos (position debug-var
2603 (debug-fun-debug-vars
2604 (code-location-debug-fun
2605 basic-code-location)))))
2607 (error 'unknown-debug-var
2608 :debug-var debug-var
2610 (code-location-debug-fun basic-code-location)))
2611 ;; There must be live-set info since basic-code-location is known.
2612 (if (zerop (sbit (compiled-code-location-live-set
2613 basic-code-location)
2620 ;;; This code produces and uses what we call source-paths. A
2621 ;;; source-path is a list whose first element is a form number as
2622 ;;; returned by CODE-LOCATION-FORM-NUMBER and whose last element is a
2623 ;;; top level form number as returned by
2624 ;;; CODE-LOCATION-TOPLEVEL-FORM-NUMBER. The elements from the last to
2625 ;;; the first, exclusively, are the numbered subforms into which to
2626 ;;; descend. For example:
2628 ;;; (let ((a (aref x 3)))
2630 ;;; The call to AREF in this example is form number 5. Assuming this
2631 ;;; DEFUN is the 11'th top level form, the source-path for the AREF
2632 ;;; call is as follows:
2634 ;;; Given the DEFUN, 3 gets you the LET, 1 gets you the bindings, 0
2635 ;;; gets the first binding, and 1 gets the AREF form.
2637 ;;; temporary buffer used to build form-number => source-path translation in
2638 ;;; FORM-NUMBER-TRANSLATIONS
2639 (defvar *form-number-temp* (make-array 10 :fill-pointer 0 :adjustable t))
2641 ;;; table used to detect CAR circularities in FORM-NUMBER-TRANSLATIONS
2642 (defvar *form-number-circularity-table* (make-hash-table :test 'eq))
2644 ;;; This returns a table mapping form numbers to source-paths. A
2645 ;;; source-path indicates a descent into the TOPLEVEL-FORM form,
2646 ;;; going directly to the subform corressponding to the form number.
2648 ;;; The vector elements are in the same format as the compiler's
2649 ;;; NODE-SOURCE-PATH; that is, the first element is the form number and
2650 ;;; the last is the TOPLEVEL-FORM number.
2651 (defun form-number-translations (form tlf-number)
2652 (clrhash *form-number-circularity-table*)
2653 (setf (fill-pointer *form-number-temp*) 0)
2654 (sub-translate-form-numbers form (list tlf-number))
2655 (coerce *form-number-temp* 'simple-vector))
2656 (defun sub-translate-form-numbers (form path)
2657 (unless (gethash form *form-number-circularity-table*)
2658 (setf (gethash form *form-number-circularity-table*) t)
2659 (vector-push-extend (cons (fill-pointer *form-number-temp*) path)
2664 (declare (fixnum pos))
2667 (when (atom subform) (return))
2668 (let ((fm (car subform)))
2670 (sub-translate-form-numbers fm (cons pos path)))
2672 (setq subform (cdr subform))
2673 (when (eq subform trail) (return)))))
2677 (setq trail (cdr trail)))))))
2679 ;;; FORM is a top level form, and path is a source-path into it. This
2680 ;;; returns the form indicated by the source-path. Context is the
2681 ;;; number of enclosing forms to return instead of directly returning
2682 ;;; the source-path form. When context is non-zero, the form returned
2683 ;;; contains a marker, #:****HERE****, immediately before the form
2684 ;;; indicated by path.
2685 (defun source-path-context (form path context)
2686 (declare (type unsigned-byte context))
2687 ;; Get to the form indicated by path or the enclosing form indicated
2688 ;; by context and path.
2689 (let ((path (reverse (butlast (cdr path)))))
2690 (dotimes (i (- (length path) context))
2691 (let ((index (first path)))
2692 (unless (and (listp form) (< index (length form)))
2693 (error "Source path no longer exists."))
2694 (setq form (elt form index))
2695 (setq path (rest path))))
2696 ;; Recursively rebuild the source form resulting from the above
2697 ;; descent, copying the beginning of each subform up to the next
2698 ;; subform we descend into according to path. At the bottom of the
2699 ;; recursion, we return the form indicated by path preceded by our
2700 ;; marker, and this gets spliced into the resulting list structure
2701 ;; on the way back up.
2702 (labels ((frob (form path level)
2703 (if (or (zerop level) (null path))
2706 `(#:***here*** ,form))
2707 (let ((n (first path)))
2708 (unless (and (listp form) (< n (length form)))
2709 (error "Source path no longer exists."))
2710 (let ((res (frob (elt form n) (rest path) (1- level))))
2711 (nconc (subseq form 0 n)
2712 (cons res (nthcdr (1+ n) form))))))))
2713 (frob form path context))))
2715 ;;;; PREPROCESS-FOR-EVAL
2717 ;;; Return a function of one argument that evaluates form in the
2718 ;;; lexical context of the BASIC-CODE-LOCATION LOC, or signal a
2719 ;;; NO-DEBUG-VARS condition when the LOC's DEBUG-FUN has no
2720 ;;; DEBUG-VAR information available.
2722 ;;; The returned function takes the frame to get values from as its
2723 ;;; argument, and it returns the values of FORM. The returned function
2724 ;;; can signal the following conditions: INVALID-VALUE,
2725 ;;; AMBIGUOUS-VAR-NAME, and FRAME-FUN-MISMATCH.
2726 (defun preprocess-for-eval (form loc)
2727 (declare (type code-location loc))
2728 (let ((n-frame (gensym))
2729 (fun (code-location-debug-fun loc)))
2730 (unless (debug-var-info-available fun)
2731 (debug-signal 'no-debug-vars :debug-fun fun))
2732 (sb!int:collect ((binds)
2734 (do-debug-fun-vars (var fun)
2735 (let ((validity (debug-var-validity var loc)))
2736 (unless (eq validity :invalid)
2737 (let* ((sym (debug-var-symbol var))
2738 (found (assoc sym (binds))))
2740 (setf (second found) :ambiguous)
2741 (binds (list sym validity var)))))))
2742 (dolist (bind (binds))
2743 (let ((name (first bind))
2745 (ecase (second bind)
2747 (specs `(,name (debug-var-value ',var ,n-frame))))
2749 (specs `(,name (debug-signal 'invalid-value
2753 (specs `(,name (debug-signal 'ambiguous-var-name
2755 :frame ,n-frame)))))))
2756 (let ((res (coerce `(lambda (,n-frame)
2757 (declare (ignorable ,n-frame))
2758 (symbol-macrolet ,(specs) ,form))
2761 ;; This prevents these functions from being used in any
2762 ;; location other than a function return location, so maybe
2763 ;; this should only check whether FRAME's DEBUG-FUN is the
2765 (unless (code-location= (frame-code-location frame) loc)
2766 (debug-signal 'frame-fun-mismatch
2767 :code-location loc :form form :frame frame))
2768 (funcall res frame))))))
2772 ;;;; user-visible interface
2774 ;;; Create and return a breakpoint. When program execution encounters
2775 ;;; the breakpoint, the system calls HOOK-FUN. HOOK-FUN takes the
2776 ;;; current frame for the function in which the program is running and
2777 ;;; the breakpoint object.
2779 ;;; WHAT and KIND determine where in a function the system invokes
2780 ;;; HOOK-FUN. WHAT is either a code-location or a DEBUG-FUN. KIND is
2781 ;;; one of :CODE-LOCATION, :FUN-START, or :FUN-END. Since the starts
2782 ;;; and ends of functions may not have code-locations representing
2783 ;;; them, designate these places by supplying WHAT as a DEBUG-FUN and
2784 ;;; KIND indicating the :FUN-START or :FUN-END. When WHAT is a
2785 ;;; DEBUG-FUN and kind is :FUN-END, then HOOK-FUN must take two
2786 ;;; additional arguments, a list of values returned by the function
2787 ;;; and a FUN-END-COOKIE.
2789 ;;; INFO is information supplied by and used by the user.
2791 ;;; FUN-END-COOKIE is a function. To implement :FUN-END
2792 ;;; breakpoints, the system uses starter breakpoints to establish the
2793 ;;; :FUN-END breakpoint for each invocation of the function. Upon
2794 ;;; each entry, the system creates a unique cookie to identify the
2795 ;;; invocation, and when the user supplies a function for this
2796 ;;; argument, the system invokes it on the frame and the cookie. The
2797 ;;; system later invokes the :FUN-END breakpoint hook on the same
2798 ;;; cookie. The user may save the cookie for comparison in the hook
2801 ;;; Signal an error if WHAT is an unknown code-location.
2802 (defun make-breakpoint (hook-fun what
2803 &key (kind :code-location) info fun-end-cookie)
2806 (when (code-location-unknown-p what)
2807 (error "cannot make a breakpoint at an unknown code location: ~S"
2809 (aver (eq kind :code-location))
2810 (let ((bpt (%make-breakpoint hook-fun what kind info)))
2812 (compiled-code-location
2813 ;; This slot is filled in due to calling CODE-LOCATION-UNKNOWN-P.
2814 (when (eq (compiled-code-location-kind what) :unknown-return)
2815 (let ((other-bpt (%make-breakpoint hook-fun what
2816 :unknown-return-partner
2818 (setf (breakpoint-unknown-return-partner bpt) other-bpt)
2819 (setf (breakpoint-unknown-return-partner other-bpt) bpt))))
2820 ;; (There used to be more cases back before sbcl-0.7.0,,
2821 ;; when we did special tricks to debug the IR1
2828 (%make-breakpoint hook-fun what kind info))
2830 (unless (eq (sb!c::compiled-debug-fun-returns
2831 (compiled-debug-fun-compiler-debug-fun what))
2833 (error ":FUN-END breakpoints are currently unsupported ~
2834 for the known return convention."))
2836 (let* ((bpt (%make-breakpoint hook-fun what kind info))
2837 (starter (compiled-debug-fun-end-starter what)))
2839 (setf starter (%make-breakpoint #'list what :fun-start nil))
2840 (setf (breakpoint-hook-fun starter)
2841 (fun-end-starter-hook starter what))
2842 (setf (compiled-debug-fun-end-starter what) starter))
2843 (setf (breakpoint-start-helper bpt) starter)
2844 (push bpt (breakpoint-%info starter))
2845 (setf (breakpoint-cookie-fun bpt) fun-end-cookie)
2848 ;;; These are unique objects created upon entry into a function by a
2849 ;;; :FUN-END breakpoint's starter hook. These are only created
2850 ;;; when users supply :FUN-END-COOKIE to MAKE-BREAKPOINT. Also,
2851 ;;; the :FUN-END breakpoint's hook is called on the same cookie
2852 ;;; when it is created.
2853 (defstruct (fun-end-cookie
2854 (:print-object (lambda (obj str)
2855 (print-unreadable-object (obj str :type t))))
2856 (:constructor make-fun-end-cookie (bogus-lra debug-fun))
2858 ;; a pointer to the bogus-lra created for :FUN-END breakpoints
2860 ;; the DEBUG-FUN associated with this cookie
2863 ;;; This maps bogus-lra-components to cookies, so that
2864 ;;; HANDLE-FUN-END-BREAKPOINT can find the appropriate cookie for the
2865 ;;; breakpoint hook.
2866 (defvar *fun-end-cookies* (make-hash-table :test 'eq))
2868 ;;; This returns a hook function for the start helper breakpoint
2869 ;;; associated with a :FUN-END breakpoint. The returned function
2870 ;;; makes a fake LRA that all returns go through, and this piece of
2871 ;;; fake code actually breaks. Upon return from the break, the code
2872 ;;; provides the returnee with any values. Since the returned function
2873 ;;; effectively activates FUN-END-BPT on each entry to DEBUG-FUN's
2874 ;;; function, we must establish breakpoint-data about FUN-END-BPT.
2875 (defun fun-end-starter-hook (starter-bpt debug-fun)
2876 (declare (type breakpoint starter-bpt)
2877 (type compiled-debug-fun debug-fun))
2878 (lambda (frame breakpoint)
2879 (declare (ignore breakpoint)
2881 (let ((lra-sc-offset
2882 (sb!c::compiled-debug-fun-return-pc
2883 (compiled-debug-fun-compiler-debug-fun debug-fun))))
2884 (multiple-value-bind (lra component offset)
2886 (get-context-value frame
2889 (setf (get-context-value frame
2893 (let ((end-bpts (breakpoint-%info starter-bpt)))
2894 (let ((data (breakpoint-data component offset)))
2895 (setf (breakpoint-data-breakpoints data) end-bpts)
2896 (dolist (bpt end-bpts)
2897 (setf (breakpoint-internal-data bpt) data)))
2898 (let ((cookie (make-fun-end-cookie lra debug-fun)))
2899 (setf (gethash component *fun-end-cookies*) cookie)
2900 (dolist (bpt end-bpts)
2901 (let ((fun (breakpoint-cookie-fun bpt)))
2902 (when fun (funcall fun frame cookie))))))))))
2904 ;;; This takes a FUN-END-COOKIE and a frame, and it returns
2905 ;;; whether the cookie is still valid. A cookie becomes invalid when
2906 ;;; the frame that established the cookie has exited. Sometimes cookie
2907 ;;; holders are unaware of cookie invalidation because their
2908 ;;; :FUN-END breakpoint hooks didn't run due to THROW'ing.
2910 ;;; This takes a frame as an efficiency hack since the user probably
2911 ;;; has a frame object in hand when using this routine, and it saves
2912 ;;; repeated parsing of the stack and consing when asking whether a
2913 ;;; series of cookies is valid.
2914 (defun fun-end-cookie-valid-p (frame cookie)
2915 (let ((lra (fun-end-cookie-bogus-lra cookie))
2916 (lra-sc-offset (sb!c::compiled-debug-fun-return-pc
2917 (compiled-debug-fun-compiler-debug-fun
2918 (fun-end-cookie-debug-fun cookie)))))
2919 (do ((frame frame (frame-down frame)))
2921 (when (and (compiled-frame-p frame)
2922 (#!-(or x86 x86-64) eq #!+(or x86 x86-64) sap=
2924 (get-context-value frame lra-save-offset lra-sc-offset)))
2927 ;;;; ACTIVATE-BREAKPOINT
2929 ;;; Cause the system to invoke the breakpoint's hook function until
2930 ;;; the next call to DEACTIVATE-BREAKPOINT or DELETE-BREAKPOINT. The
2931 ;;; system invokes breakpoint hook functions in the opposite order
2932 ;;; that you activate them.
2933 (defun activate-breakpoint (breakpoint)
2934 (when (eq (breakpoint-status breakpoint) :deleted)
2935 (error "cannot activate a deleted breakpoint: ~S" breakpoint))
2936 (unless (eq (breakpoint-status breakpoint) :active)
2937 (ecase (breakpoint-kind breakpoint)
2939 (let ((loc (breakpoint-what breakpoint)))
2941 (compiled-code-location
2942 (activate-compiled-code-location-breakpoint breakpoint)
2943 (let ((other (breakpoint-unknown-return-partner breakpoint)))
2945 (activate-compiled-code-location-breakpoint other))))
2946 ;; (There used to be more cases back before sbcl-0.7.0, when
2947 ;; we did special tricks to debug the IR1 interpreter.)
2950 (etypecase (breakpoint-what breakpoint)
2952 (activate-compiled-fun-start-breakpoint breakpoint))
2953 ;; (There used to be more cases back before sbcl-0.7.0, when
2954 ;; we did special tricks to debug the IR1 interpreter.)
2957 (etypecase (breakpoint-what breakpoint)
2959 (let ((starter (breakpoint-start-helper breakpoint)))
2960 (unless (eq (breakpoint-status starter) :active)
2961 ;; may already be active by some other :FUN-END breakpoint
2962 (activate-compiled-fun-start-breakpoint starter)))
2963 (setf (breakpoint-status breakpoint) :active))
2964 ;; (There used to be more cases back before sbcl-0.7.0, when
2965 ;; we did special tricks to debug the IR1 interpreter.)
2969 (defun activate-compiled-code-location-breakpoint (breakpoint)
2970 (declare (type breakpoint breakpoint))
2971 (let ((loc (breakpoint-what breakpoint)))
2972 (declare (type compiled-code-location loc))
2973 (sub-activate-breakpoint
2975 (breakpoint-data (compiled-debug-fun-component
2976 (code-location-debug-fun loc))
2977 (+ (compiled-code-location-pc loc)
2978 (if (or (eq (breakpoint-kind breakpoint)
2979 :unknown-return-partner)
2980 (eq (compiled-code-location-kind loc)
2981 :single-value-return))
2982 sb!vm:single-value-return-byte-offset
2985 (defun activate-compiled-fun-start-breakpoint (breakpoint)
2986 (declare (type breakpoint breakpoint))
2987 (let ((debug-fun (breakpoint-what breakpoint)))
2988 (sub-activate-breakpoint
2990 (breakpoint-data (compiled-debug-fun-component debug-fun)
2991 (sb!c::compiled-debug-fun-start-pc
2992 (compiled-debug-fun-compiler-debug-fun
2995 (defun sub-activate-breakpoint (breakpoint data)
2996 (declare (type breakpoint breakpoint)
2997 (type breakpoint-data data))
2998 (setf (breakpoint-status breakpoint) :active)
3000 (unless (breakpoint-data-breakpoints data)
3001 (setf (breakpoint-data-instruction data)
3003 (breakpoint-install (get-lisp-obj-address
3004 (breakpoint-data-component data))
3005 (breakpoint-data-offset data)))))
3006 (setf (breakpoint-data-breakpoints data)
3007 (append (breakpoint-data-breakpoints data) (list breakpoint)))
3008 (setf (breakpoint-internal-data breakpoint) data)))
3010 ;;;; DEACTIVATE-BREAKPOINT
3012 ;;; Stop the system from invoking the breakpoint's hook function.
3013 (defun deactivate-breakpoint (breakpoint)
3014 (when (eq (breakpoint-status breakpoint) :active)
3016 (let ((loc (breakpoint-what breakpoint)))
3018 ((or compiled-code-location compiled-debug-fun)
3019 (deactivate-compiled-breakpoint breakpoint)
3020 (let ((other (breakpoint-unknown-return-partner breakpoint)))
3022 (deactivate-compiled-breakpoint other))))
3023 ;; (There used to be more cases back before sbcl-0.7.0, when
3024 ;; we did special tricks to debug the IR1 interpreter.)
3028 (defun deactivate-compiled-breakpoint (breakpoint)
3029 (if (eq (breakpoint-kind breakpoint) :fun-end)
3030 (let ((starter (breakpoint-start-helper breakpoint)))
3031 (unless (find-if (lambda (bpt)
3032 (and (not (eq bpt breakpoint))
3033 (eq (breakpoint-status bpt) :active)))
3034 (breakpoint-%info starter))
3035 (deactivate-compiled-breakpoint starter)))
3036 (let* ((data (breakpoint-internal-data breakpoint))
3037 (bpts (delete breakpoint (breakpoint-data-breakpoints data))))
3038 (setf (breakpoint-internal-data breakpoint) nil)
3039 (setf (breakpoint-data-breakpoints data) bpts)
3042 (breakpoint-remove (get-lisp-obj-address
3043 (breakpoint-data-component data))
3044 (breakpoint-data-offset data)
3045 (breakpoint-data-instruction data)))
3046 (delete-breakpoint-data data))))
3047 (setf (breakpoint-status breakpoint) :inactive)
3050 ;;;; BREAKPOINT-INFO
3052 ;;; Return the user-maintained info associated with breakpoint. This
3054 (defun breakpoint-info (breakpoint)
3055 (breakpoint-%info breakpoint))
3056 (defun %set-breakpoint-info (breakpoint value)
3057 (setf (breakpoint-%info breakpoint) value)
3058 (let ((other (breakpoint-unknown-return-partner breakpoint)))
3060 (setf (breakpoint-%info other) value))))
3062 ;;;; BREAKPOINT-ACTIVE-P and DELETE-BREAKPOINT
3064 (defun breakpoint-active-p (breakpoint)
3065 (ecase (breakpoint-status breakpoint)
3067 ((:inactive :deleted) nil)))
3069 ;;; Free system storage and remove computational overhead associated
3070 ;;; with breakpoint. After calling this, breakpoint is completely
3071 ;;; impotent and can never become active again.
3072 (defun delete-breakpoint (breakpoint)
3073 (let ((status (breakpoint-status breakpoint)))
3074 (unless (eq status :deleted)
3075 (when (eq status :active)
3076 (deactivate-breakpoint breakpoint))
3077 (setf (breakpoint-status breakpoint) :deleted)
3078 (let ((other (breakpoint-unknown-return-partner breakpoint)))
3080 (setf (breakpoint-status other) :deleted)))
3081 (when (eq (breakpoint-kind breakpoint) :fun-end)
3082 (let* ((starter (breakpoint-start-helper breakpoint))
3083 (breakpoints (delete breakpoint
3084 (the list (breakpoint-info starter)))))
3085 (setf (breakpoint-info starter) breakpoints)
3087 (delete-breakpoint starter)
3088 (setf (compiled-debug-fun-end-starter
3089 (breakpoint-what breakpoint))
3093 ;;;; C call out stubs
3095 ;;; This actually installs the break instruction in the component. It
3096 ;;; returns the overwritten bits. You must call this in a context in
3097 ;;; which GC is disabled, so that Lisp doesn't move objects around
3098 ;;; that C is pointing to.
3099 (sb!alien:define-alien-routine "breakpoint_install" sb!alien:unsigned-int
3100 (code-obj sb!alien:unsigned-long)
3101 (pc-offset sb!alien:int))
3103 ;;; This removes the break instruction and replaces the original
3104 ;;; instruction. You must call this in a context in which GC is disabled
3105 ;;; so Lisp doesn't move objects around that C is pointing to.
3106 (sb!alien:define-alien-routine "breakpoint_remove" sb!alien:void
3107 (code-obj sb!alien:unsigned-long)
3108 (pc-offset sb!alien:int)
3109 (old-inst sb!alien:unsigned-int))
3111 (sb!alien:define-alien-routine "breakpoint_do_displaced_inst" sb!alien:void
3112 (scp (* os-context-t))
3113 (orig-inst sb!alien:unsigned-int))
3115 ;;;; breakpoint handlers (layer between C and exported interface)
3117 ;;; This maps components to a mapping of offsets to BREAKPOINT-DATAs.
3118 (defvar *component-breakpoint-offsets* (make-hash-table :test 'eq))
3120 ;;; This returns the BREAKPOINT-DATA object associated with component cross
3121 ;;; offset. If none exists, this makes one, installs it, and returns it.
3122 (defun breakpoint-data (component offset &optional (create t))
3123 (flet ((install-breakpoint-data ()
3125 (let ((data (make-breakpoint-data component offset)))
3126 (push (cons offset data)
3127 (gethash component *component-breakpoint-offsets*))
3129 (let ((offsets (gethash component *component-breakpoint-offsets*)))
3131 (let ((data (assoc offset offsets)))
3134 (install-breakpoint-data)))
3135 (install-breakpoint-data)))))
3137 ;;; We use this when there are no longer any active breakpoints
3138 ;;; corresponding to DATA.
3139 (defun delete-breakpoint-data (data)
3140 (let* ((component (breakpoint-data-component data))
3141 (offsets (delete (breakpoint-data-offset data)
3142 (gethash component *component-breakpoint-offsets*)
3145 (setf (gethash component *component-breakpoint-offsets*) offsets)
3146 (remhash component *component-breakpoint-offsets*)))
3149 ;;; The C handler for interrupts calls this when it has a
3150 ;;; debugging-tool break instruction. This does *not* handle all
3151 ;;; breaks; for example, it does not handle breaks for internal
3153 (defun handle-breakpoint (offset component signal-context)
3154 (let ((data (breakpoint-data component offset nil)))
3156 (error "unknown breakpoint in ~S at offset ~S"
3157 (debug-fun-name (debug-fun-from-pc component offset))
3159 (let ((breakpoints (breakpoint-data-breakpoints data)))
3160 (if (or (null breakpoints)
3161 (eq (breakpoint-kind (car breakpoints)) :fun-end))
3162 (handle-fun-end-breakpoint-aux breakpoints data signal-context)
3163 (handle-breakpoint-aux breakpoints data
3164 offset component signal-context)))))
3166 ;;; This holds breakpoint-datas while invoking the breakpoint hooks
3167 ;;; associated with that particular component and location. While they
3168 ;;; are executing, if we hit the location again, we ignore the
3169 ;;; breakpoint to avoid infinite recursion. fun-end breakpoints
3170 ;;; must work differently since the breakpoint-data is unique for each
3172 (defvar *executing-breakpoint-hooks* nil)
3174 ;;; This handles code-location and DEBUG-FUN :FUN-START
3176 (defun handle-breakpoint-aux (breakpoints data offset component signal-context)
3178 (bug "breakpoint that nobody wants"))
3179 (unless (member data *executing-breakpoint-hooks*)
3180 (let ((*executing-breakpoint-hooks* (cons data
3181 *executing-breakpoint-hooks*)))
3182 (invoke-breakpoint-hooks breakpoints signal-context)))
3183 ;; At this point breakpoints may not hold the same list as
3184 ;; BREAKPOINT-DATA-BREAKPOINTS since invoking hooks may have allowed
3185 ;; a breakpoint deactivation. In fact, if all breakpoints were
3186 ;; deactivated then data is invalid since it was deleted and so the
3187 ;; correct one must be looked up if it is to be used. If there are
3188 ;; no more breakpoints active at this location, then the normal
3189 ;; instruction has been put back, and we do not need to
3190 ;; DO-DISPLACED-INST.
3191 (setf data (breakpoint-data component offset nil))
3192 (when (and data (breakpoint-data-breakpoints data))
3193 ;; The breakpoint is still active, so we need to execute the
3194 ;; displaced instruction and leave the breakpoint instruction
3195 ;; behind. The best way to do this is different on each machine,
3196 ;; so we just leave it up to the C code.
3197 (breakpoint-do-displaced-inst signal-context
3198 (breakpoint-data-instruction data))
3199 ;; Some platforms have no usable sigreturn() call. If your
3200 ;; implementation of arch_do_displaced_inst() _does_ sigreturn(),
3201 ;; it's polite to warn here
3202 #!+(and sparc solaris)
3203 (error "BREAKPOINT-DO-DISPLACED-INST returned?")))
3205 (defun invoke-breakpoint-hooks (breakpoints signal-context)
3206 (let* ((frame (signal-context-frame signal-context)))
3207 (dolist (bpt breakpoints)
3208 (funcall (breakpoint-hook-fun bpt)
3210 ;; If this is an :UNKNOWN-RETURN-PARTNER, then pass the
3211 ;; hook function the original breakpoint, so that users
3212 ;; aren't forced to confront the fact that some
3213 ;; breakpoints really are two.
3214 (if (eq (breakpoint-kind bpt) :unknown-return-partner)
3215 (breakpoint-unknown-return-partner bpt)
3218 (defun signal-context-frame (signal-context)
3221 (declare (optimize (inhibit-warnings 3)))
3222 (sb!alien:sap-alien signal-context (* os-context-t))))
3223 (cfp (int-sap (sb!vm:context-register scp sb!vm::cfp-offset))))
3224 (compute-calling-frame cfp
3225 (sb!vm:context-pc scp)
3228 (defun handle-fun-end-breakpoint (offset component context)
3229 (let ((data (breakpoint-data component offset nil)))
3231 (error "unknown breakpoint in ~S at offset ~S"
3232 (debug-fun-name (debug-fun-from-pc component offset))
3234 (let ((breakpoints (breakpoint-data-breakpoints data)))
3236 (aver (eq (breakpoint-kind (car breakpoints)) :fun-end))
3237 (handle-fun-end-breakpoint-aux breakpoints data context)))))
3239 ;;; Either HANDLE-BREAKPOINT calls this for :FUN-END breakpoints
3240 ;;; [old C code] or HANDLE-FUN-END-BREAKPOINT calls this directly
3242 (defun handle-fun-end-breakpoint-aux (breakpoints data signal-context)
3243 (delete-breakpoint-data data)
3246 (declare (optimize (inhibit-warnings 3)))
3247 (sb!alien:sap-alien signal-context (* os-context-t))))
3248 (frame (signal-context-frame signal-context))
3249 (component (breakpoint-data-component data))
3250 (cookie (gethash component *fun-end-cookies*)))
3251 (remhash component *fun-end-cookies*)
3252 (dolist (bpt breakpoints)
3253 (funcall (breakpoint-hook-fun bpt)
3255 (get-fun-end-breakpoint-values scp)
3258 (defun get-fun-end-breakpoint-values (scp)
3259 (let ((ocfp (int-sap (sb!vm:context-register
3261 #!-(or x86 x86-64) sb!vm::ocfp-offset
3262 #!+(or x86 x86-64) sb!vm::ebx-offset)))
3263 (nargs (make-lisp-obj
3264 (sb!vm:context-register scp sb!vm::nargs-offset)))
3265 (reg-arg-offsets '#.sb!vm::*register-arg-offsets*)
3268 (dotimes (arg-num nargs)
3269 (push (if reg-arg-offsets
3271 (sb!vm:context-register scp (pop reg-arg-offsets)))
3272 (stack-ref ocfp arg-num))
3274 (nreverse results)))
3276 ;;;; MAKE-BOGUS-LRA (used for :FUN-END breakpoints)
3278 (defconstant bogus-lra-constants
3279 #!-(or x86 x86-64) 2 #!+(or x86 x86-64) 3)
3280 (defconstant known-return-p-slot
3281 (+ sb!vm:code-constants-offset #!-(or x86 x86-64) 1 #!+(or x86 x86-64) 2))
3283 ;;; Make a bogus LRA object that signals a breakpoint trap when
3284 ;;; returned to. If the breakpoint trap handler returns, REAL-LRA is
3285 ;;; returned to. Three values are returned: the bogus LRA object, the
3286 ;;; code component it is part of, and the PC offset for the trap
3288 (defun make-bogus-lra (real-lra &optional known-return-p)
3290 ;; These are really code labels, not variables: but this way we get
3292 (let* ((src-start (foreign-symbol-sap "fun_end_breakpoint_guts"))
3293 (src-end (foreign-symbol-sap "fun_end_breakpoint_end"))
3294 (trap-loc (foreign-symbol-sap "fun_end_breakpoint_trap"))
3295 (length (sap- src-end src-start))
3297 (%primitive sb!c:allocate-code-object (1+ bogus-lra-constants)
3299 (dst-start (code-instructions code-object)))
3300 (declare (type system-area-pointer
3301 src-start src-end dst-start trap-loc)
3302 (type index length))
3303 (setf (%code-debug-info code-object) :bogus-lra)
3304 (setf (code-header-ref code-object sb!vm:code-trace-table-offset-slot)
3307 (setf (code-header-ref code-object real-lra-slot) real-lra)
3309 (multiple-value-bind (offset code) (compute-lra-data-from-pc real-lra)
3310 (setf (code-header-ref code-object real-lra-slot) code)
3311 (setf (code-header-ref code-object (1+ real-lra-slot)) offset))
3312 (setf (code-header-ref code-object known-return-p-slot)
3314 (system-area-ub8-copy src-start 0 dst-start 0 length)
3315 (sb!vm:sanctify-for-execution code-object)
3317 (values dst-start code-object (sap- trap-loc src-start))
3319 (let ((new-lra (make-lisp-obj (+ (sap-int dst-start)
3320 sb!vm:other-pointer-lowtag))))
3323 (logandc2 (+ sb!vm:code-constants-offset bogus-lra-constants 1)
3325 (sb!vm:sanctify-for-execution code-object)
3326 (values new-lra code-object (sap- trap-loc src-start))))))
3330 ;;; This appears here because it cannot go with the DEBUG-FUN
3331 ;;; interface since DO-DEBUG-BLOCK-LOCATIONS isn't defined until after
3332 ;;; the DEBUG-FUN routines.
3334 ;;; Return a code-location before the body of a function and after all
3335 ;;; the arguments are in place; or if that location can't be
3336 ;;; determined due to a lack of debug information, return NIL.
3337 (defun debug-fun-start-location (debug-fun)
3338 (etypecase debug-fun
3340 (code-location-from-pc debug-fun
3341 (sb!c::compiled-debug-fun-start-pc
3342 (compiled-debug-fun-compiler-debug-fun
3345 ;; (There used to be more cases back before sbcl-0.7.0, when
3346 ;; we did special tricks to debug the IR1 interpreter.)
3350 ;;;; Single-stepping
3352 ;;; The single-stepper works by inserting conditional trap instructions
3353 ;;; into the generated code (see src/compiler/*/call.lisp), currently:
3355 ;;; 1) Before the code generated for a function call that was
3356 ;;; translated to a VOP
3357 ;;; 2) Just before the call instruction for a full call
3359 ;;; In both cases, the trap will only be executed if stepping has been
3360 ;;; enabled, in which case it'll ultimately be handled by
3361 ;;; HANDLE-SINGLE-STEP-TRAP, which will either signal a stepping condition,
3362 ;;; or replace the function that's about to be called with a wrapper
3363 ;;; which will signal the condition.
3365 (defun handle-single-step-trap (kind callee-register-offset)
3366 (let ((context (nth-interrupt-context (1- *free-interrupt-context-index*))))
3367 ;; The following calls must get tail-call eliminated for
3368 ;; *STEP-FRAME* to get set correctly on non-x86.
3369 (if (= kind single-step-before-trap)
3370 (handle-single-step-before-trap context)
3371 (handle-single-step-around-trap context callee-register-offset))))
3373 (defvar *step-frame* nil)
3375 (defun handle-single-step-before-trap (context)
3376 (let ((step-info (single-step-info-from-context context)))
3377 ;; If there was not enough debug information available, there's no
3378 ;; sense in signaling the condition.
3382 (signal-context-frame (sb!alien::alien-sap context))
3384 ;; KLUDGE: Use the first non-foreign frame as the
3385 ;; *STACK-TOP-HINT*. Getting the frame from the signal
3386 ;; context as on x86 would be cleaner, but
3387 ;; SIGNAL-CONTEXT-FRAME doesn't seem seem to work at all
3389 (loop with frame = (frame-down (top-frame))
3391 for dfun = (frame-debug-fun frame)
3392 do (when (typep dfun 'compiled-debug-fun)
3394 do (setf frame (frame-down frame)))))
3395 (sb!impl::step-form step-info
3396 ;; We could theoretically store information in
3397 ;; the debug-info about to determine the
3398 ;; arguments here, but for now let's just pass
3402 ;;; This function will replace the fdefn / function that was in the
3403 ;;; register at CALLEE-REGISTER-OFFSET with a wrapper function. To
3404 ;;; ensure that the full call will use the wrapper instead of the
3405 ;;; original, conditional trap must be emitted before the fdefn /
3406 ;;; function is converted into a raw address.
3407 (defun handle-single-step-around-trap (context callee-register-offset)
3408 ;; Fetch the function / fdefn we're about to call from the
3409 ;; appropriate register.
3410 (let* ((callee (make-lisp-obj
3411 (context-register context callee-register-offset)))
3412 (step-info (single-step-info-from-context context)))
3413 ;; If there was not enough debug information available, there's no
3414 ;; sense in signaling the condition.
3416 (return-from handle-single-step-around-trap))
3417 (let* ((fun (lambda (&rest args)
3419 (apply (typecase callee
3420 (fdefn (fdefn-fun callee))
3423 ;; Signal a step condition
3425 (let ((*step-frame* (frame-down (top-frame))))
3426 (sb!impl::step-form step-info args))))
3427 ;; And proceed based on its return value.
3429 ;; STEP-INTO was selected. Use *STEP-OUT* to
3430 ;; let the stepper know that selecting the
3431 ;; STEP-OUT restart is valid inside this
3432 (let ((sb!impl::*step-out* :maybe))
3433 ;; Pass the return values of the call to
3434 ;; STEP-VALUES, which will signal a
3435 ;; condition with them in the VALUES slot.
3437 (multiple-value-call #'sb!impl::step-values
3440 ;; If the user selected the STEP-OUT
3441 ;; restart during the call, resume
3443 (when (eq sb!impl::*step-out* t)
3444 (sb!impl::enable-stepping))))
3445 ;; STEP-NEXT / CONTINUE / OUT selected:
3446 ;; Disable the stepper for the duration of
3448 (sb!impl::with-stepping-disabled
3450 (new-callee (etypecase callee
3452 (let ((fdefn (make-fdefn (gensym))))
3453 (setf (fdefn-fun fdefn) fun)
3456 ;; And then store the wrapper in the same place.
3457 (setf (context-register context callee-register-offset)
3458 (get-lisp-obj-address new-callee)))))
3460 ;;; Given a signal context, fetch the step-info that's been stored in
3461 ;;; the debug info at the trap point.
3462 (defun single-step-info-from-context (context)
3463 (multiple-value-bind (pc-offset code)
3464 (compute-lra-data-from-pc (context-pc context))
3465 (let* ((debug-fun (debug-fun-from-pc code pc-offset))
3466 (location (code-location-from-pc debug-fun
3471 (fill-in-code-location location)
3472 (code-location-debug-source location)
3473 (compiled-code-location-step-info location))
3477 ;;; Return the frame that triggered a single-step condition. Used to
3478 ;;; provide a *STACK-TOP-HINT*.
3479 (defun find-stepped-frame ()