1 ;;;; the implementation of the programmer's interface to writing
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
15 ;;; FIXME: There are an awful lot of package prefixes in this code.
16 ;;; Couldn't we have SB-DI use the SB-C and SB-VM packages?
20 ;;;; The interface to building debugging tools signals conditions that
21 ;;;; prevent it from adhering to its contract. These are
22 ;;;; serious-conditions because the program using the interface must
23 ;;;; handle them before it can correctly continue execution. These
24 ;;;; debugging conditions are not errors since it is no fault of the
25 ;;;; programmers that the conditions occur. The interface does not
26 ;;;; provide for programs to detect these situations other than
27 ;;;; calling a routine that detects them and signals a condition. For
28 ;;;; example, programmers call A which may fail to return successfully
29 ;;;; due to a lack of debug information, and there is no B the they
30 ;;;; could have called to realize A would fail. It is not an error to
31 ;;;; have called A, but it is an error for the program to then ignore
32 ;;;; the signal generated by A since it cannot continue without A's
33 ;;;; correctly returning a value or performing some operation.
35 ;;;; Use DEBUG-SIGNAL to signal these conditions.
37 (define-condition debug-condition (serious-condition)
41 "All DEBUG-CONDITIONs inherit from this type. These are serious conditions
42 that must be handled, but they are not programmer errors."))
44 (define-condition no-debug-info (debug-condition)
45 ((code-component :reader no-debug-info-code-component
46 :initarg :code-component))
48 (:documentation "There is no usable debugging information available.")
49 (:report (lambda (condition stream)
52 "no debug information available for ~S~%"
53 (no-debug-info-code-component condition)))))
55 (define-condition no-debug-fun-returns (debug-condition)
56 ((debug-fun :reader no-debug-fun-returns-debug-fun
60 "The system could not return values from a frame with DEBUG-FUN since
61 it lacked information about returning values.")
62 (:report (lambda (condition stream)
63 (let ((fun (debug-fun-fun
64 (no-debug-fun-returns-debug-fun condition))))
66 "~&Cannot return values from ~:[frame~;~:*~S~] since ~
67 the debug information lacks details about returning ~
71 (define-condition no-debug-blocks (debug-condition)
72 ((debug-fun :reader no-debug-blocks-debug-fun
75 (:documentation "The debug-fun has no debug-block information.")
76 (:report (lambda (condition stream)
77 (format stream "~&~S has no debug-block information."
78 (no-debug-blocks-debug-fun condition)))))
80 (define-condition no-debug-vars (debug-condition)
81 ((debug-fun :reader no-debug-vars-debug-fun
84 (:documentation "The DEBUG-FUN has no DEBUG-VAR information.")
85 (:report (lambda (condition stream)
86 (format stream "~&~S has no debug variable information."
87 (no-debug-vars-debug-fun condition)))))
89 (define-condition lambda-list-unavailable (debug-condition)
90 ((debug-fun :reader lambda-list-unavailable-debug-fun
94 "The DEBUG-FUN has no lambda list since argument DEBUG-VARs are
96 (:report (lambda (condition stream)
97 (format stream "~&~S has no lambda-list information available."
98 (lambda-list-unavailable-debug-fun condition)))))
100 (define-condition invalid-value (debug-condition)
101 ((debug-var :reader invalid-value-debug-var :initarg :debug-var)
102 (frame :reader invalid-value-frame :initarg :frame))
103 (:report (lambda (condition stream)
104 (format stream "~&~S has :invalid or :unknown value in ~S."
105 (invalid-value-debug-var condition)
106 (invalid-value-frame condition)))))
108 (define-condition ambiguous-variable-name (debug-condition)
109 ((name :reader ambiguous-variable-name-name :initarg :name)
110 (frame :reader ambiguous-variable-name-frame :initarg :frame))
111 (:report (lambda (condition stream)
112 (format stream "~&~S names more than one valid variable in ~S."
113 (ambiguous-variable-name-name condition)
114 (ambiguous-variable-name-frame condition)))))
116 ;;;; errors and DEBUG-SIGNAL
118 ;;; The debug-internals code tries to signal all programmer errors as
119 ;;; subtypes of DEBUG-ERROR. There are calls to ERROR signalling
120 ;;; SIMPLE-ERRORs, but these dummy checks in the code and shouldn't
123 ;;; While under development, this code also signals errors in code
124 ;;; branches that remain unimplemented.
126 (define-condition debug-error (error) ()
129 "All programmer errors from using the interface for building debugging
130 tools inherit from this type."))
132 (define-condition unhandled-debug-condition (debug-error)
133 ((condition :reader unhandled-debug-condition-condition :initarg :condition))
134 (:report (lambda (condition stream)
135 (format stream "~&unhandled DEBUG-CONDITION:~%~A"
136 (unhandled-debug-condition-condition condition)))))
138 (define-condition unknown-code-location (debug-error)
139 ((code-location :reader unknown-code-location-code-location
140 :initarg :code-location))
141 (:report (lambda (condition stream)
142 (format stream "~&invalid use of an unknown code-location: ~S"
143 (unknown-code-location-code-location condition)))))
145 (define-condition unknown-debug-var (debug-error)
146 ((debug-var :reader unknown-debug-var-debug-var :initarg :debug-var)
147 (debug-fun :reader unknown-debug-var-debug-fun
148 :initarg :debug-fun))
149 (:report (lambda (condition stream)
150 (format stream "~&~S is not in ~S."
151 (unknown-debug-var-debug-var condition)
152 (unknown-debug-var-debug-fun condition)))))
154 (define-condition invalid-control-stack-pointer (debug-error)
156 (:report (lambda (condition stream)
157 (declare (ignore condition))
159 (write-string "invalid control stack pointer" stream))))
161 (define-condition frame-fun-mismatch (debug-error)
162 ((code-location :reader frame-fun-mismatch-code-location
163 :initarg :code-location)
164 (frame :reader frame-fun-mismatch-frame :initarg :frame)
165 (form :reader frame-fun-mismatch-form :initarg :form))
166 (:report (lambda (condition stream)
169 "~&Form was preprocessed for ~S,~% but called on ~S:~% ~S"
170 (frame-fun-mismatch-code-location condition)
171 (frame-fun-mismatch-frame condition)
172 (frame-fun-mismatch-form condition)))))
174 ;;; This signals debug-conditions. If they go unhandled, then signal
175 ;;; an UNHANDLED-DEBUG-CONDITION error.
177 ;;; ??? Get SIGNAL in the right package!
178 (defmacro debug-signal (datum &rest arguments)
179 `(let ((condition (make-condition ,datum ,@arguments)))
181 (error 'unhandled-debug-condition :condition condition)))
185 ;;;; Most of these structures model information stored in internal
186 ;;;; data structures created by the compiler. Whenever comments
187 ;;;; preface an object or type with "compiler", they refer to the
188 ;;;; internal compiler thing, not to the object or type with the same
189 ;;;; name in the "SB-DI" package.
193 ;;; These exist for caching data stored in packed binary form in
194 ;;; compiler DEBUG-FUNs.
195 (defstruct (debug-var (:constructor nil)
197 ;; the name of the variable
198 (symbol (required-argument) :type symbol)
199 ;; a unique integer identification relative to other variables with the same
201 (id 0 :type sb!c::index)
202 ;; Does the variable always have a valid value?
203 (alive-p nil :type boolean))
204 (def!method print-object ((debug-var debug-var) stream)
205 (print-unreadable-object (debug-var stream :type t :identity t)
208 (debug-var-symbol debug-var)
209 (debug-var-id debug-var))))
212 (setf (fdocumentation 'debug-var-id 'function)
213 "Return the integer that makes DEBUG-VAR's name and package unique
214 with respect to other DEBUG-VARs in the same function.")
216 (defstruct (compiled-debug-var
218 (:constructor make-compiled-debug-var
219 (symbol id alive-p sc-offset save-sc-offset))
221 ;; storage class and offset (unexported)
222 (sc-offset nil :type sb!c::sc-offset)
223 ;; storage class and offset when saved somewhere
224 (save-sc-offset nil :type (or sb!c::sc-offset null)))
228 ;;; These represent call frames on the stack.
229 (defstruct (frame (:constructor nil)
231 ;; the next frame up, or NIL when top frame
232 (up nil :type (or frame null))
233 ;; the previous frame down, or NIL when the bottom frame. Before
234 ;; computing the next frame down, this slot holds the frame pointer
235 ;; to the control stack for the given frame. This lets us get the
236 ;; next frame down and the return-pc for that frame.
237 (%down :unparsed :type (or frame (member nil :unparsed)))
238 ;; the DEBUG-FUN for the function whose call this frame represents
239 (debug-fun nil :type debug-fun)
240 ;; the CODE-LOCATION where the frame's DEBUG-FUN will continue
241 ;; running when program execution returns to this frame. If someone
242 ;; interrupted this frame, the result could be an unknown
244 (code-location nil :type code-location)
245 ;; an a-list of catch-tags to code-locations
246 (%catches :unparsed :type (or list (member :unparsed)))
247 ;; pointer to frame on control stack (unexported)
249 ;; This is the frame's number for prompt printing. Top is zero.
250 (number 0 :type index))
252 (defstruct (compiled-frame
254 (:constructor make-compiled-frame
255 (pointer up debug-fun code-location number
258 ;; This indicates whether someone interrupted the frame.
259 ;; (unexported). If escaped, this is a pointer to the state that was
260 ;; saved when we were interrupted, an os_context_t, i.e. the third
261 ;; argument to an SA_SIGACTION-style signal handler.
263 (def!method print-object ((obj compiled-frame) str)
264 (print-unreadable-object (obj str :type t)
266 "~S~:[~;, interrupted~]"
267 (debug-fun-name (frame-debug-fun obj))
268 (compiled-frame-escaped obj))))
272 ;;; These exist for caching data stored in packed binary form in
273 ;;; compiler DEBUG-FUNs. *COMPILED-DEBUG-FUNS* maps a SB!C::DEBUG-FUN
274 ;;; to a DEBUG-FUN. There should only be one DEBUG-FUN in existence
275 ;;; for any function; that is, all CODE-LOCATIONs and other objects
276 ;;; that reference DEBUG-FUNs point to unique objects. This is
277 ;;; due to the overhead in cached information.
278 (defstruct (debug-fun (:constructor nil)
280 ;; some representation of the function arguments. See
281 ;; DEBUG-FUN-LAMBDA-LIST.
282 ;; NOTE: must parse vars before parsing arg list stuff.
283 (%lambda-list :unparsed)
284 ;; cached DEBUG-VARS information (unexported).
285 ;; These are sorted by their name.
286 (%debug-vars :unparsed :type (or simple-vector null (member :unparsed)))
287 ;; cached debug-block information. This is NIL when we have tried to
288 ;; parse the packed binary info, but none is available.
289 (blocks :unparsed :type (or simple-vector null (member :unparsed)))
290 ;; the actual function if available
291 (%function :unparsed :type (or null function (member :unparsed))))
292 (def!method print-object ((obj debug-fun) stream)
293 (print-unreadable-object (obj stream :type t)
294 (prin1 (debug-fun-name obj) stream)))
296 (defstruct (compiled-debug-fun
298 (:constructor %make-compiled-debug-fun
299 (compiler-debug-fun component))
301 ;; compiler's dumped DEBUG-FUN information (unexported)
302 (compiler-debug-fun nil :type sb!c::compiled-debug-fun)
303 ;; code object (unexported).
305 ;; the :FUN-START breakpoint (if any) used to facilitate
306 ;; function end breakpoints
307 (end-starter nil :type (or null breakpoint)))
309 ;;; This maps SB!C::COMPILED-DEBUG-FUNs to
310 ;;; COMPILED-DEBUG-FUNs, so we can get at cached stuff and not
311 ;;; duplicate COMPILED-DEBUG-FUN structures.
312 (defvar *compiled-debug-funs* (make-hash-table :test 'eq))
314 ;;; Make a COMPILED-DEBUG-FUN for a SB!C::COMPILER-DEBUG-FUN
315 ;;; and its component. This maps the latter to the former in
316 ;;; *COMPILED-DEBUG-FUNS*. If there already is a
317 ;;; COMPILED-DEBUG-FUN, then this returns it from
318 ;;; *COMPILED-DEBUG-FUNS*.
319 (defun make-compiled-debug-fun (compiler-debug-fun component)
320 (or (gethash compiler-debug-fun *compiled-debug-funs*)
321 (setf (gethash compiler-debug-fun *compiled-debug-funs*)
322 (%make-compiled-debug-fun compiler-debug-fun component))))
324 (defstruct (bogus-debug-fun
326 (:constructor make-bogus-debug-fun
327 (%name &aux (%lambda-list nil) (%debug-vars nil)
328 (blocks nil) (%function nil)))
332 (defvar *ir1-lambda-debug-fun* (make-hash-table :test 'eq))
336 ;;; These exist for caching data stored in packed binary form in compiler
338 (defstruct (debug-block (:constructor nil)
340 ;; Code-locations where execution continues after this block.
341 (successors nil :type list)
342 ;; This indicates whether the block is a special glob of code shared
343 ;; by various functions and tucked away elsewhere in a component.
344 ;; This kind of block has no start code-location. This slot is in
345 ;; all debug-blocks since it is an exported interface.
346 (elsewhere-p nil :type boolean))
347 (def!method print-object ((obj debug-block) str)
348 (print-unreadable-object (obj str :type t)
349 (prin1 (debug-block-function-name obj) str)))
352 (setf (fdocumentation 'debug-block-successors 'function)
353 "Return the list of possible code-locations where execution may continue
354 when the basic-block represented by debug-block completes its execution.")
357 (setf (fdocumentation 'debug-block-elsewhere-p 'function)
358 "Return whether debug-block represents elsewhere code.")
360 (defstruct (compiled-debug-block (:include debug-block)
362 make-compiled-debug-block
363 (code-locations successors elsewhere-p))
365 ;; code-location information for the block
366 (code-locations nil :type simple-vector))
368 (defvar *ir1-block-debug-block* (make-hash-table :test 'eq))
372 ;;; This is an internal structure that manages information about a
373 ;;; breakpoint locations. See *COMPONENT-BREAKPOINT-OFFSETS*.
374 (defstruct (breakpoint-data (:constructor make-breakpoint-data
377 ;; This is the component in which the breakpoint lies.
379 ;; This is the byte offset into the component.
380 (offset nil :type sb!c::index)
381 ;; The original instruction replaced by the breakpoint.
382 (instruction nil :type (or null (unsigned-byte 32)))
383 ;; A list of user breakpoints at this location.
384 (breakpoints nil :type list))
385 (def!method print-object ((obj breakpoint-data) str)
386 (print-unreadable-object (obj str :type t)
387 (format str "~S at ~S"
389 (debug-fun-from-pc (breakpoint-data-component obj)
390 (breakpoint-data-offset obj)))
391 (breakpoint-data-offset obj))))
393 (defstruct (breakpoint (:constructor %make-breakpoint
394 (hook-function what kind %info))
396 ;; This is the function invoked when execution encounters the
397 ;; breakpoint. It takes a frame, the breakpoint, and optionally a
398 ;; list of values. Values are supplied for :FUN-END breakpoints
399 ;; as values to return for the function containing the breakpoint.
400 ;; :FUN-END breakpoint hook-functions also take a cookie
401 ;; argument. See COOKIE-FUN slot.
402 (hook-function nil :type function)
403 ;; CODE-LOCATION or DEBUG-FUN
404 (what nil :type (or code-location debug-fun))
405 ;; :CODE-LOCATION, :FUN-START, or :FUN-END for that kind
406 ;; of breakpoint. :UNKNOWN-RETURN-PARTNER if this is the partner of
407 ;; a :code-location breakpoint at an :UNKNOWN-RETURN code-location.
408 (kind nil :type (member :code-location :fun-start :fun-end
409 :unknown-return-partner))
410 ;; Status helps the user and the implementation.
411 (status :inactive :type (member :active :inactive :deleted))
412 ;; This is a backpointer to a breakpoint-data.
413 (internal-data nil :type (or null breakpoint-data))
414 ;; With code-locations whose type is :UNKNOWN-RETURN, there are
415 ;; really two breakpoints: one at the multiple-value entry point,
416 ;; and one at the single-value entry point. This slot holds the
417 ;; breakpoint for the other one, or NIL if this isn't at an
418 ;; :UNKNOWN-RETURN code location.
419 (unknown-return-partner nil :type (or null breakpoint))
420 ;; :FUN-END breakpoints use a breakpoint at the :FUN-START
421 ;; to establish the end breakpoint upon function entry. We do this
422 ;; by frobbing the LRA to jump to a special piece of code that
423 ;; breaks and provides the return values for the returnee. This slot
424 ;; points to the start breakpoint, so we can activate, deactivate,
426 (start-helper nil :type (or null breakpoint))
427 ;; This is a hook users supply to get a dynamically unique cookie
428 ;; for identifying :FUN-END breakpoint executions. That is, if
429 ;; there is one :FUN-END breakpoint, but there may be multiple
430 ;; pending calls of its function on the stack. This function takes
431 ;; the cookie, and the hook-function takes the cookie too.
432 (cookie-fun nil :type (or null function))
433 ;; This slot users can set with whatever information they find useful.
435 (def!method print-object ((obj breakpoint) str)
436 (let ((what (breakpoint-what obj)))
437 (print-unreadable-object (obj str :type t)
442 (debug-fun (debug-fun-name what)))
445 (debug-fun (breakpoint-kind obj)))))))
449 (defstruct (code-location (:constructor nil)
451 ;; the DEBUG-FUN containing this CODE-LOCATION
452 (debug-fun nil :type debug-fun)
453 ;; This is initially :UNSURE. Upon first trying to access an
454 ;; :unparsed slot, if the data is unavailable, then this becomes t,
455 ;; and the code-location is unknown. If the data is available, this
456 ;; becomes nil, a known location. We can't use a separate type
457 ;; code-location for this since we must return code-locations before
458 ;; we can tell whether they're known or unknown. For example, when
459 ;; parsing the stack, we don't want to unpack all the variables and
460 ;; blocks just to make frames.
461 (%unknown-p :unsure :type (member t nil :unsure))
462 ;; the DEBUG-BLOCK containing CODE-LOCATION. XXX Possibly toss this
463 ;; out and just find it in the blocks cache in DEBUG-FUN.
464 (%debug-block :unparsed :type (or debug-block (member :unparsed)))
465 ;; This is the number of forms processed by the compiler or loader
466 ;; before the top-level form containing this code-location.
467 (%tlf-offset :unparsed :type (or sb!c::index (member :unparsed)))
468 ;; This is the depth-first number of the node that begins
469 ;; code-location within its top-level form.
470 (%form-number :unparsed :type (or sb!c::index (member :unparsed))))
471 (def!method print-object ((obj code-location) str)
472 (print-unreadable-object (obj str :type t)
473 (prin1 (debug-fun-name (code-location-debug-fun obj))
476 (defstruct (compiled-code-location
477 (:include code-location)
478 (:constructor make-known-code-location
479 (pc debug-fun %tlf-offset %form-number
480 %live-set kind &aux (%unknown-p nil)))
481 (:constructor make-compiled-code-location (pc debug-fun))
483 ;; an index into DEBUG-FUN's component slot
484 (pc nil :type sb!c::index)
485 ;; a bit-vector indexed by a variable's position in
486 ;; DEBUG-FUN-DEBUG-VARS indicating whether the variable has a
487 ;; valid value at this code-location. (unexported).
488 (%live-set :unparsed :type (or simple-bit-vector (member :unparsed)))
489 ;; (unexported) To see SB!C::LOCATION-KIND, do
490 ;; (SB!KERNEL:TYPE-EXPAND 'SB!C::LOCATION-KIND).
491 (kind :unparsed :type (or (member :unparsed) sb!c::location-kind)))
495 ;;; Return the number of top-level forms processed by the compiler
496 ;;; before compiling this source. If this source is uncompiled, this
497 ;;; is zero. This may be zero even if the source is compiled since the
498 ;;; first form in the first file compiled in one compilation, for
499 ;;; example, must have a root number of zero -- the compiler saw no
500 ;;; other top-level forms before it.
501 (defun debug-source-root-number (debug-source)
502 (sb!c::debug-source-source-root debug-source))
506 ;;; This is used in FIND-ESCAPED-FRAME and with the bogus components
507 ;;; and LRAs used for :FUN-END breakpoints. When a components
508 ;;; debug-info slot is :BOGUS-LRA, then the REAL-LRA-SLOT contains the
509 ;;; real component to continue executing, as opposed to the bogus
510 ;;; component which appeared in some frame's LRA location.
511 (defconstant real-lra-slot sb!vm:code-constants-offset)
513 ;;; These are magically converted by the compiler.
514 (defun current-sp () (current-sp))
515 (defun current-fp () (current-fp))
516 (defun stack-ref (s n) (stack-ref s n))
517 (defun %set-stack-ref (s n value) (%set-stack-ref s n value))
518 (defun function-code-header (fun) (function-code-header fun))
519 (defun lra-code-header (lra) (lra-code-header lra))
520 (defun make-lisp-obj (value) (make-lisp-obj value))
521 (defun get-lisp-obj-address (thing) (get-lisp-obj-address thing))
522 (defun function-word-offset (fun) (function-word-offset fun))
524 #!-sb-fluid (declaim (inline cstack-pointer-valid-p))
525 (defun cstack-pointer-valid-p (x)
526 (declare (type system-area-pointer x))
527 #!-x86 ; stack grows toward high address values
528 (and (sap< x (current-sp))
529 (sap<= (int-sap control-stack-start)
531 (zerop (logand (sap-int x) #b11)))
532 #!+x86 ; stack grows toward low address values
533 (and (sap>= x (current-sp))
534 (sap> (int-sap control-stack-end) x)
535 (zerop (logand (sap-int x) #b11))))
538 (sb!alien:def-alien-routine component-ptr-from-pc (system-area-pointer)
539 (pc system-area-pointer))
542 (defun component-from-component-ptr (component-ptr)
543 (declare (type system-area-pointer component-ptr))
544 (make-lisp-obj (logior (sap-int component-ptr)
545 sb!vm:other-pointer-type)))
552 (defun compute-lra-data-from-pc (pc)
553 (declare (type system-area-pointer pc))
554 (let ((component-ptr (component-ptr-from-pc pc)))
555 (unless (sap= component-ptr (int-sap #x0))
556 (let* ((code (component-from-component-ptr component-ptr))
557 (code-header-len (* (get-header-data code) sb!vm:word-bytes))
558 (pc-offset (- (sap-int pc)
559 (- (get-lisp-obj-address code)
560 sb!vm:other-pointer-type)
562 ; (format t "c-lra-fpc ~A ~A ~A~%" pc code pc-offset)
563 (values pc-offset code)))))
565 (defconstant sb!vm::nargs-offset #.sb!vm::ecx-offset)
567 ;;; Check for a valid return address - it could be any valid C/Lisp
570 ;;; XXX Could be a little smarter.
571 #!-sb-fluid (declaim (inline ra-pointer-valid-p))
572 (defun ra-pointer-valid-p (ra)
573 (declare (type system-area-pointer ra))
575 ;; Not the first page which is unmapped.
576 (>= (sap-int ra) 4096)
577 ;; Not a Lisp stack pointer.
578 (not (cstack-pointer-valid-p ra))))
580 ;;; Try to find a valid previous stack. This is complex on the x86 as
581 ;;; it can jump between C and Lisp frames. To help find a valid frame
582 ;;; it searches backwards.
584 ;;; XXX Should probably check whether it has reached the bottom of the
587 ;;; XXX Should handle interrupted frames, both Lisp and C. At present
588 ;;; it manages to find a fp trail, see linux hack below.
589 (defun x86-call-context (fp &key (depth 0))
590 (declare (type system-area-pointer fp)
592 ;;(format t "*CC ~S ~S~%" fp depth)
594 ((not (cstack-pointer-valid-p fp))
595 #+nil (format t "debug invalid fp ~S~%" fp)
598 ;; Check the two possible frame pointers.
599 (let ((lisp-ocfp (sap-ref-sap fp (- (* (1+ sb!vm::ocfp-save-offset) 4))))
600 (lisp-ra (sap-ref-sap fp (- (* (1+ sb!vm::return-pc-save-offset)
602 (c-ocfp (sap-ref-sap fp (* 0 sb!vm:word-bytes)))
603 (c-ra (sap-ref-sap fp (* 1 sb!vm:word-bytes))))
604 (cond ((and (sap> lisp-ocfp fp) (cstack-pointer-valid-p lisp-ocfp)
605 (ra-pointer-valid-p lisp-ra)
606 (sap> c-ocfp fp) (cstack-pointer-valid-p c-ocfp)
607 (ra-pointer-valid-p c-ra))
609 "*C Both valid ~S ~S ~S ~S~%"
610 lisp-ocfp lisp-ra c-ocfp c-ra)
611 ;; Look forward another step to check their validity.
612 (let ((lisp-path-fp (x86-call-context lisp-ocfp
614 (c-path-fp (x86-call-context c-ocfp :depth (1+ depth))))
615 (cond ((and lisp-path-fp c-path-fp)
616 ;; Both still seem valid - choose the lisp frame.
617 #+nil (when (zerop depth)
619 "debug: both still valid ~S ~S ~S ~S~%"
620 lisp-ocfp lisp-ra c-ocfp c-ra))
622 (if (sap> lisp-ocfp c-ocfp)
623 (values lisp-ra lisp-ocfp)
624 (values c-ra c-ocfp))
626 (values lisp-ra lisp-ocfp))
628 ;; The lisp convention is looking good.
629 #+nil (format t "*C lisp-ocfp ~S ~S~%" lisp-ocfp lisp-ra)
630 (values lisp-ra lisp-ocfp))
632 ;; The C convention is looking good.
633 #+nil (format t "*C c-ocfp ~S ~S~%" c-ocfp c-ra)
634 (values c-ra c-ocfp))
636 ;; Neither seems right?
637 #+nil (format t "debug: no valid2 fp found ~S ~S~%"
640 ((and (sap> lisp-ocfp fp) (cstack-pointer-valid-p lisp-ocfp)
641 (ra-pointer-valid-p lisp-ra))
642 ;; The lisp convention is looking good.
643 #+nil (format t "*C lisp-ocfp ~S ~S~%" lisp-ocfp lisp-ra)
644 (values lisp-ra lisp-ocfp))
645 ((and (sap> c-ocfp fp) (cstack-pointer-valid-p c-ocfp)
646 #!-linux (ra-pointer-valid-p c-ra))
647 ;; The C convention is looking good.
648 #+nil (format t "*C c-ocfp ~S ~S~%" c-ocfp c-ra)
649 (values c-ra c-ocfp))
651 #+nil (format t "debug: no valid fp found ~S ~S~%"
657 ;;; Convert the descriptor into a SAP. The bits all stay the same, we just
658 ;;; change our notion of what we think they are.
659 #!-sb-fluid (declaim (inline descriptor-sap))
660 (defun descriptor-sap (x)
661 (int-sap (get-lisp-obj-address x)))
663 ;;; Return the top frame of the control stack as it was before calling
666 (/show0 "entering TOP-FRAME")
667 (multiple-value-bind (fp pc) (%caller-frame-and-pc)
668 (compute-calling-frame (descriptor-sap fp) pc nil)))
670 ;;; Flush all of the frames above FRAME, and renumber all the frames
672 (defun flush-frames-above (frame)
673 (setf (frame-up frame) nil)
674 (do ((number 0 (1+ number))
675 (frame frame (frame-%down frame)))
676 ((not (frame-p frame)))
677 (setf (frame-number frame) number)))
679 ;;; Return the frame immediately below FRAME on the stack; or when
680 ;;; FRAME is the bottom of the stack, return NIL.
681 (defun frame-down (frame)
682 (/show0 "entering FRAME-DOWN")
683 ;; We have to access the old-fp and return-pc out of frame and pass
684 ;; them to COMPUTE-CALLING-FRAME.
685 (let ((down (frame-%down frame)))
686 (if (eq down :unparsed)
687 (let ((debug-fun (frame-debug-fun frame)))
688 (/show0 "in DOWN :UNPARSED case")
689 (setf (frame-%down frame)
692 (let ((c-d-f (compiled-debug-fun-compiler-debug-fun
694 (compute-calling-frame
697 frame sb!vm::ocfp-save-offset
698 (sb!c::compiled-debug-fun-old-fp c-d-f)))
700 frame sb!vm::lra-save-offset
701 (sb!c::compiled-debug-fun-return-pc c-d-f))
704 (let ((fp (frame-pointer frame)))
705 (when (cstack-pointer-valid-p fp)
707 (multiple-value-bind (ra ofp) (x86-call-context fp)
708 (compute-calling-frame ofp ra frame))
710 (compute-calling-frame
712 (sap-ref-sap fp (* sb!vm::ocfp-save-offset
716 (sap-ref-32 fp (* sb!vm::ocfp-save-offset
719 (stack-ref fp sb!vm::lra-save-offset)
724 ;;; Get the old FP or return PC out of FRAME. STACK-SLOT is the
725 ;;; standard save location offset on the stack. LOC is the saved
726 ;;; SC-OFFSET describing the main location.
728 (defun get-context-value (frame stack-slot loc)
729 (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
730 (type sb!c::sc-offset loc))
731 (let ((pointer (frame-pointer frame))
732 (escaped (compiled-frame-escaped frame)))
734 (sub-access-debug-var-slot pointer loc escaped)
735 (stack-ref pointer stack-slot))))
737 (defun get-context-value (frame stack-slot loc)
738 (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
739 (type sb!c::sc-offset loc))
740 (let ((pointer (frame-pointer frame))
741 (escaped (compiled-frame-escaped frame)))
743 (sub-access-debug-var-slot pointer loc escaped)
745 (#.sb!vm::ocfp-save-offset
746 (stack-ref pointer stack-slot))
747 (#.sb!vm::lra-save-offset
748 (sap-ref-sap pointer (- (* (1+ stack-slot) 4))))))))
751 (defun (setf get-context-value) (value frame stack-slot loc)
752 (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
753 (type sb!c::sc-offset loc))
754 (let ((pointer (frame-pointer frame))
755 (escaped (compiled-frame-escaped frame)))
757 (sub-set-debug-var-slot pointer loc value escaped)
758 (setf (stack-ref pointer stack-slot) value))))
761 (defun (setf get-context-value) (value frame stack-slot loc)
762 (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
763 (type sb!c::sc-offset loc))
764 (let ((pointer (frame-pointer frame))
765 (escaped (compiled-frame-escaped frame)))
767 (sub-set-debug-var-slot pointer loc value escaped)
769 (#.sb!vm::ocfp-save-offset
770 (setf (stack-ref pointer stack-slot) value))
771 (#.sb!vm::lra-save-offset
772 (setf (sap-ref-sap pointer (- (* (1+ stack-slot) 4))) value))))))
774 ;;; This returns a frame for the one existing in time immediately
775 ;;; prior to the frame referenced by current-fp. This is current-fp's
776 ;;; caller or the next frame down the control stack. If there is no
777 ;;; down frame, this returns nil for the bottom of the stack. Up-frame
778 ;;; is the up link for the resulting frame object, and it is nil when
779 ;;; we call this to get the top of the stack.
781 ;;; The current frame contains the pointer to the temporally previous
782 ;;; frame we want, and the current frame contains the pc at which we
783 ;;; will continue executing upon returning to that previous frame.
785 ;;; Note: Sometimes LRA is actually a fixnum. This happens when lisp
786 ;;; calls into C. In this case, the code object is stored on the stack
787 ;;; after the LRA, and the LRA is the word offset.
789 (defun compute-calling-frame (caller lra up-frame)
790 (declare (type system-area-pointer caller))
791 (when (cstack-pointer-valid-p caller)
792 (multiple-value-bind (code pc-offset escaped)
794 (multiple-value-bind (word-offset code)
796 (let ((fp (frame-pointer up-frame)))
798 (stack-ref fp (1+ sb!vm::lra-save-offset))))
799 (values (get-header-data lra)
800 (lra-code-header lra)))
803 (* (1+ (- word-offset (get-header-data code)))
806 (values :foreign-function
809 (find-escaped-frame caller))
810 (if (and (code-component-p code)
811 (eq (%code-debug-info code) :bogus-lra))
812 (let ((real-lra (code-header-ref code real-lra-slot)))
813 (compute-calling-frame caller real-lra up-frame))
814 (let ((d-fun (case code
816 (make-bogus-debug-fun
817 "undefined function"))
819 (make-bogus-debug-fun
820 "foreign function call land"))
822 (make-bogus-debug-fun
823 "bogus stack frame"))
825 (debug-fun-from-pc code pc-offset)))))
826 (make-compiled-frame caller up-frame d-fun
827 (code-location-from-pc d-fun pc-offset
829 (if up-frame (1+ (frame-number up-frame)) 0)
833 (defun compute-calling-frame (caller ra up-frame)
834 (declare (type system-area-pointer caller ra))
835 (/show0 "entering COMPUTE-CALLING-FRAME")
836 (when (cstack-pointer-valid-p caller)
838 ;; First check for an escaped frame.
839 (multiple-value-bind (code pc-offset escaped) (find-escaped-frame caller)
842 (/show0 "in CODE clause")
843 ;; If it's escaped it may be a function end breakpoint trap.
844 (when (and (code-component-p code)
845 (eq (%code-debug-info code) :bogus-lra))
846 ;; If :bogus-lra grab the real lra.
847 (setq pc-offset (code-header-ref
848 code (1+ real-lra-slot)))
849 (setq code (code-header-ref code real-lra-slot))
852 (/show0 "in T clause")
854 (multiple-value-setq (pc-offset code)
855 (compute-lra-data-from-pc ra))
857 (setf code :foreign-function
861 (let ((d-fun (case code
863 (make-bogus-debug-fun
864 "undefined function"))
866 (make-bogus-debug-fun
867 "foreign function call land"))
869 (make-bogus-debug-fun
870 "bogus stack frame"))
872 (debug-fun-from-pc code pc-offset)))))
873 (/show0 "returning MAKE-COMPILED-FRAME from COMPUTE-CALLING-FRAME")
874 (make-compiled-frame caller up-frame d-fun
875 (code-location-from-pc d-fun pc-offset
877 (if up-frame (1+ (frame-number up-frame)) 0)
881 (defun find-escaped-frame (frame-pointer)
882 (declare (type system-area-pointer frame-pointer))
883 (/show0 "entering FIND-ESCAPED-FRAME")
884 (dotimes (index *free-interrupt-context-index* (values nil 0 nil))
886 ((lisp-interrupt-contexts (array (* os-context-t) nil) :extern))
887 (/show0 "at head of WITH-ALIEN")
888 (let ((context (sb!alien:deref lisp-interrupt-contexts index)))
889 (/show0 "got CONTEXT")
890 (when (= (sap-int frame-pointer)
891 (sb!vm:context-register context sb!vm::cfp-offset))
893 (/show0 "in WITHOUT-GCING")
894 (let* ((component-ptr (component-ptr-from-pc
895 (sb!vm:context-pc context)))
896 (code (unless (sap= component-ptr (int-sap #x0))
897 (component-from-component-ptr component-ptr))))
900 (return (values code 0 context)))
901 (let* ((code-header-len (* (get-header-data code)
904 (- (sap-int (sb!vm:context-pc context))
905 (- (get-lisp-obj-address code)
906 sb!vm:other-pointer-type)
908 (/show "got PC-OFFSET")
909 (unless (<= 0 pc-offset
910 (* (code-header-ref code sb!vm:code-code-size-slot)
912 ;; We were in an assembly routine. Therefore, use the
915 ;; FIXME: Should this be WARN or ERROR or what?
916 (format t "** pc-offset ~S not in code obj ~S?~%"
918 (/show0 "returning from FIND-ESCAPED-FRAME")
920 (values code pc-offset context))))))))))
923 (defun find-escaped-frame (frame-pointer)
924 (declare (type system-area-pointer frame-pointer))
925 (dotimes (index *free-interrupt-context-index* (values nil 0 nil))
927 ((lisp-interrupt-contexts (array (* os-context-t) nil) :extern))
928 (let ((scp (sb!alien:deref lisp-interrupt-contexts index)))
929 (when (= (sap-int frame-pointer)
930 (sb!vm:context-register scp sb!vm::cfp-offset))
932 (let ((code (code-object-from-bits
933 (sb!vm:context-register scp sb!vm::code-offset))))
935 (return (values code 0 scp)))
936 (let* ((code-header-len (* (get-header-data code)
939 (- (sap-int (sb!vm:context-pc scp))
940 (- (get-lisp-obj-address code)
941 sb!vm:other-pointer-type)
943 ;; Check to see whether we were executing in a branch
945 #!+(or pmax sgi) ; pmax only (and broken anyway)
946 (when (logbitp 31 (sb!alien:slot scp '%mips::sc-cause))
947 (incf pc-offset sb!vm:word-bytes))
948 (unless (<= 0 pc-offset
949 (* (code-header-ref code sb!vm:code-code-size-slot)
951 ;; We were in an assembly routine. Therefore, use the
954 (- (sb!vm:context-register scp sb!vm::lra-offset)
955 (get-lisp-obj-address code)
958 (if (eq (%code-debug-info code) :bogus-lra)
959 (let ((real-lra (code-header-ref code
961 (values (lra-code-header real-lra)
962 (get-header-data real-lra)
964 (values code pc-offset scp)))))))))))
966 ;;; Find the code object corresponding to the object represented by
967 ;;; bits and return it. We assume bogus functions correspond to the
968 ;;; undefined-function.
969 (defun code-object-from-bits (bits)
970 (declare (type (unsigned-byte 32) bits))
971 (let ((object (make-lisp-obj bits)))
972 (if (functionp object)
973 (or (function-code-header object)
975 (let ((lowtag (get-lowtag object)))
976 (if (= lowtag sb!vm:other-pointer-type)
977 (let ((type (get-type object)))
978 (cond ((= type sb!vm:code-header-type)
980 ((= type sb!vm:return-pc-header-type)
981 (lra-code-header object))
987 ;;; This returns a COMPILED-DEBUG-FUN for code and pc. We fetch the
988 ;;; SB!C::DEBUG-INFO and run down its FUN-MAP to get a
989 ;;; SB!C::COMPILED-DEBUG-FUN from the pc. The result only needs to
990 ;;; reference the component, for function constants, and the
991 ;;; SB!C::COMPILED-DEBUG-FUN.
992 (defun debug-fun-from-pc (component pc)
993 (let ((info (%code-debug-info component)))
996 (debug-signal 'no-debug-info :code-component component))
997 ((eq info :bogus-lra)
998 (make-bogus-debug-fun "function end breakpoint"))
1000 (let* ((fun-map (get-debug-info-fun-map info))
1001 (len (length fun-map)))
1002 (declare (type simple-vector fun-map))
1004 (make-compiled-debug-fun (svref fun-map 0) component)
1007 (>= pc (sb!c::compiled-debug-fun-elsewhere-pc
1008 (svref fun-map 0)))))
1009 (declare (type sb!int:index i))
1012 (< pc (if elsewhere-p
1013 (sb!c::compiled-debug-fun-elsewhere-pc
1014 (svref fun-map (1+ i)))
1015 (svref fun-map i))))
1016 (return (make-compiled-debug-fun
1017 (svref fun-map (1- i))
1021 ;;; This returns a code-location for the COMPILED-DEBUG-FUN,
1022 ;;; DEBUG-FUN, and the pc into its code vector. If we stopped at a
1023 ;;; breakpoint, find the CODE-LOCATION for that breakpoint. Otherwise,
1024 ;;; make an :UNSURE code location, so it can be filled in when we
1025 ;;; figure out what is going on.
1026 (defun code-location-from-pc (debug-fun pc escaped)
1027 (or (and (compiled-debug-fun-p debug-fun)
1029 (let ((data (breakpoint-data
1030 (compiled-debug-fun-component debug-fun)
1032 (when (and data (breakpoint-data-breakpoints data))
1033 (let ((what (breakpoint-what
1034 (first (breakpoint-data-breakpoints data)))))
1035 (when (compiled-code-location-p what)
1037 (make-compiled-code-location pc debug-fun)))
1039 ;;; Return an alist mapping catch tags to CODE-LOCATIONs. These are
1040 ;;; CODE-LOCATIONs at which execution would continue with frame as the
1041 ;;; top frame if someone threw to the corresponding tag.
1042 (defun frame-catches (frame)
1043 (let ((catch (descriptor-sap *current-catch-block*))
1045 (fp (frame-pointer frame)))
1047 (when (zerop (sap-int catch)) (return (nreverse res)))
1051 (* sb!vm:catch-block-current-cont-slot
1056 (* sb!vm:catch-block-current-cont-slot
1057 sb!vm:word-bytes))))
1059 (lra (stack-ref catch sb!vm:catch-block-entry-pc-slot))
1062 catch (* sb!vm:catch-block-entry-pc-slot
1066 (stack-ref catch sb!vm:catch-block-current-code-slot))
1068 (component (component-from-component-ptr
1069 (component-ptr-from-pc ra)))
1072 (* (- (1+ (get-header-data lra))
1073 (get-header-data component))
1077 (- (get-lisp-obj-address component)
1078 sb!vm:other-pointer-type)
1079 (* (get-header-data component) sb!vm:word-bytes))))
1081 (stack-ref catch sb!vm:catch-block-tag-slot)
1084 (sap-ref-32 catch (* sb!vm:catch-block-tag-slot
1086 (make-compiled-code-location
1087 offset (frame-debug-fun frame)))
1092 (* sb!vm:catch-block-previous-catch-slot
1097 (* sb!vm:catch-block-previous-catch-slot
1098 sb!vm:word-bytes)))))))
1100 ;;;; operations on DEBUG-FUNs
1102 ;;; Execute the forms in a context with BLOCK-VAR bound to each
1103 ;;; DEBUG-BLOCK in DEBUG-FUN successively. Result is an optional
1104 ;;; form to execute for return values, and DO-DEBUG-FUN-BLOCKS
1105 ;;; returns nil if there is no result form. This signals a
1106 ;;; NO-DEBUG-BLOCKS condition when the DEBUG-FUN lacks
1107 ;;; DEBUG-BLOCK information.
1108 (defmacro do-debug-fun-blocks ((block-var debug-fun &optional result)
1110 (let ((blocks (gensym))
1112 `(let ((,blocks (debug-fun-debug-blocks ,debug-fun)))
1113 (declare (simple-vector ,blocks))
1114 (dotimes (,i (length ,blocks) ,result)
1115 (let ((,block-var (svref ,blocks ,i)))
1118 ;;; Execute body in a context with VAR bound to each DEBUG-VAR in
1119 ;;; DEBUG-FUN. This returns the value of executing result (defaults to
1120 ;;; nil). This may iterate over only some of DEBUG-FUN's variables or
1121 ;;; none depending on debug policy; for example, possibly the
1122 ;;; compilation only preserved argument information.
1123 (defmacro do-debug-fun-variables ((var debug-fun &optional result)
1125 (let ((vars (gensym))
1127 `(let ((,vars (debug-fun-debug-vars ,debug-fun)))
1128 (declare (type (or null simple-vector) ,vars))
1130 (dotimes (,i (length ,vars) ,result)
1131 (let ((,var (svref ,vars ,i)))
1135 ;;; Return the object of type FUNCTION associated with the DEBUG-FUN,
1136 ;;; or NIL if the function is unavailable or is non-existent as a user
1137 ;;; callable function object.
1138 (defun debug-fun-fun (debug-fun)
1139 (let ((cached-value (debug-fun-%function debug-fun)))
1140 (if (eq cached-value :unparsed)
1141 (setf (debug-fun-%function debug-fun)
1142 (etypecase debug-fun
1145 (compiled-debug-fun-component debug-fun))
1147 (sb!c::compiled-debug-fun-start-pc
1148 (compiled-debug-fun-compiler-debug-fun debug-fun))))
1149 (do ((entry (%code-entry-points component)
1150 (%function-next entry)))
1153 (sb!c::compiled-debug-fun-start-pc
1154 (compiled-debug-fun-compiler-debug-fun
1155 (fun-debug-fun entry))))
1157 (bogus-debug-fun nil)))
1160 ;;; Return the name of the function represented by DEBUG-FUN. This may
1161 ;;; be a string or a cons; do not assume it is a symbol.
1162 (defun debug-fun-name (debug-fun)
1163 (etypecase debug-fun
1165 (sb!c::compiled-debug-fun-name
1166 (compiled-debug-fun-compiler-debug-fun debug-fun)))
1168 (bogus-debug-fun-%name debug-fun))))
1170 ;;; Return a DEBUG-FUN that represents debug information for FUN.
1171 (defun fun-debug-fun (fun)
1172 (declare (type function fun))
1173 (ecase (get-type fun)
1174 (#.sb!vm:closure-header-type
1175 (fun-debug-fun (%closure-function fun)))
1176 (#.sb!vm:funcallable-instance-header-type
1177 (fun-debug-fun (funcallable-instance-function fun)))
1178 ((#.sb!vm:function-header-type #.sb!vm:closure-function-header-type)
1179 (let* ((name (%function-name fun))
1180 (component (function-code-header fun))
1183 (and (sb!c::compiled-debug-fun-p x)
1184 (eq (sb!c::compiled-debug-fun-name x) name)
1185 (eq (sb!c::compiled-debug-fun-kind x) nil)))
1186 (get-debug-info-fun-map
1187 (%code-debug-info component)))))
1189 (make-compiled-debug-fun res component)
1190 ;; KLUDGE: comment from CMU CL:
1191 ;; This used to be the non-interpreted branch, but
1192 ;; William wrote it to return the debug-fun of fun's XEP
1193 ;; instead of fun's debug-fun. The above code does this
1194 ;; more correctly, but it doesn't get or eliminate all
1195 ;; appropriate cases. It mostly works, and probably
1196 ;; works for all named functions anyway.
1198 (debug-fun-from-pc component
1199 (* (- (function-word-offset fun)
1200 (get-header-data component))
1201 sb!vm:word-bytes)))))))
1203 ;;; Return the kind of the function, which is one of :OPTIONAL,
1204 ;;; :EXTERNAL, TOP-level, :CLEANUP, or NIL.
1205 (defun debug-fun-kind (debug-fun)
1206 ;; FIXME: This "is one of" information should become part of the function
1207 ;; declamation, not just a doc string
1208 (etypecase debug-fun
1210 (sb!c::compiled-debug-fun-kind
1211 (compiled-debug-fun-compiler-debug-fun debug-fun)))
1215 ;;; Is there any variable information for DEBUG-FUN?
1216 (defun debug-var-info-available (debug-fun)
1217 (not (not (debug-fun-debug-vars debug-fun))))
1219 ;;; Return a list of DEBUG-VARs in DEBUG-FUN having the same name
1220 ;;; and package as SYMBOL. If SYMBOL is uninterned, then this returns
1221 ;;; a list of DEBUG-VARs without package names and with the same name
1222 ;;; as symbol. The result of this function is limited to the
1223 ;;; availability of variable information in DEBUG-FUN; for
1224 ;;; example, possibly DEBUG-FUN only knows about its arguments.
1225 (defun debug-fun-symbol-variables (debug-fun symbol)
1226 (let ((vars (ambiguous-debug-vars debug-fun (symbol-name symbol)))
1227 (package (and (symbol-package symbol)
1228 (package-name (symbol-package symbol)))))
1229 (delete-if (if (stringp package)
1231 (let ((p (debug-var-package-name var)))
1232 (or (not (stringp p))
1233 (string/= p package))))
1235 (stringp (debug-var-package-name var))))
1238 ;;; Return a list of DEBUG-VARs in DEBUG-FUN whose names contain
1239 ;;; NAME-PREFIX-STRING as an initial substring. The result of this
1240 ;;; function is limited to the availability of variable information in
1241 ;;; debug-fun; for example, possibly debug-fun only knows
1242 ;;; about its arguments.
1243 (defun ambiguous-debug-vars (debug-fun name-prefix-string)
1244 (declare (simple-string name-prefix-string))
1245 (let ((variables (debug-fun-debug-vars debug-fun)))
1246 (declare (type (or null simple-vector) variables))
1248 (let* ((len (length variables))
1249 (prefix-len (length name-prefix-string))
1250 (pos (find-variable name-prefix-string variables len))
1253 ;; Find names from pos to variable's len that contain prefix.
1254 (do ((i pos (1+ i)))
1256 (let* ((var (svref variables i))
1257 (name (debug-var-symbol-name var))
1258 (name-len (length name)))
1259 (declare (simple-string name))
1260 (when (/= (or (string/= name-prefix-string name
1261 :end1 prefix-len :end2 name-len)
1266 (setq res (nreverse res)))
1269 ;;; This returns a position in variables for one containing name as an
1270 ;;; initial substring. End is the length of variables if supplied.
1271 (defun find-variable (name variables &optional end)
1272 (declare (simple-vector variables)
1273 (simple-string name))
1274 (let ((name-len (length name)))
1275 (position name variables
1276 :test #'(lambda (x y)
1277 (let* ((y (debug-var-symbol-name y))
1279 (declare (simple-string y))
1280 (and (>= y-len name-len)
1281 (string= x y :end1 name-len :end2 name-len))))
1282 :end (or end (length variables)))))
1284 ;;; Return a list representing the lambda-list for DEBUG-FUN. The
1285 ;;; list has the following structure:
1286 ;;; (required-var1 required-var2
1288 ;;; (:optional var3 suppliedp-var4)
1289 ;;; (:optional var5)
1291 ;;; (:rest var6) (:rest var7)
1293 ;;; (:keyword keyword-symbol var8 suppliedp-var9)
1294 ;;; (:keyword keyword-symbol var10)
1297 ;;; Each VARi is a DEBUG-VAR; however it may be the symbol :DELETED if
1298 ;;; it is unreferenced in DEBUG-FUN. This signals a
1299 ;;; LAMBDA-LIST-UNAVAILABLE condition when there is no argument list
1301 (defun debug-fun-lambda-list (debug-fun)
1302 (etypecase debug-fun
1303 (compiled-debug-fun (compiled-debug-fun-lambda-list debug-fun))
1304 (bogus-debug-fun nil)))
1306 ;;; Note: If this has to compute the lambda list, it caches it in DEBUG-FUN.
1307 (defun compiled-debug-fun-lambda-list (debug-fun)
1308 (let ((lambda-list (debug-fun-%lambda-list debug-fun)))
1309 (cond ((eq lambda-list :unparsed)
1310 (multiple-value-bind (args argsp)
1311 (parse-compiled-debug-fun-lambda-list debug-fun)
1312 (setf (debug-fun-%lambda-list debug-fun) args)
1315 (debug-signal 'lambda-list-unavailable
1316 :debug-fun debug-fun))))
1318 ((bogus-debug-fun-p debug-fun)
1320 ((sb!c::compiled-debug-fun-arguments
1321 (compiled-debug-fun-compiler-debug-fun debug-fun))
1322 ;; If the packed information is there (whether empty or not) as
1323 ;; opposed to being nil, then returned our cached value (nil).
1326 ;; Our cached value is nil, and the packed lambda-list information
1327 ;; is nil, so we don't have anything available.
1328 (debug-signal 'lambda-list-unavailable
1329 :debug-fun debug-fun)))))
1331 ;;; COMPILED-DEBUG-FUN-LAMBDA-LIST calls this when a
1332 ;;; COMPILED-DEBUG-FUN has no lambda list information cached. It
1333 ;;; returns the lambda list as the first value and whether there was
1334 ;;; any argument information as the second value. Therefore,
1335 ;;; (VALUES NIL T) means there were no arguments, but (VALUES NIL NIL)
1336 ;;; means there was no argument information.
1337 (defun parse-compiled-debug-fun-lambda-list (debug-fun)
1338 (let ((args (sb!c::compiled-debug-fun-arguments
1339 (compiled-debug-fun-compiler-debug-fun debug-fun))))
1344 (values (coerce (debug-fun-debug-vars debug-fun) 'list)
1347 (let ((vars (debug-fun-debug-vars debug-fun))
1352 (declare (type (or null simple-vector) vars))
1354 (when (>= i len) (return))
1355 (let ((ele (aref args i)))
1360 ;; Deleted required arg at beginning of args array.
1361 (push :deleted res))
1362 (sb!c::optional-args
1365 ;; SUPPLIED-P var immediately following keyword or
1366 ;; optional. Stick the extra var in the result
1367 ;; element representing the keyword or optional,
1368 ;; which is the previous one.
1370 (list (compiled-debug-fun-lambda-list-var
1371 args (incf i) vars))))
1374 (compiled-debug-fun-lambda-list-var
1375 args (incf i) vars))
1378 ;; Just ignore the fact that the next two args are
1379 ;; the &MORE arg context and count, and act like they
1380 ;; are regular arguments.
1384 (push (list :keyword
1386 (compiled-debug-fun-lambda-list-var
1387 args (incf i) vars))
1390 ;; We saw an optional marker, so the following
1391 ;; non-symbols are indexes indicating optional
1393 (push (list :optional (svref vars ele)) res))
1395 ;; Required arg at beginning of args array.
1396 (push (svref vars ele) res))))
1398 (values (nreverse res) t))))))
1400 ;;; This is used in COMPILED-DEBUG-FUN-LAMBDA-LIST.
1401 (defun compiled-debug-fun-lambda-list-var (args i vars)
1402 (declare (type (simple-array * (*)) args)
1403 (simple-vector vars))
1404 (let ((ele (aref args i)))
1405 (cond ((not (symbolp ele)) (svref vars ele))
1406 ((eq ele 'sb!c::deleted) :deleted)
1407 (t (error "malformed arguments description")))))
1409 (defun compiled-debug-fun-debug-info (debug-fun)
1410 (%code-debug-info (compiled-debug-fun-component debug-fun)))
1412 ;;;; unpacking variable and basic block data
1414 (defvar *parsing-buffer*
1415 (make-array 20 :adjustable t :fill-pointer t))
1416 (defvar *other-parsing-buffer*
1417 (make-array 20 :adjustable t :fill-pointer t))
1418 ;;; PARSE-DEBUG-BLOCKS and PARSE-DEBUG-VARS
1419 ;;; use this to unpack binary encoded information. It returns the
1420 ;;; values returned by the last form in body.
1422 ;;; This binds buffer-var to *parsing-buffer*, makes sure it starts at
1423 ;;; element zero, and makes sure if we unwind, we nil out any set
1424 ;;; elements for GC purposes.
1426 ;;; This also binds other-var to *other-parsing-buffer* when it is
1427 ;;; supplied, making sure it starts at element zero and that we nil
1428 ;;; out any elements if we unwind.
1430 ;;; This defines the local macro RESULT that takes a buffer, copies
1431 ;;; its elements to a resulting simple-vector, nil's out elements, and
1432 ;;; restarts the buffer at element zero. RESULT returns the
1434 (eval-when (:compile-toplevel :execute)
1435 (sb!xc:defmacro with-parsing-buffer ((buffer-var &optional other-var)
1437 (let ((len (gensym))
1440 (let ((,buffer-var *parsing-buffer*)
1441 ,@(if other-var `((,other-var *other-parsing-buffer*))))
1442 (setf (fill-pointer ,buffer-var) 0)
1443 ,@(if other-var `((setf (fill-pointer ,other-var) 0)))
1444 (macrolet ((result (buf)
1445 `(let* ((,',len (length ,buf))
1446 (,',res (make-array ,',len)))
1447 (replace ,',res ,buf :end1 ,',len :end2 ,',len)
1448 (fill ,buf nil :end ,',len)
1449 (setf (fill-pointer ,buf) 0)
1452 (fill *parsing-buffer* nil)
1453 ,@(if other-var `((fill *other-parsing-buffer* nil))))))
1456 ;;; The argument is a debug internals structure. This returns the
1457 ;;; DEBUG-BLOCKs for DEBUG-FUN, regardless of whether we have unpacked
1458 ;;; them yet. It signals a NO-DEBUG-BLOCKS condition if it can't
1459 ;;; return the blocks.
1460 (defun debug-fun-debug-blocks (debug-fun)
1461 (let ((blocks (debug-fun-blocks debug-fun)))
1462 (cond ((eq blocks :unparsed)
1463 (setf (debug-fun-blocks debug-fun)
1464 (parse-debug-blocks debug-fun))
1465 (unless (debug-fun-blocks debug-fun)
1466 (debug-signal 'no-debug-blocks
1467 :debug-fun debug-fun))
1468 (debug-fun-blocks debug-fun))
1471 (debug-signal 'no-debug-blocks
1472 :debug-fun debug-fun)))))
1474 ;;; This returns a SIMPLE-VECTOR of DEBUG-BLOCKs or NIL. NIL indicates
1475 ;;; there was no basic block information.
1476 (defun parse-debug-blocks (debug-fun)
1477 (etypecase debug-fun
1479 (parse-compiled-debug-blocks debug-fun))
1481 (debug-signal 'no-debug-blocks :debug-fun debug-fun))))
1483 ;;; This does some of the work of PARSE-DEBUG-BLOCKS.
1484 (defun parse-compiled-debug-blocks (debug-fun)
1485 (let* ((debug-fun (compiled-debug-fun-compiler-debug-fun
1487 (var-count (length (debug-fun-debug-vars debug-fun)))
1488 (blocks (sb!c::compiled-debug-fun-blocks debug-fun))
1489 ;; KLUDGE: 8 is a hard-wired constant in the compiler for the
1490 ;; element size of the packed binary representation of the
1492 (live-set-len (ceiling var-count 8))
1493 (tlf-number (sb!c::compiled-debug-fun-tlf-number debug-fun)))
1494 (unless blocks (return-from parse-compiled-debug-blocks nil))
1495 (macrolet ((aref+ (a i) `(prog1 (aref ,a ,i) (incf ,i))))
1496 (with-parsing-buffer (blocks-buffer locations-buffer)
1498 (len (length blocks))
1501 (when (>= i len) (return))
1502 (let ((succ-and-flags (aref+ blocks i))
1504 (declare (type (unsigned-byte 8) succ-and-flags)
1506 (dotimes (k (ldb sb!c::compiled-debug-block-nsucc-byte
1508 (push (sb!c::read-var-integer blocks i) successors))
1510 (dotimes (k (sb!c::read-var-integer blocks i)
1511 (result locations-buffer))
1512 (let ((kind (svref sb!c::*compiled-code-location-kinds*
1515 (sb!c::read-var-integer blocks i)))
1516 (tlf-offset (or tlf-number
1517 (sb!c::read-var-integer blocks
1519 (form-number (sb!c::read-var-integer blocks i))
1520 (live-set (sb!c::read-packed-bit-vector
1521 live-set-len blocks i)))
1522 (vector-push-extend (make-known-code-location
1523 pc debug-fun tlf-offset
1524 form-number live-set kind)
1526 (setf last-pc pc))))
1527 (block (make-compiled-debug-block
1528 locations successors
1530 sb!c::compiled-debug-block-elsewhere-p
1531 succ-and-flags))))))
1532 (vector-push-extend block blocks-buffer)
1533 (dotimes (k (length locations))
1534 (setf (code-location-%debug-block (svref locations k))
1536 (let ((res (result blocks-buffer)))
1537 (declare (simple-vector res))
1538 (dotimes (i (length res))
1539 (let* ((block (svref res i))
1541 (dolist (ele (debug-block-successors block))
1542 (push (svref res ele) succs))
1543 (setf (debug-block-successors block) succs)))
1546 ;;; The argument is a debug internals structure. This returns NIL if
1547 ;;; there is no variable information. It returns an empty
1548 ;;; simple-vector if there were no locals in the function. Otherwise
1549 ;;; it returns a SIMPLE-VECTOR of DEBUG-VARs.
1550 (defun debug-fun-debug-vars (debug-fun)
1551 (let ((vars (debug-fun-%debug-vars debug-fun)))
1552 (if (eq vars :unparsed)
1553 (setf (debug-fun-%debug-vars debug-fun)
1554 (etypecase debug-fun
1556 (parse-compiled-debug-vars debug-fun))
1557 (bogus-debug-fun nil)))
1560 ;;; VARS is the parsed variables for a minimal debug function. We need
1561 ;;; to assign names of the form ARG-NNN. We must pad with leading
1562 ;;; zeros, since the arguments must be in alphabetical order.
1563 (defun assign-minimal-var-names (vars)
1564 (declare (simple-vector vars))
1565 (let* ((len (length vars))
1566 (width (length (format nil "~D" (1- len)))))
1568 (setf (compiled-debug-var-symbol (svref vars i))
1569 (intern (format nil "ARG-~V,'0D" width i)
1570 ;; KLUDGE: It's somewhat nasty to have a bare
1571 ;; package name string here. It would be
1572 ;; nicer to have #.(FIND-PACKAGE "SB!DEBUG")
1573 ;; instead, since then at least it would transform
1574 ;; correctly under package renaming and stuff.
1575 ;; However, genesis can't handle dumped packages..
1578 ;; FIXME: Maybe this could be fixed by moving the
1579 ;; whole debug-int.lisp file to warm init? (after
1580 ;; which dumping a #.(FIND-PACKAGE ..) expression
1581 ;; would work fine) If this is possible, it would
1582 ;; probably be a good thing, since minimizing the
1583 ;; amount of stuff in cold init is basically good.
1584 (or (find-package "SB-DEBUG")
1585 (find-package "SB!DEBUG")))))))
1587 ;;; Parse the packed representation of DEBUG-VARs from
1588 ;;; DEBUG-FUN's SB!C::COMPILED-DEBUG-FUN, returning a vector
1589 ;;; of DEBUG-VARs, or NIL if there was no information to parse.
1590 (defun parse-compiled-debug-vars (debug-fun)
1591 (let* ((cdebug-fun (compiled-debug-fun-compiler-debug-fun
1593 (packed-vars (sb!c::compiled-debug-fun-variables cdebug-fun))
1594 (args-minimal (eq (sb!c::compiled-debug-fun-arguments cdebug-fun)
1598 (buffer (make-array 0 :fill-pointer 0 :adjustable t)))
1599 ((>= i (length packed-vars))
1600 (let ((result (coerce buffer 'simple-vector)))
1602 (assign-minimal-var-names result))
1604 (flet ((geti () (prog1 (aref packed-vars i) (incf i))))
1605 (let* ((flags (geti))
1606 (minimal (logtest sb!c::compiled-debug-var-minimal-p flags))
1607 (deleted (logtest sb!c::compiled-debug-var-deleted-p flags))
1608 (live (logtest sb!c::compiled-debug-var-environment-live
1610 (save (logtest sb!c::compiled-debug-var-save-loc-p flags))
1611 (symbol (if minimal nil (geti)))
1612 (id (if (logtest sb!c::compiled-debug-var-id-p flags)
1615 (sc-offset (if deleted 0 (geti)))
1616 (save-sc-offset (if save (geti) nil)))
1617 (aver (not (and args-minimal (not minimal))))
1618 (vector-push-extend (make-compiled-debug-var symbol
1625 ;;;; unpacking minimal debug functions
1627 ;;; Return a FUN-MAP for a given COMPILED-DEBUG-INFO object.
1628 (defun get-debug-info-fun-map (info)
1629 (declare (type sb!c::compiled-debug-info info))
1630 (let ((map (sb!c::compiled-debug-info-fun-map info)))
1631 ;; The old CMU CL had various hairy possibilities here, but in
1632 ;; SBCL we only use this one, right?
1633 (aver (simple-vector-p map))
1639 ;;; If we're sure of whether code-location is known, return T or NIL.
1640 ;;; If we're :UNSURE, then try to fill in the code-location's slots.
1641 ;;; This determines whether there is any debug-block information, and
1642 ;;; if code-location is known.
1644 ;;; ??? IF this conses closures every time it's called, then break off the
1645 ;;; :UNSURE part to get the HANDLER-CASE into another function.
1646 (defun code-location-unknown-p (basic-code-location)
1647 (ecase (code-location-%unknown-p basic-code-location)
1651 (setf (code-location-%unknown-p basic-code-location)
1652 (handler-case (not (fill-in-code-location basic-code-location))
1653 (no-debug-blocks () t))))))
1655 ;;; Return the DEBUG-BLOCK containing code-location if it is available.
1656 ;;; Some debug policies inhibit debug-block information, and if none
1657 ;;; is available, then this signals a NO-DEBUG-BLOCKS condition.
1658 (defun code-location-debug-block (basic-code-location)
1659 (let ((block (code-location-%debug-block basic-code-location)))
1660 (if (eq block :unparsed)
1661 (etypecase basic-code-location
1662 (compiled-code-location
1663 (compute-compiled-code-location-debug-block basic-code-location))
1664 ;; (There used to be more cases back before sbcl-0.7.0, when
1665 ;; we did special tricks to debug the IR1 interpreter.)
1669 ;;; Store and return BASIC-CODE-LOCATION's debug-block. We determines
1670 ;;; the correct one using the code-location's pc. We use
1671 ;;; DEBUG-FUN-DEBUG-BLOCKS to return the cached block information
1672 ;;; or signal a NO-DEBUG-BLOCKS condition. The blocks are sorted by
1673 ;;; their first code-location's pc, in ascending order. Therefore, as
1674 ;;; soon as we find a block that starts with a pc greater than
1675 ;;; basic-code-location's pc, we know the previous block contains the
1676 ;;; pc. If we get to the last block, then the code-location is either
1677 ;;; in the second to last block or the last block, and we have to be
1678 ;;; careful in determining this since the last block could be code at
1679 ;;; the end of the function. We have to check for the last block being
1680 ;;; code first in order to see how to compare the code-location's pc.
1681 (defun compute-compiled-code-location-debug-block (basic-code-location)
1682 (let* ((pc (compiled-code-location-pc basic-code-location))
1683 (debug-fun (code-location-debug-fun
1684 basic-code-location))
1685 (blocks (debug-fun-debug-blocks debug-fun))
1686 (len (length blocks)))
1687 (declare (simple-vector blocks))
1688 (setf (code-location-%debug-block basic-code-location)
1694 (let ((last (svref blocks end)))
1696 ((debug-block-elsewhere-p last)
1698 (sb!c::compiled-debug-fun-elsewhere-pc
1699 (compiled-debug-fun-compiler-debug-fun
1701 (svref blocks (1- end))
1704 (compiled-code-location-pc
1705 (svref (compiled-debug-block-code-locations last)
1707 (svref blocks (1- end)))
1709 (declare (type sb!c::index i end))
1711 (compiled-code-location-pc
1712 (svref (compiled-debug-block-code-locations
1715 (return (svref blocks (1- i)))))))))
1717 ;;; Return the CODE-LOCATION's DEBUG-SOURCE.
1718 (defun code-location-debug-source (code-location)
1719 (etypecase code-location
1720 (compiled-code-location
1721 (let* ((info (compiled-debug-fun-debug-info
1722 (code-location-debug-fun code-location)))
1723 (sources (sb!c::compiled-debug-info-source info))
1724 (len (length sources)))
1725 (declare (list sources))
1727 (debug-signal 'no-debug-blocks :debug-fun
1728 (code-location-debug-fun code-location)))
1731 (do ((prev sources src)
1732 (src (cdr sources) (cdr src))
1733 (offset (code-location-top-level-form-offset code-location)))
1734 ((null src) (car prev))
1735 (when (< offset (sb!c::debug-source-source-root (car src)))
1736 (return (car prev)))))))
1737 ;; (There used to be more cases back before sbcl-0.7.0, when we
1738 ;; did special tricks to debug the IR1 interpreter.)
1741 ;;; Returns the number of top-level forms before the one containing
1742 ;;; CODE-LOCATION as seen by the compiler in some compilation unit. (A
1743 ;;; compilation unit is not necessarily a single file, see the section
1744 ;;; on debug-sources.)
1745 (defun code-location-top-level-form-offset (code-location)
1746 (when (code-location-unknown-p code-location)
1747 (error 'unknown-code-location :code-location code-location))
1748 (let ((tlf-offset (code-location-%tlf-offset code-location)))
1749 (cond ((eq tlf-offset :unparsed)
1750 (etypecase code-location
1751 (compiled-code-location
1752 (unless (fill-in-code-location code-location)
1753 ;; This check should be unnecessary. We're missing
1754 ;; debug info the compiler should have dumped.
1755 (error "internal error: unknown code location"))
1756 (code-location-%tlf-offset code-location))
1757 ;; (There used to be more cases back before sbcl-0.7.0,,
1758 ;; when we did special tricks to debug the IR1
1763 ;;; Return the number of the form corresponding to CODE-LOCATION. The
1764 ;;; form number is derived by a walking the subforms of a top-level
1765 ;;; form in depth-first order.
1766 (defun code-location-form-number (code-location)
1767 (when (code-location-unknown-p code-location)
1768 (error 'unknown-code-location :code-location code-location))
1769 (let ((form-num (code-location-%form-number code-location)))
1770 (cond ((eq form-num :unparsed)
1771 (etypecase code-location
1772 (compiled-code-location
1773 (unless (fill-in-code-location code-location)
1774 ;; This check should be unnecessary. We're missing
1775 ;; debug info the compiler should have dumped.
1776 (error "internal error: unknown code location"))
1777 (code-location-%form-number code-location))
1778 ;; (There used to be more cases back before sbcl-0.7.0,,
1779 ;; when we did special tricks to debug the IR1
1784 ;;; Return the kind of CODE-LOCATION, one of:
1785 ;;; :INTERPRETED, :UNKNOWN-RETURN, :KNOWN-RETURN, :INTERNAL-ERROR,
1786 ;;; :NON-LOCAL-EXIT, :BLOCK-START, :CALL-SITE, :SINGLE-VALUE-RETURN,
1787 ;;; :NON-LOCAL-ENTRY
1788 (defun code-location-kind (code-location)
1789 (when (code-location-unknown-p code-location)
1790 (error 'unknown-code-location :code-location code-location))
1791 (etypecase code-location
1792 (compiled-code-location
1793 (let ((kind (compiled-code-location-kind code-location)))
1794 (cond ((not (eq kind :unparsed)) kind)
1795 ((not (fill-in-code-location code-location))
1796 ;; This check should be unnecessary. We're missing
1797 ;; debug info the compiler should have dumped.
1798 (error "internal error: unknown code location"))
1800 (compiled-code-location-kind code-location)))))
1801 ;; (There used to be more cases back before sbcl-0.7.0,,
1802 ;; when we did special tricks to debug the IR1
1806 ;;; This returns CODE-LOCATION's live-set if it is available. If
1807 ;;; there is no debug-block information, this returns NIL.
1808 (defun compiled-code-location-live-set (code-location)
1809 (if (code-location-unknown-p code-location)
1811 (let ((live-set (compiled-code-location-%live-set code-location)))
1812 (cond ((eq live-set :unparsed)
1813 (unless (fill-in-code-location code-location)
1814 ;; This check should be unnecessary. We're missing
1815 ;; debug info the compiler should have dumped.
1817 ;; FIXME: This error and comment happen over and over again.
1818 ;; Make them a shared function.
1819 (error "internal error: unknown code location"))
1820 (compiled-code-location-%live-set code-location))
1823 ;;; true if OBJ1 and OBJ2 are the same place in the code
1824 (defun code-location= (obj1 obj2)
1826 (compiled-code-location
1828 (compiled-code-location
1829 (and (eq (code-location-debug-fun obj1)
1830 (code-location-debug-fun obj2))
1831 (sub-compiled-code-location= obj1 obj2)))
1832 ;; (There used to be more cases back before sbcl-0.7.0,,
1833 ;; when we did special tricks to debug the IR1
1836 ;; (There used to be more cases back before sbcl-0.7.0,,
1837 ;; when we did special tricks to debug the IR1
1840 (defun sub-compiled-code-location= (obj1 obj2)
1841 (= (compiled-code-location-pc obj1)
1842 (compiled-code-location-pc obj2)))
1844 ;;; Fill in CODE-LOCATION's :UNPARSED slots, returning T or NIL
1845 ;;; depending on whether the code-location was known in its
1846 ;;; DEBUG-FUN's debug-block information. This may signal a
1847 ;;; NO-DEBUG-BLOCKS condition due to DEBUG-FUN-DEBUG-BLOCKS, and
1848 ;;; it assumes the %UNKNOWN-P slot is already set or going to be set.
1849 (defun fill-in-code-location (code-location)
1850 (declare (type compiled-code-location code-location))
1851 (let* ((debug-fun (code-location-debug-fun code-location))
1852 (blocks (debug-fun-debug-blocks debug-fun)))
1853 (declare (simple-vector blocks))
1854 (dotimes (i (length blocks) nil)
1855 (let* ((block (svref blocks i))
1856 (locations (compiled-debug-block-code-locations block)))
1857 (declare (simple-vector locations))
1858 (dotimes (j (length locations))
1859 (let ((loc (svref locations j)))
1860 (when (sub-compiled-code-location= code-location loc)
1861 (setf (code-location-%debug-block code-location) block)
1862 (setf (code-location-%tlf-offset code-location)
1863 (code-location-%tlf-offset loc))
1864 (setf (code-location-%form-number code-location)
1865 (code-location-%form-number loc))
1866 (setf (compiled-code-location-%live-set code-location)
1867 (compiled-code-location-%live-set loc))
1868 (setf (compiled-code-location-kind code-location)
1869 (compiled-code-location-kind loc))
1870 (return-from fill-in-code-location t))))))))
1872 ;;;; operations on DEBUG-BLOCKs
1874 ;;; Execute FORMS in a context with CODE-VAR bound to each
1875 ;;; CODE-LOCATION in DEBUG-BLOCK, and return the value of RESULT.
1876 (defmacro do-debug-block-locations ((code-var debug-block &optional result)
1878 (let ((code-locations (gensym))
1880 `(let ((,code-locations (debug-block-code-locations ,debug-block)))
1881 (declare (simple-vector ,code-locations))
1882 (dotimes (,i (length ,code-locations) ,result)
1883 (let ((,code-var (svref ,code-locations ,i)))
1886 ;;; Return the name of the function represented by DEBUG-FUN.
1887 ;;; This may be a string or a cons; do not assume it is a symbol.
1888 (defun debug-block-function-name (debug-block)
1889 (etypecase debug-block
1890 (compiled-debug-block
1891 (let ((code-locs (compiled-debug-block-code-locations debug-block)))
1892 (declare (simple-vector code-locs))
1893 (if (zerop (length code-locs))
1894 "??? Can't get name of debug-block's function."
1896 (code-location-debug-fun (svref code-locs 0))))))
1897 ;; (There used to be more cases back before sbcl-0.7.0, when we
1898 ;; did special tricks to debug the IR1 interpreter.)
1901 (defun debug-block-code-locations (debug-block)
1902 (etypecase debug-block
1903 (compiled-debug-block
1904 (compiled-debug-block-code-locations debug-block))
1905 ;; (There used to be more cases back before sbcl-0.7.0, when we
1906 ;; did special tricks to debug the IR1 interpreter.)
1909 ;;;; operations on debug variables
1911 (defun debug-var-symbol-name (debug-var)
1912 (symbol-name (debug-var-symbol debug-var)))
1914 ;;; FIXME: Make sure that this isn't called anywhere that it wouldn't
1915 ;;; be acceptable to have NIL returned, or that it's only called on
1916 ;;; DEBUG-VARs whose symbols have non-NIL packages.
1917 (defun debug-var-package-name (debug-var)
1918 (package-name (symbol-package (debug-var-symbol debug-var))))
1920 ;;; Return the value stored for DEBUG-VAR in frame, or if the value is
1921 ;;; not :VALID, then signal an INVALID-VALUE error.
1922 (defun debug-var-valid-value (debug-var frame)
1923 (unless (eq (debug-var-validity debug-var (frame-code-location frame))
1925 (error 'invalid-value :debug-var debug-var :frame frame))
1926 (debug-var-value debug-var frame))
1928 ;;; Returns the value stored for DEBUG-VAR in frame. The value may be
1929 ;;; invalid. This is SETFable.
1930 (defun debug-var-value (debug-var frame)
1931 (aver (typep frame 'compiled-frame))
1932 (let ((res (access-compiled-debug-var-slot debug-var frame)))
1933 (if (indirect-value-cell-p res)
1934 (value-cell-ref res)
1937 ;;; This returns what is stored for the variable represented by
1938 ;;; DEBUG-VAR relative to the FRAME. This may be an indirect value
1939 ;;; cell if the variable is both closed over and set.
1940 (defun access-compiled-debug-var-slot (debug-var frame)
1941 (declare (optimize (speed 1)))
1942 (let ((escaped (compiled-frame-escaped frame)))
1944 (sub-access-debug-var-slot
1945 (frame-pointer frame)
1946 (compiled-debug-var-sc-offset debug-var)
1948 (sub-access-debug-var-slot
1949 (frame-pointer frame)
1950 (or (compiled-debug-var-save-sc-offset debug-var)
1951 (compiled-debug-var-sc-offset debug-var))))))
1953 ;;; a helper function for working with possibly-invalid values:
1954 ;;; Do (MAKE-LISP-OBJ VAL) only if the value looks valid.
1956 ;;; (Such values can arise in registers on machines with conservative
1957 ;;; GC, and might also arise in debug variable locations when
1958 ;;; those variables are invalid.)
1959 (defun make-valid-lisp-obj (val)
1960 (/show0 "entering MAKE-VALID-LISP-OBJ, VAL=..")
1961 #!+sb-show (/hexstr val)
1964 (zerop (logand val 3))
1966 (and (zerop (logand val #xffff0000)) ; Top bits zero
1967 (= (logand val #xff) sb!vm:base-char-type)) ; Char tag
1969 (= val sb!vm:unbound-marker-type)
1972 ;; Check that the pointer is valid. XXX Could do a better
1973 ;; job. FIXME: e.g. by calling out to an is_valid_pointer
1974 ;; routine in the C runtime support code
1975 (or (< sb!vm:read-only-space-start val
1976 (* sb!vm:*read-only-space-free-pointer*
1978 (< sb!vm:static-space-start val
1979 (* sb!vm:*static-space-free-pointer*
1981 (< sb!vm:dynamic-space-start val
1982 (sap-int (dynamic-space-free-pointer))))))
1987 (defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
1988 (macrolet ((with-escaped-value ((var) &body forms)
1990 (let ((,var (sb!vm:context-register
1992 (sb!c:sc-offset-offset sc-offset))))
1994 :invalid-value-for-unescaped-register-storage))
1995 (escaped-float-value (format)
1997 (sb!vm:context-float-register
1999 (sb!c:sc-offset-offset sc-offset)
2001 :invalid-value-for-unescaped-register-storage))
2002 (with-nfp ((var) &body body)
2003 `(let ((,var (if escaped
2005 (sb!vm:context-register escaped
2008 (sb!sys:sap-ref-sap fp (* sb!vm::nfp-save-offset
2011 (sb!vm::make-number-stack-pointer
2012 (sb!sys:sap-ref-32 fp (* sb!vm::nfp-save-offset
2013 sb!vm:word-bytes))))))
2015 (ecase (sb!c:sc-offset-scn sc-offset)
2016 ((#.sb!vm:any-reg-sc-number
2017 #.sb!vm:descriptor-reg-sc-number
2018 #!+rt #.sb!vm:word-pointer-reg-sc-number)
2019 (sb!sys:without-gcing
2020 (with-escaped-value (val) (sb!kernel:make-lisp-obj val))))
2022 (#.sb!vm:base-char-reg-sc-number
2023 (with-escaped-value (val)
2025 (#.sb!vm:sap-reg-sc-number
2026 (with-escaped-value (val)
2027 (sb!sys:int-sap val)))
2028 (#.sb!vm:signed-reg-sc-number
2029 (with-escaped-value (val)
2030 (if (logbitp (1- sb!vm:word-bits) val)
2031 (logior val (ash -1 sb!vm:word-bits))
2033 (#.sb!vm:unsigned-reg-sc-number
2034 (with-escaped-value (val)
2036 (#.sb!vm:non-descriptor-reg-sc-number
2037 (error "Local non-descriptor register access?"))
2038 (#.sb!vm:interior-reg-sc-number
2039 (error "Local interior register access?"))
2040 (#.sb!vm:single-reg-sc-number
2041 (escaped-float-value single-float))
2042 (#.sb!vm:double-reg-sc-number
2043 (escaped-float-value double-float))
2045 (#.sb!vm:long-reg-sc-number
2046 (escaped-float-value long-float))
2047 (#.sb!vm:complex-single-reg-sc-number
2050 (sb!vm:context-float-register
2051 escaped (sb!c:sc-offset-offset sc-offset) 'single-float)
2052 (sb!vm:context-float-register
2053 escaped (1+ (sb!c:sc-offset-offset sc-offset)) 'single-float))
2054 :invalid-value-for-unescaped-register-storage))
2055 (#.sb!vm:complex-double-reg-sc-number
2058 (sb!vm:context-float-register
2059 escaped (sb!c:sc-offset-offset sc-offset) 'double-float)
2060 (sb!vm:context-float-register
2061 escaped (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 2 #-sparc 1)
2063 :invalid-value-for-unescaped-register-storage))
2065 (#.sb!vm:complex-long-reg-sc-number
2068 (sb!vm:context-float-register
2069 escaped (sb!c:sc-offset-offset sc-offset) 'long-float)
2070 (sb!vm:context-float-register
2071 escaped (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4)
2073 :invalid-value-for-unescaped-register-storage))
2074 (#.sb!vm:single-stack-sc-number
2076 (sb!sys:sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset)
2077 sb!vm:word-bytes))))
2078 (#.sb!vm:double-stack-sc-number
2080 (sb!sys:sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset)
2081 sb!vm:word-bytes))))
2083 (#.sb!vm:long-stack-sc-number
2085 (sb!sys:sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset)
2086 sb!vm:word-bytes))))
2087 (#.sb!vm:complex-single-stack-sc-number
2090 (sb!sys:sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset)
2092 (sb!sys:sap-ref-single nfp (* (1+ (sb!c:sc-offset-offset sc-offset))
2093 sb!vm:word-bytes)))))
2094 (#.sb!vm:complex-double-stack-sc-number
2097 (sb!sys:sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset)
2099 (sb!sys:sap-ref-double nfp (* (+ (sb!c:sc-offset-offset sc-offset) 2)
2100 sb!vm:word-bytes)))))
2102 (#.sb!vm:complex-long-stack-sc-number
2105 (sb!sys:sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset)
2107 (sb!sys:sap-ref-long nfp (* (+ (sb!c:sc-offset-offset sc-offset)
2109 sb!vm:word-bytes)))))
2110 (#.sb!vm:control-stack-sc-number
2111 (sb!kernel:stack-ref fp (sb!c:sc-offset-offset sc-offset)))
2112 (#.sb!vm:base-char-stack-sc-number
2114 (code-char (sb!sys:sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
2115 sb!vm:word-bytes)))))
2116 (#.sb!vm:unsigned-stack-sc-number
2118 (sb!sys:sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
2119 sb!vm:word-bytes))))
2120 (#.sb!vm:signed-stack-sc-number
2122 (sb!sys:signed-sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
2123 sb!vm:word-bytes))))
2124 (#.sb!vm:sap-stack-sc-number
2126 (sb!sys:sap-ref-sap nfp (* (sb!c:sc-offset-offset sc-offset)
2127 sb!vm:word-bytes)))))))
2130 (defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
2131 (declare (type system-area-pointer fp))
2132 (/show0 "entering SUB-ACCESS-DEBUG-VAR-SLOT, FP,SC-OFFSET,ESCAPED=..")
2133 (/hexstr fp) (/hexstr sc-offset) (/hexstr escaped)
2134 (macrolet ((with-escaped-value ((var) &body forms)
2136 (let ((,var (sb!vm:context-register
2138 (sb!c:sc-offset-offset sc-offset))))
2139 (/show0 "in escaped case, ,VAR value=..")
2142 :invalid-value-for-unescaped-register-storage))
2143 (escaped-float-value (format)
2145 (sb!vm:context-float-register
2146 escaped (sb!c:sc-offset-offset sc-offset) ',format)
2147 :invalid-value-for-unescaped-register-storage))
2148 (escaped-complex-float-value (format)
2151 (sb!vm:context-float-register
2152 escaped (sb!c:sc-offset-offset sc-offset) ',format)
2153 (sb!vm:context-float-register
2154 escaped (1+ (sb!c:sc-offset-offset sc-offset)) ',format))
2155 :invalid-value-for-unescaped-register-storage)))
2156 (ecase (sb!c:sc-offset-scn sc-offset)
2157 ((#.sb!vm:any-reg-sc-number #.sb!vm:descriptor-reg-sc-number)
2158 (/show0 "case of ANY-REG-SC-NUMBER or DESCRIPTOR-REG-SC-NUMBER")
2160 (with-escaped-value (val)
2163 (make-valid-lisp-obj val))))
2164 (#.sb!vm:base-char-reg-sc-number
2165 (/show0 "case of BASE-CHAR-REG-SC-NUMBER")
2166 (with-escaped-value (val)
2168 (#.sb!vm:sap-reg-sc-number
2169 (/show0 "case of SAP-REG-SC-NUMBER")
2170 (with-escaped-value (val)
2172 (#.sb!vm:signed-reg-sc-number
2173 (/show0 "case of SIGNED-REG-SC-NUMBER")
2174 (with-escaped-value (val)
2175 (if (logbitp (1- sb!vm:word-bits) val)
2176 (logior val (ash -1 sb!vm:word-bits))
2178 (#.sb!vm:unsigned-reg-sc-number
2179 (/show0 "case of UNSIGNED-REG-SC-NUMBER")
2180 (with-escaped-value (val)
2182 (#.sb!vm:single-reg-sc-number
2183 (/show0 "case of SINGLE-REG-SC-NUMBER")
2184 (escaped-float-value single-float))
2185 (#.sb!vm:double-reg-sc-number
2186 (/show0 "case of DOUBLE-REG-SC-NUMBER")
2187 (escaped-float-value double-float))
2189 (#.sb!vm:long-reg-sc-number
2190 (/show0 "case of LONG-REG-SC-NUMBER")
2191 (escaped-float-value long-float))
2192 (#.sb!vm:complex-single-reg-sc-number
2193 (/show0 "case of COMPLEX-SINGLE-REG-SC-NUMBER")
2194 (escaped-complex-float-value single-float))
2195 (#.sb!vm:complex-double-reg-sc-number
2196 (/show0 "case of COMPLEX-DOUBLE-REG-SC-NUMBER")
2197 (escaped-complex-float-value double-float))
2199 (#.sb!vm:complex-long-reg-sc-number
2200 (/show0 "case of COMPLEX-LONG-REG-SC-NUMBER")
2201 (escaped-complex-float-value long-float))
2202 (#.sb!vm:single-stack-sc-number
2203 (/show0 "case of SINGLE-STACK-SC-NUMBER")
2204 (sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2205 sb!vm:word-bytes))))
2206 (#.sb!vm:double-stack-sc-number
2207 (/show0 "case of DOUBLE-STACK-SC-NUMBER")
2208 (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
2209 sb!vm:word-bytes))))
2211 (#.sb!vm:long-stack-sc-number
2212 (/show0 "case of LONG-STACK-SC-NUMBER")
2213 (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
2214 sb!vm:word-bytes))))
2215 (#.sb!vm:complex-single-stack-sc-number
2216 (/show0 "case of COMPLEX-STACK-SC-NUMBER")
2218 (sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2220 (sap-ref-single fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
2221 sb!vm:word-bytes)))))
2222 (#.sb!vm:complex-double-stack-sc-number
2223 (/show0 "case of COMPLEX-DOUBLE-STACK-SC-NUMBER")
2225 (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
2227 (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 4)
2228 sb!vm:word-bytes)))))
2230 (#.sb!vm:complex-long-stack-sc-number
2231 (/show0 "case of COMPLEX-LONG-STACK-SC-NUMBER")
2233 (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
2235 (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 6)
2236 sb!vm:word-bytes)))))
2237 (#.sb!vm:control-stack-sc-number
2238 (/show0 "case of CONTROL-STACK-SC-NUMBER")
2239 (stack-ref fp (sb!c:sc-offset-offset sc-offset)))
2240 (#.sb!vm:base-char-stack-sc-number
2241 (/show0 "case of BASE-CHAR-STACK-SC-NUMBER")
2243 (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2244 sb!vm:word-bytes)))))
2245 (#.sb!vm:unsigned-stack-sc-number
2246 (/show0 "case of UNSIGNED-STACK-SC-NUMBER")
2247 (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2248 sb!vm:word-bytes))))
2249 (#.sb!vm:signed-stack-sc-number
2250 (/show0 "case of SIGNED-STACK-SC-NUMBER")
2251 (signed-sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2252 sb!vm:word-bytes))))
2253 (#.sb!vm:sap-stack-sc-number
2254 (/show0 "case of SAP-STACK-SC-NUMBER")
2255 (sap-ref-sap fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2256 sb!vm:word-bytes)))))))
2258 ;;; This stores value as the value of DEBUG-VAR in FRAME. In the
2259 ;;; COMPILED-DEBUG-VAR case, access the current value to determine if
2260 ;;; it is an indirect value cell. This occurs when the variable is
2261 ;;; both closed over and set.
2262 (defun %set-debug-var-value (debug-var frame new-value)
2263 (aver (typep frame 'compiled-frame))
2264 (let ((old-value (access-compiled-debug-var-slot debug-var frame)))
2265 (if (indirect-value-cell-p old-value)
2266 (value-cell-set old-value new-value)
2267 (set-compiled-debug-var-slot debug-var frame new-value)))
2270 ;;; This stores VALUE for the variable represented by debug-var
2271 ;;; relative to the frame. This assumes the location directly contains
2272 ;;; the variable's value; that is, there is no indirect value cell
2273 ;;; currently there in case the variable is both closed over and set.
2274 (defun set-compiled-debug-var-slot (debug-var frame value)
2275 (let ((escaped (compiled-frame-escaped frame)))
2277 (sub-set-debug-var-slot (frame-pointer frame)
2278 (compiled-debug-var-sc-offset debug-var)
2280 (sub-set-debug-var-slot
2281 (frame-pointer frame)
2282 (or (compiled-debug-var-save-sc-offset debug-var)
2283 (compiled-debug-var-sc-offset debug-var))
2287 (defun sub-set-debug-var-slot (fp sc-offset value &optional escaped)
2288 (macrolet ((set-escaped-value (val)
2290 (setf (sb!vm:context-register
2292 (sb!c:sc-offset-offset sc-offset))
2295 (set-escaped-float-value (format val)
2297 (setf (sb!vm:context-float-register
2299 (sb!c:sc-offset-offset sc-offset)
2303 (with-nfp ((var) &body body)
2304 `(let ((,var (if escaped
2306 (sb!vm:context-register escaped
2310 (* sb!vm::nfp-save-offset
2313 (sb!vm::make-number-stack-pointer
2315 (* sb!vm::nfp-save-offset
2316 sb!vm:word-bytes))))))
2318 (ecase (sb!c:sc-offset-scn sc-offset)
2319 ((#.sb!vm:any-reg-sc-number
2320 #.sb!vm:descriptor-reg-sc-number
2321 #!+rt #.sb!vm:word-pointer-reg-sc-number)
2324 (get-lisp-obj-address value))))
2325 (#.sb!vm:base-char-reg-sc-number
2326 (set-escaped-value (char-code value)))
2327 (#.sb!vm:sap-reg-sc-number
2328 (set-escaped-value (sap-int value)))
2329 (#.sb!vm:signed-reg-sc-number
2330 (set-escaped-value (logand value (1- (ash 1 sb!vm:word-bits)))))
2331 (#.sb!vm:unsigned-reg-sc-number
2332 (set-escaped-value value))
2333 (#.sb!vm:non-descriptor-reg-sc-number
2334 (error "Local non-descriptor register access?"))
2335 (#.sb!vm:interior-reg-sc-number
2336 (error "Local interior register access?"))
2337 (#.sb!vm:single-reg-sc-number
2338 (set-escaped-float-value single-float value))
2339 (#.sb!vm:double-reg-sc-number
2340 (set-escaped-float-value double-float value))
2342 (#.sb!vm:long-reg-sc-number
2343 (set-escaped-float-value long-float value))
2344 (#.sb!vm:complex-single-reg-sc-number
2346 (setf (sb!vm:context-float-register escaped
2347 (sb!c:sc-offset-offset sc-offset)
2350 (setf (sb!vm:context-float-register
2351 escaped (1+ (sb!c:sc-offset-offset sc-offset))
2355 (#.sb!vm:complex-double-reg-sc-number
2357 (setf (sb!vm:context-float-register
2358 escaped (sb!c:sc-offset-offset sc-offset) 'double-float)
2360 (setf (sb!vm:context-float-register
2362 (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 2 #!-sparc 1)
2367 (#.sb!vm:complex-long-reg-sc-number
2369 (setf (sb!vm:context-float-register
2370 escaped (sb!c:sc-offset-offset sc-offset) 'long-float)
2372 (setf (sb!vm:context-float-register
2374 (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4)
2378 (#.sb!vm:single-stack-sc-number
2380 (setf (sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset)
2382 (the single-float value))))
2383 (#.sb!vm:double-stack-sc-number
2385 (setf (sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset)
2387 (the double-float value))))
2389 (#.sb!vm:long-stack-sc-number
2391 (setf (sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset)
2393 (the long-float value))))
2394 (#.sb!vm:complex-single-stack-sc-number
2396 (setf (sap-ref-single
2397 nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:word-bytes))
2398 (the single-float (realpart value)))
2399 (setf (sap-ref-single
2400 nfp (* (1+ (sb!c:sc-offset-offset sc-offset))
2402 (the single-float (realpart value)))))
2403 (#.sb!vm:complex-double-stack-sc-number
2405 (setf (sap-ref-double
2406 nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:word-bytes))
2407 (the double-float (realpart value)))
2408 (setf (sap-ref-double
2409 nfp (* (+ (sb!c:sc-offset-offset sc-offset) 2)
2411 (the double-float (realpart value)))))
2413 (#.sb!vm:complex-long-stack-sc-number
2416 nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:word-bytes))
2417 (the long-float (realpart value)))
2419 nfp (* (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4)
2421 (the long-float (realpart value)))))
2422 (#.sb!vm:control-stack-sc-number
2423 (setf (stack-ref fp (sb!c:sc-offset-offset sc-offset)) value))
2424 (#.sb!vm:base-char-stack-sc-number
2426 (setf (sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
2428 (char-code (the character value)))))
2429 (#.sb!vm:unsigned-stack-sc-number
2431 (setf (sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
2433 (the (unsigned-byte 32) value))))
2434 (#.sb!vm:signed-stack-sc-number
2436 (setf (signed-sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
2438 (the (signed-byte 32) value))))
2439 (#.sb!vm:sap-stack-sc-number
2441 (setf (sap-ref-sap nfp (* (sb!c:sc-offset-offset sc-offset)
2443 (the system-area-pointer value)))))))
2446 (defun sub-set-debug-var-slot (fp sc-offset value &optional escaped)
2447 (macrolet ((set-escaped-value (val)
2449 (setf (sb!vm:context-register
2451 (sb!c:sc-offset-offset sc-offset))
2454 (ecase (sb!c:sc-offset-scn sc-offset)
2455 ((#.sb!vm:any-reg-sc-number #.sb!vm:descriptor-reg-sc-number)
2458 (get-lisp-obj-address value))))
2459 (#.sb!vm:base-char-reg-sc-number
2460 (set-escaped-value (char-code value)))
2461 (#.sb!vm:sap-reg-sc-number
2462 (set-escaped-value (sap-int value)))
2463 (#.sb!vm:signed-reg-sc-number
2464 (set-escaped-value (logand value (1- (ash 1 sb!vm:word-bits)))))
2465 (#.sb!vm:unsigned-reg-sc-number
2466 (set-escaped-value value))
2467 (#.sb!vm:single-reg-sc-number
2468 #+nil ;; don't have escaped floats.
2469 (set-escaped-float-value single-float value))
2470 (#.sb!vm:double-reg-sc-number
2471 #+nil ;; don't have escaped floats -- still in npx?
2472 (set-escaped-float-value double-float value))
2474 (#.sb!vm:long-reg-sc-number
2475 #+nil ;; don't have escaped floats -- still in npx?
2476 (set-escaped-float-value long-float value))
2477 (#.sb!vm:single-stack-sc-number
2478 (setf (sap-ref-single
2479 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2481 (the single-float value)))
2482 (#.sb!vm:double-stack-sc-number
2483 (setf (sap-ref-double
2484 fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
2486 (the double-float value)))
2488 (#.sb!vm:long-stack-sc-number
2490 fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
2492 (the long-float value)))
2493 (#.sb!vm:complex-single-stack-sc-number
2494 (setf (sap-ref-single
2495 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2497 (realpart (the (complex single-float) value)))
2498 (setf (sap-ref-single
2499 fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
2501 (imagpart (the (complex single-float) value))))
2502 (#.sb!vm:complex-double-stack-sc-number
2503 (setf (sap-ref-double
2504 fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
2506 (realpart (the (complex double-float) value)))
2507 (setf (sap-ref-double
2508 fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 4)
2510 (imagpart (the (complex double-float) value))))
2512 (#.sb!vm:complex-long-stack-sc-number
2514 fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
2516 (realpart (the (complex long-float) value)))
2518 fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 6)
2520 (imagpart (the (complex long-float) value))))
2521 (#.sb!vm:control-stack-sc-number
2522 (setf (stack-ref fp (sb!c:sc-offset-offset sc-offset)) value))
2523 (#.sb!vm:base-char-stack-sc-number
2524 (setf (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2526 (char-code (the character value))))
2527 (#.sb!vm:unsigned-stack-sc-number
2528 (setf (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2530 (the (unsigned-byte 32) value)))
2531 (#.sb!vm:signed-stack-sc-number
2532 (setf (signed-sap-ref-32
2533 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) sb!vm:word-bytes)))
2534 (the (signed-byte 32) value)))
2535 (#.sb!vm:sap-stack-sc-number
2536 (setf (sap-ref-sap fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2538 (the system-area-pointer value))))))
2540 ;;; The method for setting and accessing COMPILED-DEBUG-VAR values use
2541 ;;; this to determine if the value stored is the actual value or an
2542 ;;; indirection cell.
2543 (defun indirect-value-cell-p (x)
2544 (and (= (get-lowtag x) sb!vm:other-pointer-type)
2545 (= (get-type x) sb!vm:value-cell-header-type)))
2547 ;;; Return three values reflecting the validity of DEBUG-VAR's value
2548 ;;; at BASIC-CODE-LOCATION:
2549 ;;; :VALID The value is known to be available.
2550 ;;; :INVALID The value is known to be unavailable.
2551 ;;; :UNKNOWN The value's availability is unknown.
2553 ;;; If the variable is always alive, then it is valid. If the
2554 ;;; code-location is unknown, then the variable's validity is
2555 ;;; :unknown. Once we've called CODE-LOCATION-UNKNOWN-P, we know the
2556 ;;; live-set information has been cached in the code-location.
2557 (defun debug-var-validity (debug-var basic-code-location)
2558 (etypecase debug-var
2560 (compiled-debug-var-validity debug-var basic-code-location))
2561 ;; (There used to be more cases back before sbcl-0.7.0, when
2562 ;; we did special tricks to debug the IR1 interpreter.)
2565 ;;; This is the method for DEBUG-VAR-VALIDITY for COMPILED-DEBUG-VARs.
2566 ;;; For safety, make sure basic-code-location is what we think.
2567 (defun compiled-debug-var-validity (debug-var basic-code-location)
2568 (declare (type compiled-code-location basic-code-location))
2569 (cond ((debug-var-alive-p debug-var)
2570 (let ((debug-fun (code-location-debug-fun basic-code-location)))
2571 (if (>= (compiled-code-location-pc basic-code-location)
2572 (sb!c::compiled-debug-fun-start-pc
2573 (compiled-debug-fun-compiler-debug-fun debug-fun)))
2576 ((code-location-unknown-p basic-code-location) :unknown)
2578 (let ((pos (position debug-var
2579 (debug-fun-debug-vars
2580 (code-location-debug-fun
2581 basic-code-location)))))
2583 (error 'unknown-debug-var
2584 :debug-var debug-var
2586 (code-location-debug-fun basic-code-location)))
2587 ;; There must be live-set info since basic-code-location is known.
2588 (if (zerop (sbit (compiled-code-location-live-set
2589 basic-code-location)
2596 ;;; This code produces and uses what we call source-paths. A
2597 ;;; source-path is a list whose first element is a form number as
2598 ;;; returned by CODE-LOCATION-FORM-NUMBER and whose last element is a
2599 ;;; top-level-form number as returned by
2600 ;;; CODE-LOCATION-TOP-LEVEL-FORM-NUMBER. The elements from the last to
2601 ;;; the first, exclusively, are the numbered subforms into which to
2602 ;;; descend. For example:
2604 ;;; (let ((a (aref x 3)))
2606 ;;; The call to AREF in this example is form number 5. Assuming this
2607 ;;; DEFUN is the 11'th top-level-form, the source-path for the AREF
2608 ;;; call is as follows:
2610 ;;; Given the DEFUN, 3 gets you the LET, 1 gets you the bindings, 0
2611 ;;; gets the first binding, and 1 gets the AREF form.
2613 ;;; temporary buffer used to build form-number => source-path translation in
2614 ;;; FORM-NUMBER-TRANSLATIONS
2615 (defvar *form-number-temp* (make-array 10 :fill-pointer 0 :adjustable t))
2617 ;;; table used to detect CAR circularities in FORM-NUMBER-TRANSLATIONS
2618 (defvar *form-number-circularity-table* (make-hash-table :test 'eq))
2620 ;;; This returns a table mapping form numbers to source-paths. A source-path
2621 ;;; indicates a descent into the top-level-form form, going directly to the
2622 ;;; subform corressponding to the form number.
2624 ;;; The vector elements are in the same format as the compiler's
2625 ;;; NODE-SOURCE-PATH; that is, the first element is the form number and
2626 ;;; the last is the top-level-form number.
2627 (defun form-number-translations (form tlf-number)
2628 (clrhash *form-number-circularity-table*)
2629 (setf (fill-pointer *form-number-temp*) 0)
2630 (sub-translate-form-numbers form (list tlf-number))
2631 (coerce *form-number-temp* 'simple-vector))
2632 (defun sub-translate-form-numbers (form path)
2633 (unless (gethash form *form-number-circularity-table*)
2634 (setf (gethash form *form-number-circularity-table*) t)
2635 (vector-push-extend (cons (fill-pointer *form-number-temp*) path)
2640 (declare (fixnum pos))
2643 (when (atom subform) (return))
2644 (let ((fm (car subform)))
2646 (sub-translate-form-numbers fm (cons pos path)))
2648 (setq subform (cdr subform))
2649 (when (eq subform trail) (return)))))
2653 (setq trail (cdr trail)))))))
2655 ;;; FORM is a top-level form, and path is a source-path into it. This
2656 ;;; returns the form indicated by the source-path. Context is the
2657 ;;; number of enclosing forms to return instead of directly returning
2658 ;;; the source-path form. When context is non-zero, the form returned
2659 ;;; contains a marker, #:****HERE****, immediately before the form
2660 ;;; indicated by path.
2661 (defun source-path-context (form path context)
2662 (declare (type unsigned-byte context))
2663 ;; Get to the form indicated by path or the enclosing form indicated
2664 ;; by context and path.
2665 (let ((path (reverse (butlast (cdr path)))))
2666 (dotimes (i (- (length path) context))
2667 (let ((index (first path)))
2668 (unless (and (listp form) (< index (length form)))
2669 (error "Source path no longer exists."))
2670 (setq form (elt form index))
2671 (setq path (rest path))))
2672 ;; Recursively rebuild the source form resulting from the above
2673 ;; descent, copying the beginning of each subform up to the next
2674 ;; subform we descend into according to path. At the bottom of the
2675 ;; recursion, we return the form indicated by path preceded by our
2676 ;; marker, and this gets spliced into the resulting list structure
2677 ;; on the way back up.
2678 (labels ((frob (form path level)
2679 (if (or (zerop level) (null path))
2682 `(#:***here*** ,form))
2683 (let ((n (first path)))
2684 (unless (and (listp form) (< n (length form)))
2685 (error "Source path no longer exists."))
2686 (let ((res (frob (elt form n) (rest path) (1- level))))
2687 (nconc (subseq form 0 n)
2688 (cons res (nthcdr (1+ n) form))))))))
2689 (frob form path context))))
2691 ;;;; PREPROCESS-FOR-EVAL
2693 ;;; Return a function of one argument that evaluates form in the
2694 ;;; lexical context of the BASIC-CODE-LOCATION LOC, or signal a
2695 ;;; NO-DEBUG-VARS condition when the LOC's DEBUG-FUN has no
2696 ;;; DEBUG-VAR information available.
2698 ;;; The returned function takes the frame to get values from as its
2699 ;;; argument, and it returns the values of FORM. The returned function
2700 ;;; can signal the following conditions: INVALID-VALUE,
2701 ;;; AMBIGUOUS-VARIABLE-NAME, and FRAME-FUN-MISMATCH.
2702 (defun preprocess-for-eval (form loc)
2703 (declare (type code-location loc))
2704 (let ((n-frame (gensym))
2705 (fun (code-location-debug-fun loc)))
2706 (unless (debug-var-info-available fun)
2707 (debug-signal 'no-debug-vars :debug-fun fun))
2708 (sb!int:collect ((binds)
2710 (do-debug-fun-variables (var fun)
2711 (let ((validity (debug-var-validity var loc)))
2712 (unless (eq validity :invalid)
2713 (let* ((sym (debug-var-symbol var))
2714 (found (assoc sym (binds))))
2716 (setf (second found) :ambiguous)
2717 (binds (list sym validity var)))))))
2718 (dolist (bind (binds))
2719 (let ((name (first bind))
2721 (ecase (second bind)
2723 (specs `(,name (debug-var-value ',var ,n-frame))))
2725 (specs `(,name (debug-signal 'invalid-value :debug-var ',var
2728 (specs `(,name (debug-signal 'ambiguous-variable-name :name ',name
2729 :frame ,n-frame)))))))
2730 (let ((res (coerce `(lambda (,n-frame)
2731 (declare (ignorable ,n-frame))
2732 (symbol-macrolet ,(specs) ,form))
2735 ;; This prevents these functions from being used in any
2736 ;; location other than a function return location, so
2737 ;; maybe this should only check whether frame's
2738 ;; DEBUG-FUN is the same as loc's.
2739 (unless (code-location= (frame-code-location frame) loc)
2740 (debug-signal 'frame-fun-mismatch
2741 :code-location loc :form form :frame frame))
2742 (funcall res frame))))))
2746 ;;;; user-visible interface
2748 ;;; Create and return a breakpoint. When program execution encounters
2749 ;;; the breakpoint, the system calls HOOK-FUNCTION. HOOK-FUNCTION takes the
2750 ;;; current frame for the function in which the program is running and the
2751 ;;; breakpoint object.
2753 ;;; WHAT and KIND determine where in a function the system invokes
2754 ;;; HOOK-FUNCTION. WHAT is either a code-location or a DEBUG-FUN.
2755 ;;; KIND is one of :CODE-LOCATION, :FUN-START, or :FUN-END.
2756 ;;; Since the starts and ends of functions may not have code-locations
2757 ;;; representing them, designate these places by supplying WHAT as a
2758 ;;; DEBUG-FUN and KIND indicating the :FUN-START or
2759 ;;; :FUN-END. When WHAT is a DEBUG-FUN and kind is
2760 ;;; :FUN-END, then hook-function must take two additional
2761 ;;; arguments, a list of values returned by the function and a
2764 ;;; INFO is information supplied by and used by the user.
2766 ;;; FUN-END-COOKIE is a function. To implement :FUN-END
2767 ;;; breakpoints, the system uses starter breakpoints to establish the
2768 ;;; :FUN-END breakpoint for each invocation of the function. Upon
2769 ;;; each entry, the system creates a unique cookie to identify the
2770 ;;; invocation, and when the user supplies a function for this
2771 ;;; argument, the system invokes it on the frame and the cookie. The
2772 ;;; system later invokes the :FUN-END breakpoint hook on the same
2773 ;;; cookie. The user may save the cookie for comparison in the hook
2776 ;;; Signal an error if WHAT is an unknown code-location.
2777 (defun make-breakpoint (hook-function what
2778 &key (kind :code-location) info fun-end-cookie)
2781 (when (code-location-unknown-p what)
2782 (error "cannot make a breakpoint at an unknown code location: ~S"
2784 (aver (eq kind :code-location))
2785 (let ((bpt (%make-breakpoint hook-function what kind info)))
2787 (compiled-code-location
2788 ;; This slot is filled in due to calling CODE-LOCATION-UNKNOWN-P.
2789 (when (eq (compiled-code-location-kind what) :unknown-return)
2790 (let ((other-bpt (%make-breakpoint hook-function what
2791 :unknown-return-partner
2793 (setf (breakpoint-unknown-return-partner bpt) other-bpt)
2794 (setf (breakpoint-unknown-return-partner other-bpt) bpt))))
2795 ;; (There used to be more cases back before sbcl-0.7.0,,
2796 ;; when we did special tricks to debug the IR1
2803 (%make-breakpoint hook-function what kind info))
2805 (unless (eq (sb!c::compiled-debug-fun-returns
2806 (compiled-debug-fun-compiler-debug-fun what))
2808 (error ":FUN-END breakpoints are currently unsupported ~
2809 for the known return convention."))
2811 (let* ((bpt (%make-breakpoint hook-function what kind info))
2812 (starter (compiled-debug-fun-end-starter what)))
2814 (setf starter (%make-breakpoint #'list what :fun-start nil))
2815 (setf (breakpoint-hook-function starter)
2816 (fun-end-starter-hook starter what))
2817 (setf (compiled-debug-fun-end-starter what) starter))
2818 (setf (breakpoint-start-helper bpt) starter)
2819 (push bpt (breakpoint-%info starter))
2820 (setf (breakpoint-cookie-fun bpt) fun-end-cookie)
2823 ;;; These are unique objects created upon entry into a function by a
2824 ;;; :FUN-END breakpoint's starter hook. These are only created
2825 ;;; when users supply :FUN-END-COOKIE to MAKE-BREAKPOINT. Also,
2826 ;;; the :FUN-END breakpoint's hook is called on the same cookie
2827 ;;; when it is created.
2828 (defstruct (fun-end-cookie
2829 (:print-object (lambda (obj str)
2830 (print-unreadable-object (obj str :type t))))
2831 (:constructor make-fun-end-cookie (bogus-lra debug-fun))
2833 ;; a pointer to the bogus-lra created for :FUN-END breakpoints
2835 ;; the DEBUG-FUN associated with this cookie
2838 ;;; This maps bogus-lra-components to cookies, so that
2839 ;;; HANDLE-FUN-END-BREAKPOINT can find the appropriate cookie for the
2840 ;;; breakpoint hook.
2841 (defvar *fun-end-cookies* (make-hash-table :test 'eq))
2843 ;;; This returns a hook function for the start helper breakpoint
2844 ;;; associated with a :FUN-END breakpoint. The returned function
2845 ;;; makes a fake LRA that all returns go through, and this piece of
2846 ;;; fake code actually breaks. Upon return from the break, the code
2847 ;;; provides the returnee with any values. Since the returned function
2848 ;;; effectively activates FUN-END-BPT on each entry to DEBUG-FUN's
2849 ;;; function, we must establish breakpoint-data about FUN-END-BPT.
2850 (defun fun-end-starter-hook (starter-bpt debug-fun)
2851 (declare (type breakpoint starter-bpt)
2852 (type compiled-debug-fun debug-fun))
2853 #'(lambda (frame breakpoint)
2854 (declare (ignore breakpoint)
2856 (let ((lra-sc-offset
2857 (sb!c::compiled-debug-fun-return-pc
2858 (compiled-debug-fun-compiler-debug-fun debug-fun))))
2859 (multiple-value-bind (lra component offset)
2861 (get-context-value frame
2862 sb!vm::lra-save-offset
2864 (setf (get-context-value frame
2865 sb!vm::lra-save-offset
2868 (let ((end-bpts (breakpoint-%info starter-bpt)))
2869 (let ((data (breakpoint-data component offset)))
2870 (setf (breakpoint-data-breakpoints data) end-bpts)
2871 (dolist (bpt end-bpts)
2872 (setf (breakpoint-internal-data bpt) data)))
2873 (let ((cookie (make-fun-end-cookie lra debug-fun)))
2874 (setf (gethash component *fun-end-cookies*) cookie)
2875 (dolist (bpt end-bpts)
2876 (let ((fun (breakpoint-cookie-fun bpt)))
2877 (when fun (funcall fun frame cookie))))))))))
2879 ;;; This takes a FUN-END-COOKIE and a frame, and it returns
2880 ;;; whether the cookie is still valid. A cookie becomes invalid when
2881 ;;; the frame that established the cookie has exited. Sometimes cookie
2882 ;;; holders are unaware of cookie invalidation because their
2883 ;;; :FUN-END breakpoint hooks didn't run due to THROW'ing.
2885 ;;; This takes a frame as an efficiency hack since the user probably
2886 ;;; has a frame object in hand when using this routine, and it saves
2887 ;;; repeated parsing of the stack and consing when asking whether a
2888 ;;; series of cookies is valid.
2889 (defun fun-end-cookie-valid-p (frame cookie)
2890 (let ((lra (fun-end-cookie-bogus-lra cookie))
2891 (lra-sc-offset (sb!c::compiled-debug-fun-return-pc
2892 (compiled-debug-fun-compiler-debug-fun
2893 (fun-end-cookie-debug-fun cookie)))))
2894 (do ((frame frame (frame-down frame)))
2896 (when (and (compiled-frame-p frame)
2898 (get-context-value frame
2899 sb!vm::lra-save-offset
2903 ;;;; ACTIVATE-BREAKPOINT
2905 ;;; Cause the system to invoke the breakpoint's hook-function until
2906 ;;; the next call to DEACTIVATE-BREAKPOINT or DELETE-BREAKPOINT. The
2907 ;;; system invokes breakpoint hook functions in the opposite order
2908 ;;; that you activate them.
2909 (defun activate-breakpoint (breakpoint)
2910 (when (eq (breakpoint-status breakpoint) :deleted)
2911 (error "cannot activate a deleted breakpoint: ~S" breakpoint))
2912 (unless (eq (breakpoint-status breakpoint) :active)
2913 (ecase (breakpoint-kind breakpoint)
2915 (let ((loc (breakpoint-what breakpoint)))
2917 (compiled-code-location
2918 (activate-compiled-code-location-breakpoint breakpoint)
2919 (let ((other (breakpoint-unknown-return-partner breakpoint)))
2921 (activate-compiled-code-location-breakpoint other))))
2922 ;; (There used to be more cases back before sbcl-0.7.0, when
2923 ;; we did special tricks to debug the IR1 interpreter.)
2926 (etypecase (breakpoint-what breakpoint)
2928 (activate-compiled-fun-start-breakpoint breakpoint))
2929 ;; (There used to be more cases back before sbcl-0.7.0, when
2930 ;; we did special tricks to debug the IR1 interpreter.)
2933 (etypecase (breakpoint-what breakpoint)
2935 (let ((starter (breakpoint-start-helper breakpoint)))
2936 (unless (eq (breakpoint-status starter) :active)
2937 ;; may already be active by some other :FUN-END breakpoint
2938 (activate-compiled-fun-start-breakpoint starter)))
2939 (setf (breakpoint-status breakpoint) :active))
2940 ;; (There used to be more cases back before sbcl-0.7.0, when
2941 ;; we did special tricks to debug the IR1 interpreter.)
2945 (defun activate-compiled-code-location-breakpoint (breakpoint)
2946 (declare (type breakpoint breakpoint))
2947 (let ((loc (breakpoint-what breakpoint)))
2948 (declare (type compiled-code-location loc))
2949 (sub-activate-breakpoint
2951 (breakpoint-data (compiled-debug-fun-component
2952 (code-location-debug-fun loc))
2953 (+ (compiled-code-location-pc loc)
2954 (if (or (eq (breakpoint-kind breakpoint)
2955 :unknown-return-partner)
2956 (eq (compiled-code-location-kind loc)
2957 :single-value-return))
2958 sb!vm:single-value-return-byte-offset
2961 (defun activate-compiled-fun-start-breakpoint (breakpoint)
2962 (declare (type breakpoint breakpoint))
2963 (let ((debug-fun (breakpoint-what breakpoint)))
2964 (sub-activate-breakpoint
2966 (breakpoint-data (compiled-debug-fun-component debug-fun)
2967 (sb!c::compiled-debug-fun-start-pc
2968 (compiled-debug-fun-compiler-debug-fun
2971 (defun sub-activate-breakpoint (breakpoint data)
2972 (declare (type breakpoint breakpoint)
2973 (type breakpoint-data data))
2974 (setf (breakpoint-status breakpoint) :active)
2976 (unless (breakpoint-data-breakpoints data)
2977 (setf (breakpoint-data-instruction data)
2979 (breakpoint-install (get-lisp-obj-address
2980 (breakpoint-data-component data))
2981 (breakpoint-data-offset data)))))
2982 (setf (breakpoint-data-breakpoints data)
2983 (append (breakpoint-data-breakpoints data) (list breakpoint)))
2984 (setf (breakpoint-internal-data breakpoint) data)))
2986 ;;;; DEACTIVATE-BREAKPOINT
2988 ;;; Stop the system from invoking the breakpoint's hook-function.
2989 (defun deactivate-breakpoint (breakpoint)
2990 (when (eq (breakpoint-status breakpoint) :active)
2992 (let ((loc (breakpoint-what breakpoint)))
2994 ((or compiled-code-location compiled-debug-fun)
2995 (deactivate-compiled-breakpoint breakpoint)
2996 (let ((other (breakpoint-unknown-return-partner breakpoint)))
2998 (deactivate-compiled-breakpoint other))))
2999 ;; (There used to be more cases back before sbcl-0.7.0, when
3000 ;; we did special tricks to debug the IR1 interpreter.)
3004 (defun deactivate-compiled-breakpoint (breakpoint)
3005 (if (eq (breakpoint-kind breakpoint) :fun-end)
3006 (let ((starter (breakpoint-start-helper breakpoint)))
3007 (unless (find-if #'(lambda (bpt)
3008 (and (not (eq bpt breakpoint))
3009 (eq (breakpoint-status bpt) :active)))
3010 (breakpoint-%info starter))
3011 (deactivate-compiled-breakpoint starter)))
3012 (let* ((data (breakpoint-internal-data breakpoint))
3013 (bpts (delete breakpoint (breakpoint-data-breakpoints data))))
3014 (setf (breakpoint-internal-data breakpoint) nil)
3015 (setf (breakpoint-data-breakpoints data) bpts)
3018 (breakpoint-remove (get-lisp-obj-address
3019 (breakpoint-data-component data))
3020 (breakpoint-data-offset data)
3021 (breakpoint-data-instruction data)))
3022 (delete-breakpoint-data data))))
3023 (setf (breakpoint-status breakpoint) :inactive)
3026 ;;;; BREAKPOINT-INFO
3028 ;;; Return the user-maintained info associated with breakpoint. This
3030 (defun breakpoint-info (breakpoint)
3031 (breakpoint-%info breakpoint))
3032 (defun %set-breakpoint-info (breakpoint value)
3033 (setf (breakpoint-%info breakpoint) value)
3034 (let ((other (breakpoint-unknown-return-partner breakpoint)))
3036 (setf (breakpoint-%info other) value))))
3038 ;;;; BREAKPOINT-ACTIVE-P and DELETE-BREAKPOINT
3040 (defun breakpoint-active-p (breakpoint)
3041 (ecase (breakpoint-status breakpoint)
3043 ((:inactive :deleted) nil)))
3045 ;;; Free system storage and remove computational overhead associated
3046 ;;; with breakpoint. After calling this, breakpoint is completely
3047 ;;; impotent and can never become active again.
3048 (defun delete-breakpoint (breakpoint)
3049 (let ((status (breakpoint-status breakpoint)))
3050 (unless (eq status :deleted)
3051 (when (eq status :active)
3052 (deactivate-breakpoint breakpoint))
3053 (setf (breakpoint-status breakpoint) :deleted)
3054 (let ((other (breakpoint-unknown-return-partner breakpoint)))
3056 (setf (breakpoint-status other) :deleted)))
3057 (when (eq (breakpoint-kind breakpoint) :fun-end)
3058 (let* ((starter (breakpoint-start-helper breakpoint))
3059 (breakpoints (delete breakpoint
3060 (the list (breakpoint-info starter)))))
3061 (setf (breakpoint-info starter) breakpoints)
3063 (delete-breakpoint starter)
3064 (setf (compiled-debug-fun-end-starter
3065 (breakpoint-what breakpoint))
3069 ;;;; C call out stubs
3071 ;;; This actually installs the break instruction in the component. It
3072 ;;; returns the overwritten bits. You must call this in a context in
3073 ;;; which GC is disabled, so that Lisp doesn't move objects around
3074 ;;; that C is pointing to.
3075 (sb!alien:def-alien-routine "breakpoint_install" sb!c-call:unsigned-long
3076 (code-obj sb!c-call:unsigned-long)
3077 (pc-offset sb!c-call:int))
3079 ;;; This removes the break instruction and replaces the original
3080 ;;; instruction. You must call this in a context in which GC is disabled
3081 ;;; so Lisp doesn't move objects around that C is pointing to.
3082 (sb!alien:def-alien-routine "breakpoint_remove" sb!c-call:void
3083 (code-obj sb!c-call:unsigned-long)
3084 (pc-offset sb!c-call:int)
3085 (old-inst sb!c-call:unsigned-long))
3087 (sb!alien:def-alien-routine "breakpoint_do_displaced_inst" sb!c-call:void
3088 (scp (* os-context-t))
3089 (orig-inst sb!c-call:unsigned-long))
3091 ;;;; breakpoint handlers (layer between C and exported interface)
3093 ;;; This maps components to a mapping of offsets to breakpoint-datas.
3094 (defvar *component-breakpoint-offsets* (make-hash-table :test 'eq))
3096 ;;; This returns the breakpoint-data associated with component cross
3097 ;;; offset. If none exists, this makes one, installs it, and returns it.
3098 (defun breakpoint-data (component offset &optional (create t))
3099 (flet ((install-breakpoint-data ()
3101 (let ((data (make-breakpoint-data component offset)))
3102 (push (cons offset data)
3103 (gethash component *component-breakpoint-offsets*))
3105 (let ((offsets (gethash component *component-breakpoint-offsets*)))
3107 (let ((data (assoc offset offsets)))
3110 (install-breakpoint-data)))
3111 (install-breakpoint-data)))))
3113 ;;; We use this when there are no longer any active breakpoints
3114 ;;; corresponding to data.
3115 (defun delete-breakpoint-data (data)
3116 (let* ((component (breakpoint-data-component data))
3117 (offsets (delete (breakpoint-data-offset data)
3118 (gethash component *component-breakpoint-offsets*)
3121 (setf (gethash component *component-breakpoint-offsets*) offsets)
3122 (remhash component *component-breakpoint-offsets*)))
3125 ;;; The C handler for interrupts calls this when it has a
3126 ;;; debugging-tool break instruction. This does NOT handle all breaks;
3127 ;;; for example, it does not handle breaks for internal errors.
3128 (defun handle-breakpoint (offset component signal-context)
3129 (/show0 "entering HANDLE-BREAKPOINT")
3130 (let ((data (breakpoint-data component offset nil)))
3132 (error "unknown breakpoint in ~S at offset ~S"
3133 (debug-fun-name (debug-fun-from-pc component offset))
3135 (let ((breakpoints (breakpoint-data-breakpoints data)))
3136 (if (or (null breakpoints)
3137 (eq (breakpoint-kind (car breakpoints)) :fun-end))
3138 (handle-fun-end-breakpoint-aux breakpoints data signal-context)
3139 (handle-breakpoint-aux breakpoints data
3140 offset component signal-context)))))
3142 ;;; This holds breakpoint-datas while invoking the breakpoint hooks
3143 ;;; associated with that particular component and location. While they
3144 ;;; are executing, if we hit the location again, we ignore the
3145 ;;; breakpoint to avoid infinite recursion. fun-end breakpoints
3146 ;;; must work differently since the breakpoint-data is unique for each
3148 (defvar *executing-breakpoint-hooks* nil)
3150 ;;; This handles code-location and DEBUG-FUN :FUN-START
3152 (defun handle-breakpoint-aux (breakpoints data offset component signal-context)
3153 (/show0 "entering HANDLE-BREAKPOINT-AUX")
3155 (error "internal error: breakpoint that nobody wants"))
3156 (unless (member data *executing-breakpoint-hooks*)
3157 (let ((*executing-breakpoint-hooks* (cons data
3158 *executing-breakpoint-hooks*)))
3159 (invoke-breakpoint-hooks breakpoints component offset)))
3160 ;; At this point breakpoints may not hold the same list as
3161 ;; BREAKPOINT-DATA-BREAKPOINTS since invoking hooks may have allowed
3162 ;; a breakpoint deactivation. In fact, if all breakpoints were
3163 ;; deactivated then data is invalid since it was deleted and so the
3164 ;; correct one must be looked up if it is to be used. If there are
3165 ;; no more breakpoints active at this location, then the normal
3166 ;; instruction has been put back, and we do not need to
3167 ;; DO-DISPLACED-INST.
3168 (let ((data (breakpoint-data component offset nil)))
3169 (when (and data (breakpoint-data-breakpoints data))
3170 ;; The breakpoint is still active, so we need to execute the
3171 ;; displaced instruction and leave the breakpoint instruction
3172 ;; behind. The best way to do this is different on each machine,
3173 ;; so we just leave it up to the C code.
3174 (breakpoint-do-displaced-inst signal-context
3175 (breakpoint-data-instruction data))
3176 ;; Some platforms have no usable sigreturn() call. If your
3177 ;; implementation of arch_do_displaced_inst() doesn't sigreturn(),
3178 ;; add it to this list.
3179 #!-(or hpux irix x86 alpha)
3180 (error "BREAKPOINT-DO-DISPLACED-INST returned?"))))
3182 (defun invoke-breakpoint-hooks (breakpoints component offset)
3183 (let* ((debug-fun (debug-fun-from-pc component offset))
3184 (frame (do ((f (top-frame) (frame-down f)))
3185 ((eq debug-fun (frame-debug-fun f)) f))))
3186 (dolist (bpt breakpoints)
3187 (funcall (breakpoint-hook-function bpt)
3189 ;; If this is an :UNKNOWN-RETURN-PARTNER, then pass the
3190 ;; hook function the original breakpoint, so that users
3191 ;; aren't forced to confront the fact that some
3192 ;; breakpoints really are two.
3193 (if (eq (breakpoint-kind bpt) :unknown-return-partner)
3194 (breakpoint-unknown-return-partner bpt)
3197 (defun handle-fun-end-breakpoint (offset component context)
3198 (/show0 "entering HANDLE-FUN-END-BREAKPOINT")
3199 (let ((data (breakpoint-data component offset nil)))
3201 (error "unknown breakpoint in ~S at offset ~S"
3202 (debug-fun-name (debug-fun-from-pc component offset))
3204 (let ((breakpoints (breakpoint-data-breakpoints data)))
3206 (aver (eq (breakpoint-kind (car breakpoints)) :fun-end))
3207 (handle-fun-end-breakpoint-aux breakpoints data context)))))
3209 ;;; Either HANDLE-BREAKPOINT calls this for :FUN-END breakpoints
3210 ;;; [old C code] or HANDLE-FUN-END-BREAKPOINT calls this directly
3212 (defun handle-fun-end-breakpoint-aux (breakpoints data signal-context)
3213 (/show0 "entering HANDLE-FUN-END-BREAKPOINT-AUX")
3214 (delete-breakpoint-data data)
3217 (declare (optimize (inhibit-warnings 3)))
3218 (sb!alien:sap-alien signal-context (* os-context-t))))
3219 (frame (do ((cfp (sb!vm:context-register scp sb!vm::cfp-offset))
3220 (f (top-frame) (frame-down f)))
3221 ((= cfp (sap-int (frame-pointer f))) f)
3222 (declare (type (unsigned-byte #.sb!vm:word-bits) cfp))))
3223 (component (breakpoint-data-component data))
3224 (cookie (gethash component *fun-end-cookies*)))
3225 (remhash component *fun-end-cookies*)
3226 (dolist (bpt breakpoints)
3227 (funcall (breakpoint-hook-function bpt)
3229 (get-fun-end-breakpoint-values scp)
3232 (defun get-fun-end-breakpoint-values (scp)
3233 (let ((ocfp (int-sap (sb!vm:context-register
3235 #!-x86 sb!vm::ocfp-offset
3236 #!+x86 sb!vm::ebx-offset)))
3237 (nargs (make-lisp-obj
3238 (sb!vm:context-register scp sb!vm::nargs-offset)))
3239 (reg-arg-offsets '#.sb!vm::*register-arg-offsets*)
3242 (dotimes (arg-num nargs)
3243 (push (if reg-arg-offsets
3245 (sb!vm:context-register scp (pop reg-arg-offsets)))
3246 (stack-ref ocfp arg-num))
3248 (nreverse results)))
3250 ;;;; MAKE-BOGUS-LRA (used for :FUN-END breakpoints)
3252 (defconstant bogus-lra-constants
3254 (defconstant known-return-p-slot
3255 (+ sb!vm:code-constants-offset #!-x86 1 #!+x86 2))
3257 ;;; Make a bogus LRA object that signals a breakpoint trap when
3258 ;;; returned to. If the breakpoint trap handler returns, REAL-LRA is
3259 ;;; returned to. Three values are returned: the bogus LRA object, the
3260 ;;; code component it is part of, and the PC offset for the trap
3262 (defun make-bogus-lra (real-lra &optional known-return-p)
3264 (let* ((src-start (foreign-symbol-address "fun_end_breakpoint_guts"))
3265 (src-end (foreign-symbol-address "fun_end_breakpoint_end"))
3266 (trap-loc (foreign-symbol-address "fun_end_breakpoint_trap"))
3267 (length (sap- src-end src-start))
3270 #!-(and x86 gencgc) sb!c:allocate-code-object
3271 #!+(and x86 gencgc) sb!c::allocate-dynamic-code-object
3272 (1+ bogus-lra-constants)
3274 (dst-start (code-instructions code-object)))
3275 (declare (type system-area-pointer
3276 src-start src-end dst-start trap-loc)
3277 (type index length))
3278 (setf (%code-debug-info code-object) :bogus-lra)
3279 (setf (code-header-ref code-object sb!vm:code-trace-table-offset-slot)
3282 (setf (code-header-ref code-object real-lra-slot) real-lra)
3284 (multiple-value-bind (offset code) (compute-lra-data-from-pc real-lra)
3285 (setf (code-header-ref code-object real-lra-slot) code)
3286 (setf (code-header-ref code-object (1+ real-lra-slot)) offset))
3287 (setf (code-header-ref code-object known-return-p-slot)
3289 (system-area-copy src-start 0 dst-start 0 (* length sb!vm:byte-bits))
3290 (sb!vm:sanctify-for-execution code-object)
3292 (values dst-start code-object (sap- trap-loc src-start))
3294 (let ((new-lra (make-lisp-obj (+ (sap-int dst-start)
3295 sb!vm:other-pointer-type))))
3298 (logandc2 (+ sb!vm:code-constants-offset bogus-lra-constants 1)
3300 (sb!vm:sanctify-for-execution code-object)
3301 (values new-lra code-object (sap- trap-loc src-start))))))
3305 ;;; This appears here because it cannot go with the DEBUG-FUN
3306 ;;; interface since DO-DEBUG-BLOCK-LOCATIONS isn't defined until after
3307 ;;; the DEBUG-FUN routines.
3309 ;;; Return a code-location before the body of a function and after all
3310 ;;; the arguments are in place; or if that location can't be
3311 ;;; determined due to a lack of debug information, return NIL.
3312 (defun debug-fun-start-location (debug-fun)
3313 (etypecase debug-fun
3315 (code-location-from-pc debug-fun
3316 (sb!c::compiled-debug-fun-start-pc
3317 (compiled-debug-fun-compiler-debug-fun
3320 ;; (There used to be more cases back before sbcl-0.7.0, when
3321 ;; we did special tricks to debug the IR1 interpreter.)
3324 (defun print-code-locations (function)
3325 (let ((debug-fun (fun-debug-fun function)))
3326 (do-debug-fun-blocks (block debug-fun)
3327 (do-debug-block-locations (loc block)
3328 (fill-in-code-location loc)
3329 (format t "~S code location at ~D"
3330 (compiled-code-location-kind loc)
3331 (compiled-code-location-pc loc))
3332 (sb!debug::print-code-location-source-form loc 0)