0.8.15.7
[sbcl.git] / src / code / debug-int.lisp
1 ;;;; the implementation of the programmer's interface to writing
2 ;;;; debugging tools
3
4 ;;;; This software is part of the SBCL system. See the README file for
5 ;;;; more information.
6 ;;;;
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.
12
13 (in-package "SB!DI")
14
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?
17 \f
18 ;;;; conditions
19
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.
34 ;;;;
35 ;;;; Use DEBUG-SIGNAL to signal these conditions.
36
37 (define-condition debug-condition (serious-condition)
38   ()
39   #!+sb-doc
40   (:documentation
41    "All DEBUG-CONDITIONs inherit from this type. These are serious conditions
42     that must be handled, but they are not programmer errors."))
43
44 (define-condition no-debug-info (debug-condition)
45   ((code-component :reader no-debug-info-code-component
46                    :initarg :code-component))
47   #!+sb-doc
48   (:documentation "There is no usable debugging information available.")
49   (:report (lambda (condition stream)
50              (fresh-line stream)
51              (format stream
52                      "no debug information available for ~S~%"
53                      (no-debug-info-code-component condition)))))
54
55 (define-condition no-debug-fun-returns (debug-condition)
56   ((debug-fun :reader no-debug-fun-returns-debug-fun
57               :initarg :debug-fun))
58   #!+sb-doc
59   (:documentation
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))))
65                (format stream
66                        "~&Cannot return values from ~:[frame~;~:*~S~] since ~
67                         the debug information lacks details about returning ~
68                         values here."
69                        fun)))))
70
71 (define-condition no-debug-blocks (debug-condition)
72   ((debug-fun :reader no-debug-blocks-debug-fun
73               :initarg :debug-fun))
74   #!+sb-doc
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)))))
79
80 (define-condition no-debug-vars (debug-condition)
81   ((debug-fun :reader no-debug-vars-debug-fun
82               :initarg :debug-fun))
83   #!+sb-doc
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)))))
88
89 (define-condition lambda-list-unavailable (debug-condition)
90   ((debug-fun :reader lambda-list-unavailable-debug-fun
91               :initarg :debug-fun))
92   #!+sb-doc
93   (:documentation
94    "The DEBUG-FUN has no lambda list since argument DEBUG-VARs are
95     unavailable.")
96   (:report (lambda (condition stream)
97              (format stream "~&~S has no lambda-list information available."
98                      (lambda-list-unavailable-debug-fun condition)))))
99
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)))))
107
108 (define-condition ambiguous-var-name (debug-condition)
109   ((name :reader ambiguous-var-name-name :initarg :name)
110    (frame :reader ambiguous-var-name-frame :initarg :frame))
111   (:report (lambda (condition stream)
112              (format stream "~&~S names more than one valid variable in ~S."
113                      (ambiguous-var-name-name condition)
114                      (ambiguous-var-name-frame condition)))))
115 \f
116 ;;;; errors and DEBUG-SIGNAL
117
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
121 ;;; come up.
122 ;;;
123 ;;; While under development, this code also signals errors in code
124 ;;; branches that remain unimplemented.
125
126 (define-condition debug-error (error) ()
127   #!+sb-doc
128   (:documentation
129    "All programmer errors from using the interface for building debugging
130     tools inherit from this type."))
131
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)))))
137
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)))))
144
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)))))
153
154 (define-condition invalid-control-stack-pointer (debug-error)
155   ()
156   (:report (lambda (condition stream)
157              (declare (ignore condition))
158              (fresh-line stream)
159              (write-string "invalid control stack pointer" stream))))
160
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)
167              (format
168               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)))))
173
174 ;;; This signals debug-conditions. If they go unhandled, then signal
175 ;;; an UNHANDLED-DEBUG-CONDITION error.
176 ;;;
177 ;;; ??? Get SIGNAL in the right package!
178 (defmacro debug-signal (datum &rest arguments)
179   `(let ((condition (make-condition ,datum ,@arguments)))
180      (signal condition)
181      (error 'unhandled-debug-condition :condition condition)))
182 \f
183 ;;;; structures
184 ;;;;
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.
190
191 ;;;; DEBUG-VARs
192
193 ;;; These exist for caching data stored in packed binary form in
194 ;;; compiler DEBUG-FUNs.
195 (defstruct (debug-var (:constructor nil)
196                       (:copier nil))
197   ;; the name of the variable
198   (symbol (missing-arg) :type symbol)
199   ;; a unique integer identification relative to other variables with the same
200   ;; symbol
201   (id 0 :type 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)
206     (format stream
207             "~S ~W"
208             (debug-var-symbol debug-var)
209             (debug-var-id debug-var))))
210
211 #!+sb-doc
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.")
215
216 (defstruct (compiled-debug-var
217             (:include debug-var)
218             (:constructor make-compiled-debug-var
219                           (symbol id alive-p sc-offset save-sc-offset))
220             (:copier nil))
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)))
225
226 ;;;; frames
227
228 ;;; These represent call frames on the stack.
229 (defstruct (frame (:constructor nil)
230                   (:copier 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
243   ;; CODE-LOCATION.
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)
248   pointer
249   ;; This is the frame's number for prompt printing. Top is zero.
250   (number 0 :type index))
251
252 (defstruct (compiled-frame
253             (:include frame)
254             (:constructor make-compiled-frame
255                           (pointer up debug-fun code-location number
256                                    &optional escaped))
257             (:copier nil))
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.
262   escaped)
263 (def!method print-object ((obj compiled-frame) str)
264   (print-unreadable-object (obj str :type t)
265     (format str
266             "~S~:[~;, interrupted~]"
267             (debug-fun-name (frame-debug-fun obj))
268             (compiled-frame-escaped obj))))
269 \f
270 ;;;; DEBUG-FUNs
271
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)
279                       (:copier 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)))
295
296 (defstruct (compiled-debug-fun
297             (:include debug-fun)
298             (:constructor %make-compiled-debug-fun
299                           (compiler-debug-fun component))
300             (:copier nil))
301   ;; compiler's dumped DEBUG-FUN information (unexported)
302   (compiler-debug-fun nil :type sb!c::compiled-debug-fun)
303   ;; code object (unexported).
304   component
305   ;; the :FUN-START breakpoint (if any) used to facilitate
306   ;; function end breakpoints
307   (end-starter nil :type (or null breakpoint)))
308
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))
313
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))))
323
324 (defstruct (bogus-debug-fun
325             (:include debug-fun)
326             (:constructor make-bogus-debug-fun
327                           (%name &aux
328                                  (%lambda-list nil)
329                                  (%debug-vars nil)
330                                  (blocks nil)
331                                  (%function nil)))
332             (:copier nil))
333   %name)
334
335 (defvar *ir1-lambda-debug-fun* (make-hash-table :test 'eq))
336 \f
337 ;;;; DEBUG-BLOCKs
338
339 ;;; These exist for caching data stored in packed binary form in compiler
340 ;;; DEBUG-BLOCKs.
341 (defstruct (debug-block (:constructor nil)
342                         (:copier nil))
343   ;; Code-locations where execution continues after this block.
344   (successors nil :type list)
345   ;; This indicates whether the block is a special glob of code shared
346   ;; by various functions and tucked away elsewhere in a component.
347   ;; This kind of block has no start code-location. This slot is in
348   ;; all debug-blocks since it is an exported interface.
349   (elsewhere-p nil :type boolean))
350 (def!method print-object ((obj debug-block) str)
351   (print-unreadable-object (obj str :type t)
352     (prin1 (debug-block-fun-name obj) str)))
353
354 #!+sb-doc
355 (setf (fdocumentation 'debug-block-successors 'function)
356   "Return the list of possible code-locations where execution may continue
357    when the basic-block represented by debug-block completes its execution.")
358
359 #!+sb-doc
360 (setf (fdocumentation 'debug-block-elsewhere-p 'function)
361   "Return whether debug-block represents elsewhere code.")
362
363 (defstruct (compiled-debug-block (:include debug-block)
364                                  (:constructor
365                                   make-compiled-debug-block
366                                   (code-locations successors elsewhere-p))
367                                  (:copier nil))
368   ;; code-location information for the block
369   (code-locations nil :type simple-vector))
370
371 (defvar *ir1-block-debug-block* (make-hash-table :test 'eq))
372 \f
373 ;;;; breakpoints
374
375 ;;; This is an internal structure that manages information about a
376 ;;; breakpoint locations. See *COMPONENT-BREAKPOINT-OFFSETS*.
377 (defstruct (breakpoint-data (:constructor make-breakpoint-data
378                                           (component offset))
379                             (:copier nil))
380   ;; This is the component in which the breakpoint lies.
381   component
382   ;; This is the byte offset into the component.
383   (offset nil :type index)
384   ;; The original instruction replaced by the breakpoint.
385   (instruction nil :type (or null (unsigned-byte 32)))
386   ;; A list of user breakpoints at this location.
387   (breakpoints nil :type list))
388 (def!method print-object ((obj breakpoint-data) str)
389   (print-unreadable-object (obj str :type t)
390     (format str "~S at ~S"
391             (debug-fun-name
392              (debug-fun-from-pc (breakpoint-data-component obj)
393                                 (breakpoint-data-offset obj)))
394             (breakpoint-data-offset obj))))
395
396 (defstruct (breakpoint (:constructor %make-breakpoint
397                                      (hook-fun what kind %info))
398                        (:copier nil))
399   ;; This is the function invoked when execution encounters the
400   ;; breakpoint. It takes a frame, the breakpoint, and optionally a
401   ;; list of values. Values are supplied for :FUN-END breakpoints as
402   ;; values to return for the function containing the breakpoint.
403   ;; :FUN-END breakpoint hook functions also take a cookie argument.
404   ;; See the COOKIE-FUN slot.
405   (hook-fun (required-arg) :type function)
406   ;; CODE-LOCATION or DEBUG-FUN
407   (what nil :type (or code-location debug-fun))
408   ;; :CODE-LOCATION, :FUN-START, or :FUN-END for that kind
409   ;; of breakpoint. :UNKNOWN-RETURN-PARTNER if this is the partner of
410   ;; a :code-location breakpoint at an :UNKNOWN-RETURN code-location.
411   (kind nil :type (member :code-location :fun-start :fun-end
412                           :unknown-return-partner))
413   ;; Status helps the user and the implementation.
414   (status :inactive :type (member :active :inactive :deleted))
415   ;; This is a backpointer to a breakpoint-data.
416   (internal-data nil :type (or null breakpoint-data))
417   ;; With code-locations whose type is :UNKNOWN-RETURN, there are
418   ;; really two breakpoints: one at the multiple-value entry point,
419   ;; and one at the single-value entry point. This slot holds the
420   ;; breakpoint for the other one, or NIL if this isn't at an
421   ;; :UNKNOWN-RETURN code location.
422   (unknown-return-partner nil :type (or null breakpoint))
423   ;; :FUN-END breakpoints use a breakpoint at the :FUN-START
424   ;; to establish the end breakpoint upon function entry. We do this
425   ;; by frobbing the LRA to jump to a special piece of code that
426   ;; breaks and provides the return values for the returnee. This slot
427   ;; points to the start breakpoint, so we can activate, deactivate,
428   ;; and delete it.
429   (start-helper nil :type (or null breakpoint))
430   ;; This is a hook users supply to get a dynamically unique cookie
431   ;; for identifying :FUN-END breakpoint executions. That is, if
432   ;; there is one :FUN-END breakpoint, but there may be multiple
433   ;; pending calls of its function on the stack. This function takes
434   ;; the cookie, and the hook function takes the cookie too.
435   (cookie-fun nil :type (or null function))
436   ;; This slot users can set with whatever information they find useful.
437   %info)
438 (def!method print-object ((obj breakpoint) str)
439   (let ((what (breakpoint-what obj)))
440     (print-unreadable-object (obj str :type t)
441       (format str
442               "~S~:[~;~:*~S~]"
443               (etypecase what
444                 (code-location what)
445                 (debug-fun (debug-fun-name what)))
446               (etypecase what
447                 (code-location nil)
448                 (debug-fun (breakpoint-kind obj)))))))
449 \f
450 ;;;; CODE-LOCATIONs
451
452 (defstruct (code-location (:constructor nil)
453                           (:copier nil))
454   ;; the DEBUG-FUN containing this CODE-LOCATION
455   (debug-fun nil :type debug-fun)
456   ;; This is initially :UNSURE. Upon first trying to access an
457   ;; :UNPARSED slot, if the data is unavailable, then this becomes T,
458   ;; and the code-location is unknown. If the data is available, this
459   ;; becomes NIL, a known location. We can't use a separate type
460   ;; code-location for this since we must return code-locations before
461   ;; we can tell whether they're known or unknown. For example, when
462   ;; parsing the stack, we don't want to unpack all the variables and
463   ;; blocks just to make frames.
464   (%unknown-p :unsure :type (member t nil :unsure))
465   ;; the DEBUG-BLOCK containing CODE-LOCATION. XXX Possibly toss this
466   ;; out and just find it in the blocks cache in DEBUG-FUN.
467   (%debug-block :unparsed :type (or debug-block (member :unparsed)))
468   ;; This is the number of forms processed by the compiler or loader
469   ;; before the top level form containing this code-location.
470   (%tlf-offset :unparsed :type (or index (member :unparsed)))
471   ;; This is the depth-first number of the node that begins
472   ;; code-location within its top level form.
473   (%form-number :unparsed :type (or index (member :unparsed))))
474 (def!method print-object ((obj code-location) str)
475   (print-unreadable-object (obj str :type t)
476     (prin1 (debug-fun-name (code-location-debug-fun obj))
477            str)))
478
479 (defstruct (compiled-code-location
480             (:include code-location)
481             (:constructor make-known-code-location
482                           (pc debug-fun %tlf-offset %form-number
483                               %live-set kind &aux (%unknown-p nil)))
484             (:constructor make-compiled-code-location (pc debug-fun))
485             (:copier nil))
486   ;; an index into DEBUG-FUN's component slot
487   (pc nil :type index)
488   ;; a bit-vector indexed by a variable's position in
489   ;; DEBUG-FUN-DEBUG-VARS indicating whether the variable has a
490   ;; valid value at this code-location. (unexported).
491   (%live-set :unparsed :type (or simple-bit-vector (member :unparsed)))
492   ;; (unexported) To see SB!C::LOCATION-KIND, do
493   ;; (SB!KERNEL:TYPE-EXPAND 'SB!C::LOCATION-KIND).
494   (kind :unparsed :type (or (member :unparsed) sb!c::location-kind)))
495 \f
496 ;;;; DEBUG-SOURCEs
497
498 ;;; Return the number of top level forms processed by the compiler
499 ;;; before compiling this source. If this source is uncompiled, this
500 ;;; is zero. This may be zero even if the source is compiled since the
501 ;;; first form in the first file compiled in one compilation, for
502 ;;; example, must have a root number of zero -- the compiler saw no
503 ;;; other top level forms before it.
504 (defun debug-source-root-number (debug-source)
505   (sb!c::debug-source-source-root debug-source))
506 \f
507 ;;;; frames
508
509 ;;; This is used in FIND-ESCAPED-FRAME and with the bogus components
510 ;;; and LRAs used for :FUN-END breakpoints. When a component's
511 ;;; debug-info slot is :BOGUS-LRA, then the REAL-LRA-SLOT contains the
512 ;;; real component to continue executing, as opposed to the bogus
513 ;;; component which appeared in some frame's LRA location.
514 (defconstant real-lra-slot sb!vm:code-constants-offset)
515
516 ;;; These are magically converted by the compiler.
517 (defun current-sp () (current-sp))
518 (defun current-fp () (current-fp))
519 (defun stack-ref (s n) (stack-ref s n))
520 (defun %set-stack-ref (s n value) (%set-stack-ref s n value))
521 (defun fun-code-header (fun) (fun-code-header fun))
522 (defun lra-code-header (lra) (lra-code-header lra))
523 (defun make-lisp-obj (value) (make-lisp-obj value))
524 (defun get-lisp-obj-address (thing) (get-lisp-obj-address thing))
525 (defun fun-word-offset (fun) (fun-word-offset fun))
526
527 #!-sb-fluid (declaim (inline control-stack-pointer-valid-p))
528 (defun control-stack-pointer-valid-p (x)
529   (declare (type system-area-pointer x))
530   (let* (#!-stack-grows-downward-not-upward
531          (control-stack-start
532           (descriptor-sap *control-stack-start*))
533          #!+stack-grows-downward-not-upward
534          (control-stack-end
535           (descriptor-sap *control-stack-end*)))
536     #!-stack-grows-downward-not-upward
537     (and (sap< x (current-sp))
538          (sap<= control-stack-start x)
539          (zerop (logand (sap-int x) #b11)))
540     #!+stack-grows-downward-not-upward
541     (and (sap>= x (current-sp))
542          (sap> control-stack-end x)
543          (zerop (logand (sap-int x) #b11)))))
544
545 (sb!alien:define-alien-routine component-ptr-from-pc (system-area-pointer)
546   (pc system-area-pointer))
547
548 (defun component-from-component-ptr (component-ptr)
549   (declare (type system-area-pointer component-ptr))
550   (make-lisp-obj (logior (sap-int component-ptr)
551                          sb!vm:other-pointer-lowtag)))
552
553 ;;;; X86 support
554
555 #!+x86
556 (progn
557
558 (defun compute-lra-data-from-pc (pc)
559   (declare (type system-area-pointer pc))
560   (let ((component-ptr (component-ptr-from-pc pc)))
561     (unless (sap= component-ptr (int-sap #x0))
562        (let* ((code (component-from-component-ptr component-ptr))
563               (code-header-len (* (get-header-data code) sb!vm:n-word-bytes))
564               (pc-offset (- (sap-int pc)
565                             (- (get-lisp-obj-address code)
566                                sb!vm:other-pointer-lowtag)
567                             code-header-len)))
568 ;        (format t "c-lra-fpc ~A ~A ~A~%" pc code pc-offset)
569          (values pc-offset code)))))
570
571 (defconstant sb!vm::nargs-offset #.sb!vm::ecx-offset)
572
573 ;;; Check for a valid return address - it could be any valid C/Lisp
574 ;;; address.
575 ;;;
576 ;;; XXX Could be a little smarter.
577 #!-sb-fluid (declaim (inline ra-pointer-valid-p))
578 (defun ra-pointer-valid-p (ra)
579   (declare (type system-area-pointer ra))
580   (and
581    ;; not the first page (which is unmapped)
582    ;;
583    ;; FIXME: Where is this documented? Is it really true of every CPU
584    ;; architecture? Is it even necessarily true in current SBCL?
585    (>= (sap-int ra) 4096)
586    ;; not a Lisp stack pointer
587    (not (control-stack-pointer-valid-p ra))))
588
589 ;;; Try to find a valid previous stack. This is complex on the x86 as
590 ;;; it can jump between C and Lisp frames. To help find a valid frame
591 ;;; it searches backwards.
592 ;;;
593 ;;; XXX Should probably check whether it has reached the bottom of the
594 ;;; stack.
595 ;;;
596 ;;; XXX Should handle interrupted frames, both Lisp and C. At present
597 ;;; it manages to find a fp trail, see linux hack below.
598 (defun x86-call-context (fp &key (depth 0))
599   (declare (type system-area-pointer fp)
600            (fixnum depth))
601   ;;(format t "*CC ~S ~S~%" fp depth)
602   (cond
603    ((not (control-stack-pointer-valid-p fp))
604     #+nil (format t "debug invalid fp ~S~%" fp)
605     nil)
606    (t
607     ;; Check the two possible frame pointers.
608     (let ((lisp-ocfp (sap-ref-sap fp (- (* (1+ ocfp-save-offset) 4))))
609           (lisp-ra (sap-ref-sap fp (- (* (1+ return-pc-save-offset)
610                                          4))))
611           (c-ocfp (sap-ref-sap fp (* 0 sb!vm:n-word-bytes)))
612           (c-ra (sap-ref-sap fp (* 1 sb!vm:n-word-bytes))))
613       (cond ((and (sap> lisp-ocfp fp) (control-stack-pointer-valid-p lisp-ocfp)
614                   (ra-pointer-valid-p lisp-ra)
615                   (sap> c-ocfp fp) (control-stack-pointer-valid-p c-ocfp)
616                   (ra-pointer-valid-p c-ra))
617              #+nil (format t
618                            "*C Both valid ~S ~S ~S ~S~%"
619                            lisp-ocfp lisp-ra c-ocfp c-ra)
620              ;; Look forward another step to check their validity.
621              (let ((lisp-path-fp (x86-call-context lisp-ocfp
622                                                    :depth (1+ depth)))
623                    (c-path-fp (x86-call-context c-ocfp :depth (1+ depth))))
624                (cond ((and lisp-path-fp c-path-fp)
625                        ;; Both still seem valid - choose the lisp frame.
626                        #+nil (when (zerop depth)
627                                (format t
628                                        "debug: both still valid ~S ~S ~S ~S~%"
629                                        lisp-ocfp lisp-ra c-ocfp c-ra))
630                       #!+freebsd
631                       (if (sap> lisp-ocfp c-ocfp)
632                         (values lisp-ra lisp-ocfp)
633                         (values c-ra c-ocfp))
634                        #!-freebsd
635                        (values lisp-ra lisp-ocfp))
636                      (lisp-path-fp
637                       ;; The lisp convention is looking good.
638                       #+nil (format t "*C lisp-ocfp ~S ~S~%" lisp-ocfp lisp-ra)
639                       (values lisp-ra lisp-ocfp))
640                      (c-path-fp
641                       ;; The C convention is looking good.
642                       #+nil (format t "*C c-ocfp ~S ~S~%" c-ocfp c-ra)
643                       (values c-ra c-ocfp))
644                      (t
645                       ;; Neither seems right?
646                       #+nil (format t "debug: no valid2 fp found ~S ~S~%"
647                                     lisp-ocfp c-ocfp)
648                       nil))))
649             ((and (sap> lisp-ocfp fp) (control-stack-pointer-valid-p lisp-ocfp)
650                   (ra-pointer-valid-p lisp-ra))
651              ;; The lisp convention is looking good.
652              #+nil (format t "*C lisp-ocfp ~S ~S~%" lisp-ocfp lisp-ra)
653              (values lisp-ra lisp-ocfp))
654             ((and (sap> c-ocfp fp) (control-stack-pointer-valid-p c-ocfp)
655                   #!-linux (ra-pointer-valid-p c-ra))
656              ;; The C convention is looking good.
657              #+nil (format t "*C c-ocfp ~S ~S~%" c-ocfp c-ra)
658              (values c-ra c-ocfp))
659             (t
660              #+nil (format t "debug: no valid fp found ~S ~S~%"
661                            lisp-ocfp c-ocfp)
662              nil))))))
663
664 ) ; #+x86 PROGN
665 \f
666 ;;; Convert the descriptor into a SAP. The bits all stay the same, we just
667 ;;; change our notion of what we think they are.
668 #!-sb-fluid (declaim (inline descriptor-sap))
669 (defun descriptor-sap (x)
670   (int-sap (get-lisp-obj-address x)))
671
672 ;;; Return the top frame of the control stack as it was before calling
673 ;;; this function.
674 (defun top-frame ()
675   (/noshow0 "entering TOP-FRAME")
676   (multiple-value-bind (fp pc) (%caller-frame-and-pc)
677     (compute-calling-frame (descriptor-sap fp) pc nil)))
678
679 ;;; Flush all of the frames above FRAME, and renumber all the frames
680 ;;; below FRAME.
681 (defun flush-frames-above (frame)
682   (setf (frame-up frame) nil)
683   (do ((number 0 (1+ number))
684        (frame frame (frame-%down frame)))
685       ((not (frame-p frame)))
686     (setf (frame-number frame) number)))
687
688 ;;; Return the frame immediately below FRAME on the stack; or when
689 ;;; FRAME is the bottom of the stack, return NIL.
690 (defun frame-down (frame)
691   (/noshow0 "entering FRAME-DOWN")
692   ;; We have to access the old-fp and return-pc out of frame and pass
693   ;; them to COMPUTE-CALLING-FRAME.
694   (let ((down (frame-%down frame)))
695     (if (eq down :unparsed)
696         (let ((debug-fun (frame-debug-fun frame)))
697           (/noshow0 "in DOWN :UNPARSED case")
698           (setf (frame-%down frame)
699                 (etypecase debug-fun
700                   (compiled-debug-fun
701                    (let ((c-d-f (compiled-debug-fun-compiler-debug-fun
702                                  debug-fun)))
703                      (compute-calling-frame
704                       (descriptor-sap
705                        (get-context-value
706                         frame ocfp-save-offset
707                         (sb!c::compiled-debug-fun-old-fp c-d-f)))
708                       (get-context-value
709                        frame lra-save-offset
710                        (sb!c::compiled-debug-fun-return-pc c-d-f))
711                       frame)))
712                   (bogus-debug-fun
713                    (let ((fp (frame-pointer frame)))
714                      (when (control-stack-pointer-valid-p fp)
715                        #!+x86
716                         (multiple-value-bind (ra ofp) (x86-call-context fp)
717                          (and ra (compute-calling-frame ofp ra frame)))
718                         #!-x86
719                        (compute-calling-frame
720                         #!-alpha
721                         (sap-ref-sap fp (* ocfp-save-offset
722                                            sb!vm:n-word-bytes))
723                         #!+alpha
724                         (int-sap
725                          (sap-ref-32 fp (* ocfp-save-offset
726                                            sb!vm:n-word-bytes)))
727
728                         (stack-ref fp lra-save-offset)
729
730                         frame)))))))
731         down)))
732
733 ;;; Get the old FP or return PC out of FRAME. STACK-SLOT is the
734 ;;; standard save location offset on the stack. LOC is the saved
735 ;;; SC-OFFSET describing the main location.
736 #!-x86
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)))
742     (if escaped
743         (sub-access-debug-var-slot pointer loc escaped)
744         (stack-ref pointer stack-slot))))
745 #!+x86
746 (defun get-context-value (frame stack-slot loc)
747   (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
748            (type sb!c:sc-offset loc))
749   (let ((pointer (frame-pointer frame))
750         (escaped (compiled-frame-escaped frame)))
751     (if escaped
752         (sub-access-debug-var-slot pointer loc escaped)
753         (ecase stack-slot
754           (#.ocfp-save-offset
755            (stack-ref pointer stack-slot))
756           (#.lra-save-offset
757            (sap-ref-sap pointer (- (* (1+ stack-slot) 4))))))))
758
759 #!-x86
760 (defun (setf get-context-value) (value frame stack-slot loc)
761   (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
762            (type sb!c:sc-offset loc))
763   (let ((pointer (frame-pointer frame))
764         (escaped (compiled-frame-escaped frame)))
765     (if escaped
766         (sub-set-debug-var-slot pointer loc value escaped)
767         (setf (stack-ref pointer stack-slot) value))))
768
769 #!+x86
770 (defun (setf get-context-value) (value frame stack-slot loc)
771   (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
772            (type sb!c:sc-offset loc))
773   (let ((pointer (frame-pointer frame))
774         (escaped (compiled-frame-escaped frame)))
775     (if escaped
776         (sub-set-debug-var-slot pointer loc value escaped)
777         (ecase stack-slot
778           (#.ocfp-save-offset
779            (setf (stack-ref pointer stack-slot) value))
780           (#.lra-save-offset
781            (setf (sap-ref-sap pointer (- (* (1+ stack-slot) 4))) value))))))
782
783 (defun foreign-function-backtrace-name (sap)
784   (let ((name (foreign-symbol-in-address sap)))
785     (if name
786         (format nil "foreign function: ~A" name)
787         (format nil "foreign function: #x~X" (sap-int sap)))))
788
789 ;;; This returns a frame for the one existing in time immediately
790 ;;; prior to the frame referenced by current-fp. This is current-fp's
791 ;;; caller or the next frame down the control stack. If there is no
792 ;;; down frame, this returns NIL for the bottom of the stack. UP-FRAME
793 ;;; is the up link for the resulting frame object, and it is null when
794 ;;; we call this to get the top of the stack.
795 ;;;
796 ;;; The current frame contains the pointer to the temporally previous
797 ;;; frame we want, and the current frame contains the pc at which we
798 ;;; will continue executing upon returning to that previous frame.
799 ;;;
800 ;;; Note: Sometimes LRA is actually a fixnum. This happens when lisp
801 ;;; calls into C. In this case, the code object is stored on the stack
802 ;;; after the LRA, and the LRA is the word offset.
803 #!-x86
804 (defun compute-calling-frame (caller lra up-frame)
805   (declare (type system-area-pointer caller))
806   (when (control-stack-pointer-valid-p caller)
807     (multiple-value-bind (code pc-offset escaped)
808         (if lra
809             (multiple-value-bind (word-offset code)
810                 (if (fixnump lra)
811                     (let ((fp (frame-pointer up-frame)))
812                       (values lra
813                               (stack-ref fp (1+ lra-save-offset))))
814                     (values (get-header-data lra)
815                             (lra-code-header lra)))
816               (if code
817                   (values code
818                           (* (1+ (- word-offset (get-header-data code)))
819                              sb!vm:n-word-bytes)
820                           nil)
821                   (values :foreign-function
822                           0
823                           nil)))
824             (find-escaped-frame caller))
825       (if (and (code-component-p code)
826                (eq (%code-debug-info code) :bogus-lra))
827           (let ((real-lra (code-header-ref code real-lra-slot)))
828             (compute-calling-frame caller real-lra up-frame))
829           (let ((d-fun (case code
830                          (:undefined-function
831                           (make-bogus-debug-fun
832                            "undefined function"))
833                          (:foreign-function
834                           (make-bogus-debug-fun
835                            (foreign-function-backtrace-name
836                             (int-sap (get-lisp-obj-address lra)))))
837                          ((nil)
838                           (make-bogus-debug-fun
839                            "bogus stack frame"))
840                          (t
841                           (debug-fun-from-pc code pc-offset)))))
842             (make-compiled-frame caller up-frame d-fun
843                                  (code-location-from-pc d-fun pc-offset
844                                                         escaped)
845                                  (if up-frame (1+ (frame-number up-frame)) 0)
846                                  escaped))))))
847 #!+x86
848 (defun compute-calling-frame (caller ra up-frame)
849   (declare (type system-area-pointer caller ra))
850   (/noshow0 "entering COMPUTE-CALLING-FRAME")
851   (when (control-stack-pointer-valid-p caller)
852     (/noshow0 "in WHEN")
853     ;; First check for an escaped frame.
854     (multiple-value-bind (code pc-offset escaped) (find-escaped-frame caller)
855       (/noshow0 "at COND")
856       (cond (code
857              (/noshow0 "in CODE clause")
858              ;; If it's escaped it may be a function end breakpoint trap.
859              (when (and (code-component-p code)
860                         (eq (%code-debug-info code) :bogus-lra))
861                ;; If :bogus-lra grab the real lra.
862                (setq pc-offset (code-header-ref
863                                 code (1+ real-lra-slot)))
864                (setq code (code-header-ref code real-lra-slot))
865                (aver code)))
866             (t
867              (/noshow0 "in T clause")
868              ;; not escaped
869              (multiple-value-setq (pc-offset code)
870                (compute-lra-data-from-pc ra))
871              (unless code
872                (setf code :foreign-function
873                      pc-offset 0
874                      escaped nil))))
875
876       (let ((d-fun (case code
877                      (:undefined-function
878                       (make-bogus-debug-fun
879                        "undefined function"))
880                      (:foreign-function
881                       (make-bogus-debug-fun
882                        (foreign-function-backtrace-name ra)))
883                      ((nil)
884                       (make-bogus-debug-fun
885                        "bogus stack frame"))
886                      (t
887                       (debug-fun-from-pc code pc-offset)))))
888         (/noshow0 "returning MAKE-COMPILED-FRAME from COMPUTE-CALLING-FRAME")
889         (make-compiled-frame caller up-frame d-fun
890                              (code-location-from-pc d-fun pc-offset
891                                                     escaped)
892                              (if up-frame (1+ (frame-number up-frame)) 0)
893                              escaped)))))
894
895 (defun nth-interrupt-context (n)
896   (declare (type (unsigned-byte 32) n)
897            (optimize (speed 3) (safety 0)))
898   (sb!alien:sap-alien (sb!vm::current-thread-offset-sap 
899                        (+ sb!vm::thread-interrupt-contexts-offset n))
900                       (* os-context-t)))
901
902 #!+x86
903 (defun find-escaped-frame (frame-pointer)
904   (declare (type system-area-pointer frame-pointer))
905   (/noshow0 "entering FIND-ESCAPED-FRAME")
906   (dotimes (index *free-interrupt-context-index* (values nil 0 nil))
907       (/noshow0 "at head of WITH-ALIEN")
908     (let ((context (nth-interrupt-context index)))
909         (/noshow0 "got CONTEXT")
910         (when (= (sap-int frame-pointer)
911                  (sb!vm:context-register context sb!vm::cfp-offset))
912           (without-gcing
913            (/noshow0 "in WITHOUT-GCING")
914            (let* ((component-ptr (component-ptr-from-pc
915                                   (sb!vm:context-pc context)))
916                   (code (unless (sap= component-ptr (int-sap #x0))
917                           (component-from-component-ptr component-ptr))))
918              (/noshow0 "got CODE")
919              (when (null code)
920                (return (values code 0 context)))
921              (let* ((code-header-len (* (get-header-data code)
922                                         sb!vm:n-word-bytes))
923                     (pc-offset
924                      (- (sap-int (sb!vm:context-pc context))
925                         (- (get-lisp-obj-address code)
926                            sb!vm:other-pointer-lowtag)
927                         code-header-len)))
928                (/noshow "got PC-OFFSET")
929                (unless (<= 0 pc-offset
930                            (* (code-header-ref code sb!vm:code-code-size-slot)
931                               sb!vm:n-word-bytes))
932                  ;; We were in an assembly routine. Therefore, use the
933                  ;; LRA as the pc.
934                  ;;
935                  ;; FIXME: Should this be WARN or ERROR or what?
936                  (format t "** pc-offset ~S not in code obj ~S?~%"
937                          pc-offset code))
938                (/noshow0 "returning from FIND-ESCAPED-FRAME")
939                (return
940                (values code pc-offset context)))))))))
941
942 #!-x86
943 (defun find-escaped-frame (frame-pointer)
944   (declare (type system-area-pointer frame-pointer))
945   (dotimes (index *free-interrupt-context-index* (values nil 0 nil))
946     (let ((scp (nth-interrupt-context index)))
947       (when (= (sap-int frame-pointer)
948                (sb!vm:context-register scp sb!vm::cfp-offset))
949         (without-gcing
950          (let ((code (code-object-from-bits
951                       (sb!vm:context-register scp sb!vm::code-offset))))
952            (when (symbolp code)
953              (return (values code 0 scp)))
954            (let* ((code-header-len (* (get-header-data code)
955                                       sb!vm:n-word-bytes))
956                   (pc-offset
957                    (- (sap-int (sb!vm:context-pc scp))
958                       (- (get-lisp-obj-address code)
959                          sb!vm:other-pointer-lowtag)
960                       code-header-len)))
961              ;; Check to see whether we were executing in a branch
962              ;; delay slot.
963              #!+(or pmax sgi)          ; pmax only (and broken anyway)
964              (when (logbitp 31 (sb!alien:slot scp '%mips::sc-cause))
965                (incf pc-offset sb!vm:n-word-bytes))
966              (let ((code-size (* (code-header-ref code 
967                                                   sb!vm:code-code-size-slot)
968                                  sb!vm:n-word-bytes)))
969                (unless (<= 0 pc-offset code-size)
970                  ;; We were in an assembly routine.
971                  (multiple-value-bind (new-pc-offset computed-return)
972                      (find-pc-from-assembly-fun code scp)
973                    (setf pc-offset new-pc-offset)
974                    (unless (<= 0 pc-offset code-size)
975                      (cerror
976                       "Set PC-OFFSET to zero and continue backtrace."
977                       'bug
978                       :format-control
979                       "~@<PC-OFFSET (~D) not in code object. Frame details:~
980                        ~2I~:@_PC: #X~X~:@_CODE: ~S~:@_CODE FUN: ~S~:@_LRA: ~
981                        #X~X~:@_COMPUTED RETURN: #X~X.~:>"
982                       :format-arguments
983                       (list pc-offset
984                             (sap-int (sb!vm:context-pc scp))
985                             code
986                             (%code-entry-points code)
987                             (sb!vm:context-register scp sb!vm::lra-offset)
988                             computed-return))
989                      ;; We failed to pinpoint where PC is, but set
990                      ;; pc-offset to 0 to keep the backtrace from
991                      ;; exploding.
992                      (setf pc-offset 0)))))
993              (return
994                (if (eq (%code-debug-info code) :bogus-lra)
995                    (let ((real-lra (code-header-ref code
996                                                     real-lra-slot)))
997                      (values (lra-code-header real-lra)
998                              (get-header-data real-lra)
999                              nil))
1000                    (values code pc-offset scp))))))))))
1001
1002 #!-x86
1003 (defun find-pc-from-assembly-fun (code scp)
1004   "Finds the PC for the return from an assembly routine properly.
1005 For some architectures (such as PPC) this will not be the $LRA
1006 register."
1007   (let ((return-machine-address (sb!vm::return-machine-address scp))
1008         (code-header-len (* (get-header-data code) sb!vm:n-word-bytes)))
1009     (values (- return-machine-address
1010                (- (get-lisp-obj-address code)
1011                   sb!vm:other-pointer-lowtag) 
1012                code-header-len)
1013             return-machine-address)))
1014
1015 ;;; Find the code object corresponding to the object represented by
1016 ;;; bits and return it. We assume bogus functions correspond to the
1017 ;;; undefined-function.
1018 (defun code-object-from-bits (bits)
1019   (declare (type (unsigned-byte 32) bits))
1020   (let ((object (make-lisp-obj bits)))
1021     (if (functionp object)
1022         (or (fun-code-header object)
1023             :undefined-function)
1024         (let ((lowtag (lowtag-of object)))
1025           (if (= lowtag sb!vm:other-pointer-lowtag)
1026               (let ((widetag (widetag-of object)))
1027                 (cond ((= widetag sb!vm:code-header-widetag)
1028                        object)
1029                       ((= widetag sb!vm:return-pc-header-widetag)
1030                        (lra-code-header object))
1031                       (t
1032                        nil))))))))
1033 \f
1034 ;;;; frame utilities
1035
1036 ;;; This returns a COMPILED-DEBUG-FUN for COMPONENT and PC. We fetch the
1037 ;;; SB!C::DEBUG-INFO and run down its FUN-MAP to get a
1038 ;;; SB!C::COMPILED-DEBUG-FUN from the PC. The result only needs to
1039 ;;; reference the COMPONENT, for function constants, and the
1040 ;;; SB!C::COMPILED-DEBUG-FUN.
1041 (defun debug-fun-from-pc (component pc)
1042   (let ((info (%code-debug-info component)))
1043     (cond
1044      ((not info)
1045       (debug-signal 'no-debug-info :code-component component))
1046      ((eq info :bogus-lra)
1047       (make-bogus-debug-fun "function end breakpoint"))
1048      (t
1049       (let* ((fun-map (sb!c::compiled-debug-info-fun-map info))
1050              (len (length fun-map)))
1051         (declare (type simple-vector fun-map))
1052         (if (= len 1)
1053             (make-compiled-debug-fun (svref fun-map 0) component)
1054             (let ((i 1)
1055                   (elsewhere-p
1056                    (>= pc (sb!c::compiled-debug-fun-elsewhere-pc
1057                            (svref fun-map 0)))))
1058               (declare (type sb!int:index i))
1059               (loop
1060                 (when (or (= i len)
1061                           (< pc (if elsewhere-p
1062                                     (sb!c::compiled-debug-fun-elsewhere-pc
1063                                      (svref fun-map (1+ i)))
1064                                     (svref fun-map i))))
1065                   (return (make-compiled-debug-fun
1066                            (svref fun-map (1- i))
1067                            component)))
1068                 (incf i 2)))))))))
1069
1070 ;;; This returns a code-location for the COMPILED-DEBUG-FUN,
1071 ;;; DEBUG-FUN, and the pc into its code vector. If we stopped at a
1072 ;;; breakpoint, find the CODE-LOCATION for that breakpoint. Otherwise,
1073 ;;; make an :UNSURE code location, so it can be filled in when we
1074 ;;; figure out what is going on.
1075 (defun code-location-from-pc (debug-fun pc escaped)
1076   (or (and (compiled-debug-fun-p debug-fun)
1077            escaped
1078            (let ((data (breakpoint-data
1079                         (compiled-debug-fun-component debug-fun)
1080                         pc nil)))
1081              (when (and data (breakpoint-data-breakpoints data))
1082                (let ((what (breakpoint-what
1083                             (first (breakpoint-data-breakpoints data)))))
1084                  (when (compiled-code-location-p what)
1085                    what)))))
1086       (make-compiled-code-location pc debug-fun)))
1087
1088 ;;; Return an alist mapping catch tags to CODE-LOCATIONs. These are
1089 ;;; CODE-LOCATIONs at which execution would continue with frame as the
1090 ;;; top frame if someone threw to the corresponding tag.
1091 (defun frame-catches (frame)
1092   (let ((catch (descriptor-sap sb!vm:*current-catch-block*))
1093         (reversed-result nil)
1094         (fp (frame-pointer frame)))
1095     (loop until (zerop (sap-int catch))
1096           finally (return (nreverse reversed-result))
1097           do
1098           (when (sap= fp
1099                       #!-alpha
1100                       (sap-ref-sap catch
1101                                    (* sb!vm:catch-block-current-cont-slot
1102                                       sb!vm:n-word-bytes))
1103                       #!+alpha
1104                       (int-sap
1105                        (sap-ref-32 catch
1106                                    (* sb!vm:catch-block-current-cont-slot
1107                                       sb!vm:n-word-bytes))))
1108             (let* (#!-x86
1109                    (lra (stack-ref catch sb!vm:catch-block-entry-pc-slot))
1110                    #!+x86
1111                    (ra (sap-ref-sap
1112                         catch (* sb!vm:catch-block-entry-pc-slot
1113                                  sb!vm:n-word-bytes)))
1114                    #!-x86
1115                    (component
1116                     (stack-ref catch sb!vm:catch-block-current-code-slot))
1117                    #!+x86
1118                    (component (component-from-component-ptr
1119                                (component-ptr-from-pc ra)))
1120                    (offset
1121                     #!-x86
1122                     (* (- (1+ (get-header-data lra))
1123                           (get-header-data component))
1124                        sb!vm:n-word-bytes)
1125                     #!+x86
1126                     (- (sap-int ra)
1127                        (- (get-lisp-obj-address component)
1128                           sb!vm:other-pointer-lowtag)
1129                        (* (get-header-data component) sb!vm:n-word-bytes))))
1130               (push (cons #!-x86
1131                           (stack-ref catch sb!vm:catch-block-tag-slot)
1132                           #!+x86
1133                           (make-lisp-obj
1134                            (sap-ref-32 catch (* sb!vm:catch-block-tag-slot
1135                                                 sb!vm:n-word-bytes)))
1136                           (make-compiled-code-location
1137                            offset (frame-debug-fun frame)))
1138                     reversed-result)))
1139           (setf catch
1140                 #!-alpha
1141                 (sap-ref-sap catch
1142                              (* sb!vm:catch-block-previous-catch-slot
1143                                 sb!vm:n-word-bytes))
1144                 #!+alpha
1145                 (int-sap
1146                  (sap-ref-32 catch
1147                              (* sb!vm:catch-block-previous-catch-slot
1148                                 sb!vm:n-word-bytes)))))))
1149 \f
1150 ;;;; operations on DEBUG-FUNs
1151
1152 ;;; Execute the forms in a context with BLOCK-VAR bound to each
1153 ;;; DEBUG-BLOCK in DEBUG-FUN successively. Result is an optional
1154 ;;; form to execute for return values, and DO-DEBUG-FUN-BLOCKS
1155 ;;; returns nil if there is no result form. This signals a
1156 ;;; NO-DEBUG-BLOCKS condition when the DEBUG-FUN lacks
1157 ;;; DEBUG-BLOCK information.
1158 (defmacro do-debug-fun-blocks ((block-var debug-fun &optional result)
1159                                &body body)
1160   (let ((blocks (gensym))
1161         (i (gensym)))
1162     `(let ((,blocks (debug-fun-debug-blocks ,debug-fun)))
1163        (declare (simple-vector ,blocks))
1164        (dotimes (,i (length ,blocks) ,result)
1165          (let ((,block-var (svref ,blocks ,i)))
1166            ,@body)))))
1167
1168 ;;; Execute body in a context with VAR bound to each DEBUG-VAR in
1169 ;;; DEBUG-FUN. This returns the value of executing result (defaults to
1170 ;;; nil). This may iterate over only some of DEBUG-FUN's variables or
1171 ;;; none depending on debug policy; for example, possibly the
1172 ;;; compilation only preserved argument information.
1173 (defmacro do-debug-fun-vars ((var debug-fun &optional result) &body body)
1174   (let ((vars (gensym))
1175         (i (gensym)))
1176     `(let ((,vars (debug-fun-debug-vars ,debug-fun)))
1177        (declare (type (or null simple-vector) ,vars))
1178        (if ,vars
1179            (dotimes (,i (length ,vars) ,result)
1180              (let ((,var (svref ,vars ,i)))
1181                ,@body))
1182            ,result))))
1183
1184 ;;; Return the object of type FUNCTION associated with the DEBUG-FUN,
1185 ;;; or NIL if the function is unavailable or is non-existent as a user
1186 ;;; callable function object.
1187 (defun debug-fun-fun (debug-fun)
1188   (let ((cached-value (debug-fun-%function debug-fun)))
1189     (if (eq cached-value :unparsed)
1190         (setf (debug-fun-%function debug-fun)
1191               (etypecase debug-fun
1192                 (compiled-debug-fun
1193                  (let ((component
1194                         (compiled-debug-fun-component debug-fun))
1195                        (start-pc
1196                         (sb!c::compiled-debug-fun-start-pc
1197                          (compiled-debug-fun-compiler-debug-fun debug-fun))))
1198                    (do ((entry (%code-entry-points component)
1199                                (%simple-fun-next entry)))
1200                        ((null entry) nil)
1201                      (when (= start-pc
1202                               (sb!c::compiled-debug-fun-start-pc
1203                                (compiled-debug-fun-compiler-debug-fun
1204                                 (fun-debug-fun entry))))
1205                        (return entry)))))
1206                 (bogus-debug-fun nil)))
1207         cached-value)))
1208
1209 ;;; Return the name of the function represented by DEBUG-FUN. This may
1210 ;;; be a string or a cons; do not assume it is a symbol.
1211 (defun debug-fun-name (debug-fun)
1212   (declare (type debug-fun debug-fun))
1213   (etypecase debug-fun
1214     (compiled-debug-fun
1215      (sb!c::compiled-debug-fun-name
1216       (compiled-debug-fun-compiler-debug-fun debug-fun)))
1217     (bogus-debug-fun
1218      (bogus-debug-fun-%name debug-fun))))
1219
1220 ;;; Return a DEBUG-FUN that represents debug information for FUN.
1221 (defun fun-debug-fun (fun)
1222   (declare (type function fun))
1223   (ecase (widetag-of fun)
1224     (#.sb!vm:closure-header-widetag
1225      (fun-debug-fun (%closure-fun fun)))
1226     (#.sb!vm:funcallable-instance-header-widetag
1227      (fun-debug-fun (funcallable-instance-fun fun)))
1228     (#.sb!vm:simple-fun-header-widetag
1229       (let* ((name (%simple-fun-name fun))
1230              (component (fun-code-header fun))
1231              (res (find-if
1232                    (lambda (x)
1233                      (and (sb!c::compiled-debug-fun-p x)
1234                           (eq (sb!c::compiled-debug-fun-name x) name)
1235                           (eq (sb!c::compiled-debug-fun-kind x) nil)))
1236                    (sb!c::compiled-debug-info-fun-map
1237                     (%code-debug-info component)))))
1238         (if res
1239             (make-compiled-debug-fun res component)
1240             ;; KLUDGE: comment from CMU CL:
1241             ;;   This used to be the non-interpreted branch, but
1242             ;;   William wrote it to return the debug-fun of fun's XEP
1243             ;;   instead of fun's debug-fun. The above code does this
1244             ;;   more correctly, but it doesn't get or eliminate all
1245             ;;   appropriate cases. It mostly works, and probably
1246             ;;   works for all named functions anyway.
1247             ;; -- WHN 20000120
1248             (debug-fun-from-pc component
1249                                (* (- (fun-word-offset fun)
1250                                      (get-header-data component))
1251                                   sb!vm:n-word-bytes)))))))
1252
1253 ;;; Return the kind of the function, which is one of :OPTIONAL,
1254 ;;; :EXTERNAL, :TOPLEVEL, :CLEANUP, or NIL.
1255 (defun debug-fun-kind (debug-fun)
1256   ;; FIXME: This "is one of" information should become part of the function
1257   ;; declamation, not just a doc string
1258   (etypecase debug-fun
1259     (compiled-debug-fun
1260      (sb!c::compiled-debug-fun-kind
1261       (compiled-debug-fun-compiler-debug-fun debug-fun)))
1262     (bogus-debug-fun
1263      nil)))
1264
1265 ;;; Is there any variable information for DEBUG-FUN?
1266 (defun debug-var-info-available (debug-fun)
1267   (not (not (debug-fun-debug-vars debug-fun))))
1268
1269 ;;; Return a list of DEBUG-VARs in DEBUG-FUN having the same name
1270 ;;; and package as SYMBOL. If SYMBOL is uninterned, then this returns
1271 ;;; a list of DEBUG-VARs without package names and with the same name
1272 ;;; as symbol. The result of this function is limited to the
1273 ;;; availability of variable information in DEBUG-FUN; for
1274 ;;; example, possibly DEBUG-FUN only knows about its arguments.
1275 (defun debug-fun-symbol-vars (debug-fun symbol)
1276   (let ((vars (ambiguous-debug-vars debug-fun (symbol-name symbol)))
1277         (package (and (symbol-package symbol)
1278                       (package-name (symbol-package symbol)))))
1279     (delete-if (if (stringp package)
1280                    (lambda (var)
1281                      (let ((p (debug-var-package-name var)))
1282                        (or (not (stringp p))
1283                            (string/= p package))))
1284                    (lambda (var)
1285                      (stringp (debug-var-package-name var))))
1286                vars)))
1287
1288 ;;; Return a list of DEBUG-VARs in DEBUG-FUN whose names contain
1289 ;;; NAME-PREFIX-STRING as an initial substring. The result of this
1290 ;;; function is limited to the availability of variable information in
1291 ;;; debug-fun; for example, possibly debug-fun only knows
1292 ;;; about its arguments.
1293 (defun ambiguous-debug-vars (debug-fun name-prefix-string)
1294   (declare (simple-string name-prefix-string))
1295   (let ((variables (debug-fun-debug-vars debug-fun)))
1296     (declare (type (or null simple-vector) variables))
1297     (if variables
1298         (let* ((len (length variables))
1299                (prefix-len (length name-prefix-string))
1300                (pos (find-var name-prefix-string variables len))
1301                (res nil))
1302           (when pos
1303             ;; Find names from pos to variable's len that contain prefix.
1304             (do ((i pos (1+ i)))
1305                 ((= i len))
1306               (let* ((var (svref variables i))
1307                      (name (debug-var-symbol-name var))
1308                      (name-len (length name)))
1309                 (declare (simple-string name))
1310                 (when (/= (or (string/= name-prefix-string name
1311                                         :end1 prefix-len :end2 name-len)
1312                               prefix-len)
1313                           prefix-len)
1314                   (return))
1315                 (push var res)))
1316             (setq res (nreverse res)))
1317           res))))
1318
1319 ;;; This returns a position in VARIABLES for one containing NAME as an
1320 ;;; initial substring. END is the length of VARIABLES if supplied.
1321 (defun find-var (name variables &optional end)
1322   (declare (simple-vector variables)
1323            (simple-string name))
1324   (let ((name-len (length name)))
1325     (position name variables
1326               :test (lambda (x y)
1327                       (let* ((y (debug-var-symbol-name y))
1328                              (y-len (length y)))
1329                         (declare (simple-string y))
1330                         (and (>= y-len name-len)
1331                              (string= x y :end1 name-len :end2 name-len))))
1332               :end (or end (length variables)))))
1333
1334 ;;; Return a list representing the lambda-list for DEBUG-FUN. The
1335 ;;; list has the following structure:
1336 ;;;   (required-var1 required-var2
1337 ;;;    ...
1338 ;;;    (:optional var3 suppliedp-var4)
1339 ;;;    (:optional var5)
1340 ;;;    ...
1341 ;;;    (:rest var6) (:rest var7)
1342 ;;;    ...
1343 ;;;    (:keyword keyword-symbol var8 suppliedp-var9)
1344 ;;;    (:keyword keyword-symbol var10)
1345 ;;;    ...
1346 ;;;   )
1347 ;;; Each VARi is a DEBUG-VAR; however it may be the symbol :DELETED if
1348 ;;; it is unreferenced in DEBUG-FUN. This signals a
1349 ;;; LAMBDA-LIST-UNAVAILABLE condition when there is no argument list
1350 ;;; information.
1351 (defun debug-fun-lambda-list (debug-fun)
1352   (etypecase debug-fun
1353     (compiled-debug-fun (compiled-debug-fun-lambda-list debug-fun))
1354     (bogus-debug-fun nil)))
1355
1356 ;;; Note: If this has to compute the lambda list, it caches it in DEBUG-FUN.
1357 (defun compiled-debug-fun-lambda-list (debug-fun)
1358   (let ((lambda-list (debug-fun-%lambda-list debug-fun)))
1359     (cond ((eq lambda-list :unparsed)
1360            (multiple-value-bind (args argsp)
1361                (parse-compiled-debug-fun-lambda-list debug-fun)
1362              (setf (debug-fun-%lambda-list debug-fun) args)
1363              (if argsp
1364                  args
1365                  (debug-signal 'lambda-list-unavailable
1366                                :debug-fun debug-fun))))
1367           (lambda-list)
1368           ((bogus-debug-fun-p debug-fun)
1369            nil)
1370           ((sb!c::compiled-debug-fun-arguments
1371             (compiled-debug-fun-compiler-debug-fun debug-fun))
1372            ;; If the packed information is there (whether empty or not) as
1373            ;; opposed to being nil, then returned our cached value (nil).
1374            nil)
1375           (t
1376            ;; Our cached value is nil, and the packed lambda-list information
1377            ;; is nil, so we don't have anything available.
1378            (debug-signal 'lambda-list-unavailable
1379                          :debug-fun debug-fun)))))
1380
1381 ;;; COMPILED-DEBUG-FUN-LAMBDA-LIST calls this when a
1382 ;;; COMPILED-DEBUG-FUN has no lambda list information cached. It
1383 ;;; returns the lambda list as the first value and whether there was
1384 ;;; any argument information as the second value. Therefore,
1385 ;;; (VALUES NIL T) means there were no arguments, but (VALUES NIL NIL)
1386 ;;; means there was no argument information.
1387 (defun parse-compiled-debug-fun-lambda-list (debug-fun)
1388   (let ((args (sb!c::compiled-debug-fun-arguments
1389                (compiled-debug-fun-compiler-debug-fun debug-fun))))
1390     (cond
1391      ((not args)
1392       (values nil nil))
1393      ((eq args :minimal)
1394       (values (coerce (debug-fun-debug-vars debug-fun) 'list)
1395               t))
1396      (t
1397       (let ((vars (debug-fun-debug-vars debug-fun))
1398             (i 0)
1399             (len (length args))
1400             (res nil)
1401             (optionalp nil))
1402         (declare (type (or null simple-vector) vars))
1403         (loop
1404           (when (>= i len) (return))
1405           (let ((ele (aref args i)))
1406             (cond
1407              ((symbolp ele)
1408               (case ele
1409                 (sb!c::deleted
1410                  ;; Deleted required arg at beginning of args array.
1411                  (push :deleted res))
1412                 (sb!c::optional-args
1413                  (setf optionalp t))
1414                 (sb!c::supplied-p
1415                  ;; SUPPLIED-P var immediately following keyword or
1416                  ;; optional. Stick the extra var in the result
1417                  ;; element representing the keyword or optional,
1418                  ;; which is the previous one.
1419                  (nconc (car res)
1420                         (list (compiled-debug-fun-lambda-list-var
1421                                args (incf i) vars))))
1422                 (sb!c::rest-arg
1423                  (push (list :rest
1424                              (compiled-debug-fun-lambda-list-var
1425                               args (incf i) vars))
1426                        res))
1427                 (sb!c::more-arg
1428                  ;; Just ignore the fact that the next two args are
1429                  ;; the &MORE arg context and count, and act like they
1430                  ;; are regular arguments.
1431                  nil)
1432                 (t
1433                  ;; &KEY arg
1434                  (push (list :keyword
1435                              ele
1436                              (compiled-debug-fun-lambda-list-var
1437                               args (incf i) vars))
1438                        res))))
1439              (optionalp
1440               ;; We saw an optional marker, so the following
1441               ;; non-symbols are indexes indicating optional
1442               ;; variables.
1443               (push (list :optional (svref vars ele)) res))
1444              (t
1445               ;; Required arg at beginning of args array.
1446               (push (svref vars ele) res))))
1447           (incf i))
1448         (values (nreverse res) t))))))
1449
1450 ;;; This is used in COMPILED-DEBUG-FUN-LAMBDA-LIST.
1451 (defun compiled-debug-fun-lambda-list-var (args i vars)
1452   (declare (type (simple-array * (*)) args)
1453            (simple-vector vars))
1454   (let ((ele (aref args i)))
1455     (cond ((not (symbolp ele)) (svref vars ele))
1456           ((eq ele 'sb!c::deleted) :deleted)
1457           (t (error "malformed arguments description")))))
1458
1459 (defun compiled-debug-fun-debug-info (debug-fun)
1460   (%code-debug-info (compiled-debug-fun-component debug-fun)))
1461 \f
1462 ;;;; unpacking variable and basic block data
1463
1464 (defvar *parsing-buffer*
1465   (make-array 20 :adjustable t :fill-pointer t))
1466 (defvar *other-parsing-buffer*
1467   (make-array 20 :adjustable t :fill-pointer t))
1468 ;;; PARSE-DEBUG-BLOCKS and PARSE-DEBUG-VARS
1469 ;;; use this to unpack binary encoded information. It returns the
1470 ;;; values returned by the last form in body.
1471 ;;;
1472 ;;; This binds buffer-var to *parsing-buffer*, makes sure it starts at
1473 ;;; element zero, and makes sure if we unwind, we nil out any set
1474 ;;; elements for GC purposes.
1475 ;;;
1476 ;;; This also binds other-var to *other-parsing-buffer* when it is
1477 ;;; supplied, making sure it starts at element zero and that we nil
1478 ;;; out any elements if we unwind.
1479 ;;;
1480 ;;; This defines the local macro RESULT that takes a buffer, copies
1481 ;;; its elements to a resulting simple-vector, nil's out elements, and
1482 ;;; restarts the buffer at element zero. RESULT returns the
1483 ;;; simple-vector.
1484 (eval-when (:compile-toplevel :execute)
1485 (sb!xc:defmacro with-parsing-buffer ((buffer-var &optional other-var)
1486                                      &body body)
1487   (let ((len (gensym))
1488         (res (gensym)))
1489     `(unwind-protect
1490          (let ((,buffer-var *parsing-buffer*)
1491                ,@(if other-var `((,other-var *other-parsing-buffer*))))
1492            (setf (fill-pointer ,buffer-var) 0)
1493            ,@(if other-var `((setf (fill-pointer ,other-var) 0)))
1494            (macrolet ((result (buf)
1495                         `(let* ((,',len (length ,buf))
1496                                 (,',res (make-array ,',len)))
1497                            (replace ,',res ,buf :end1 ,',len :end2 ,',len)
1498                            (fill ,buf nil :end ,',len)
1499                            (setf (fill-pointer ,buf) 0)
1500                            ,',res)))
1501              ,@body))
1502      (fill *parsing-buffer* nil)
1503      ,@(if other-var `((fill *other-parsing-buffer* nil))))))
1504 ) ; EVAL-WHEN
1505
1506 ;;; The argument is a debug internals structure. This returns the
1507 ;;; DEBUG-BLOCKs for DEBUG-FUN, regardless of whether we have unpacked
1508 ;;; them yet. It signals a NO-DEBUG-BLOCKS condition if it can't
1509 ;;; return the blocks.
1510 (defun debug-fun-debug-blocks (debug-fun)
1511   (let ((blocks (debug-fun-blocks debug-fun)))
1512     (cond ((eq blocks :unparsed)
1513            (setf (debug-fun-blocks debug-fun)
1514                  (parse-debug-blocks debug-fun))
1515            (unless (debug-fun-blocks debug-fun)
1516              (debug-signal 'no-debug-blocks
1517                            :debug-fun debug-fun))
1518            (debug-fun-blocks debug-fun))
1519           (blocks)
1520           (t
1521            (debug-signal 'no-debug-blocks
1522                          :debug-fun debug-fun)))))
1523
1524 ;;; Return a SIMPLE-VECTOR of DEBUG-BLOCKs or NIL. NIL indicates there
1525 ;;; was no basic block information.
1526 (defun parse-debug-blocks (debug-fun)
1527   (etypecase debug-fun
1528     (compiled-debug-fun
1529      (parse-compiled-debug-blocks debug-fun))
1530     (bogus-debug-fun
1531      (debug-signal 'no-debug-blocks :debug-fun debug-fun))))
1532
1533 ;;; This does some of the work of PARSE-DEBUG-BLOCKS.
1534 (defun parse-compiled-debug-blocks (debug-fun)
1535   (let* ((var-count (length (debug-fun-debug-vars debug-fun)))
1536          (compiler-debug-fun (compiled-debug-fun-compiler-debug-fun
1537                               debug-fun))
1538          (blocks (sb!c::compiled-debug-fun-blocks compiler-debug-fun))
1539          ;; KLUDGE: 8 is a hard-wired constant in the compiler for the
1540          ;; element size of the packed binary representation of the
1541          ;; blocks data.
1542          (live-set-len (ceiling var-count 8))
1543          (tlf-number (sb!c::compiled-debug-fun-tlf-number compiler-debug-fun)))
1544     (unless blocks
1545       (return-from parse-compiled-debug-blocks nil))
1546     (macrolet ((aref+ (a i) `(prog1 (aref ,a ,i) (incf ,i))))
1547       (with-parsing-buffer (blocks-buffer locations-buffer)
1548         (let ((i 0)
1549               (len (length blocks))
1550               (last-pc 0))
1551           (loop
1552             (when (>= i len) (return))
1553             (let ((succ-and-flags (aref+ blocks i))
1554                   (successors nil))
1555               (declare (type (unsigned-byte 8) succ-and-flags)
1556                        (list successors))
1557               (dotimes (k (ldb sb!c::compiled-debug-block-nsucc-byte
1558                                succ-and-flags))
1559                 (push (sb!c:read-var-integer blocks i) successors))
1560               (let* ((locations
1561                       (dotimes (k (sb!c:read-var-integer blocks i)
1562                                   (result locations-buffer))
1563                         (let ((kind (svref sb!c::*compiled-code-location-kinds*
1564                                            (aref+ blocks i)))
1565                               (pc (+ last-pc
1566                                      (sb!c:read-var-integer blocks i)))
1567                               (tlf-offset (or tlf-number
1568                                               (sb!c:read-var-integer blocks i)))
1569                               (form-number (sb!c:read-var-integer blocks i))
1570                               (live-set (sb!c:read-packed-bit-vector
1571                                          live-set-len blocks i)))
1572                           (vector-push-extend (make-known-code-location
1573                                                pc debug-fun tlf-offset
1574                                                form-number live-set kind)
1575                                               locations-buffer)
1576                           (setf last-pc pc))))
1577                      (block (make-compiled-debug-block
1578                              locations successors
1579                              (not (zerop (logand
1580                                           sb!c::compiled-debug-block-elsewhere-p
1581                                           succ-and-flags))))))
1582                 (vector-push-extend block blocks-buffer)
1583                 (dotimes (k (length locations))
1584                   (setf (code-location-%debug-block (svref locations k))
1585                         block))))))
1586         (let ((res (result blocks-buffer)))
1587           (declare (simple-vector res))
1588           (dotimes (i (length res))
1589             (let* ((block (svref res i))
1590                    (succs nil))
1591               (dolist (ele (debug-block-successors block))
1592                 (push (svref res ele) succs))
1593               (setf (debug-block-successors block) succs)))
1594           res)))))
1595
1596 ;;; The argument is a debug internals structure. This returns NIL if
1597 ;;; there is no variable information. It returns an empty
1598 ;;; simple-vector if there were no locals in the function. Otherwise
1599 ;;; it returns a SIMPLE-VECTOR of DEBUG-VARs.
1600 (defun debug-fun-debug-vars (debug-fun)
1601   (let ((vars (debug-fun-%debug-vars debug-fun)))
1602     (if (eq vars :unparsed)
1603         (setf (debug-fun-%debug-vars debug-fun)
1604               (etypecase debug-fun
1605                 (compiled-debug-fun
1606                  (parse-compiled-debug-vars debug-fun))
1607                 (bogus-debug-fun nil)))
1608         vars)))
1609
1610 ;;; VARS is the parsed variables for a minimal debug function. We need
1611 ;;; to assign names of the form ARG-NNN. We must pad with leading
1612 ;;; zeros, since the arguments must be in alphabetical order.
1613 (defun assign-minimal-var-names (vars)
1614   (declare (simple-vector vars))
1615   (let* ((len (length vars))
1616          (width (length (format nil "~W" (1- len)))))
1617     (dotimes (i len)
1618       (without-package-locks
1619         (setf (compiled-debug-var-symbol (svref vars i))
1620               (intern (format nil "ARG-~V,'0D" width i)
1621                       ;; KLUDGE: It's somewhat nasty to have a bare
1622                       ;; package name string here. It would be
1623                       ;; nicer to have #.(FIND-PACKAGE "SB!DEBUG")
1624                       ;; instead, since then at least it would transform
1625                       ;; correctly under package renaming and stuff.
1626                       ;; However, genesis can't handle dumped packages..
1627                       ;; -- WHN 20000129
1628                       ;;
1629                       ;; FIXME: Maybe this could be fixed by moving the
1630                       ;; whole debug-int.lisp file to warm init? (after
1631                       ;; which dumping a #.(FIND-PACKAGE ..) expression
1632                       ;; would work fine) If this is possible, it would
1633                       ;; probably be a good thing, since minimizing the
1634                       ;; amount of stuff in cold init is basically good.
1635                       (or (find-package "SB-DEBUG")
1636                           (find-package "SB!DEBUG"))))))))
1637
1638 ;;; Parse the packed representation of DEBUG-VARs from
1639 ;;; DEBUG-FUN's SB!C::COMPILED-DEBUG-FUN, returning a vector
1640 ;;; of DEBUG-VARs, or NIL if there was no information to parse.
1641 (defun parse-compiled-debug-vars (debug-fun)
1642   (let* ((cdebug-fun (compiled-debug-fun-compiler-debug-fun
1643                       debug-fun))
1644          (packed-vars (sb!c::compiled-debug-fun-vars cdebug-fun))
1645          (args-minimal (eq (sb!c::compiled-debug-fun-arguments cdebug-fun)
1646                            :minimal)))
1647     (when packed-vars
1648       (do ((i 0)
1649            (buffer (make-array 0 :fill-pointer 0 :adjustable t)))
1650           ((>= i (length packed-vars))
1651            (let ((result (coerce buffer 'simple-vector)))
1652              (when args-minimal
1653                (assign-minimal-var-names result))
1654              result))
1655         (flet ((geti () (prog1 (aref packed-vars i) (incf i))))
1656           (let* ((flags (geti))
1657                  (minimal (logtest sb!c::compiled-debug-var-minimal-p flags))
1658                  (deleted (logtest sb!c::compiled-debug-var-deleted-p flags))
1659                  (live (logtest sb!c::compiled-debug-var-environment-live
1660                                 flags))
1661                  (save (logtest sb!c::compiled-debug-var-save-loc-p flags))
1662                  (symbol (if minimal nil (geti)))
1663                  (id (if (logtest sb!c::compiled-debug-var-id-p flags)
1664                          (geti)
1665                          0))
1666                  (sc-offset (if deleted 0 (geti)))
1667                  (save-sc-offset (if save (geti) nil)))
1668             (aver (not (and args-minimal (not minimal))))
1669             (vector-push-extend (make-compiled-debug-var symbol
1670                                                          id
1671                                                          live
1672                                                          sc-offset
1673                                                          save-sc-offset)
1674                                 buffer)))))))
1675 \f
1676 ;;;; CODE-LOCATIONs
1677
1678 ;;; If we're sure of whether code-location is known, return T or NIL.
1679 ;;; If we're :UNSURE, then try to fill in the code-location's slots.
1680 ;;; This determines whether there is any debug-block information, and
1681 ;;; if code-location is known.
1682 ;;;
1683 ;;; ??? IF this conses closures every time it's called, then break off the
1684 ;;; :UNSURE part to get the HANDLER-CASE into another function.
1685 (defun code-location-unknown-p (basic-code-location)
1686   (ecase (code-location-%unknown-p basic-code-location)
1687     ((t) t)
1688     ((nil) nil)
1689     (:unsure
1690      (setf (code-location-%unknown-p basic-code-location)
1691            (handler-case (not (fill-in-code-location basic-code-location))
1692              (no-debug-blocks () t))))))
1693
1694 ;;; Return the DEBUG-BLOCK containing code-location if it is available.
1695 ;;; Some debug policies inhibit debug-block information, and if none
1696 ;;; is available, then this signals a NO-DEBUG-BLOCKS condition.
1697 (defun code-location-debug-block (basic-code-location)
1698   (let ((block (code-location-%debug-block basic-code-location)))
1699     (if (eq block :unparsed)
1700         (etypecase basic-code-location
1701           (compiled-code-location
1702            (compute-compiled-code-location-debug-block basic-code-location))
1703           ;; (There used to be more cases back before sbcl-0.7.0, when
1704           ;; we did special tricks to debug the IR1 interpreter.)
1705           )
1706         block)))
1707
1708 ;;; Store and return BASIC-CODE-LOCATION's debug-block. We determines
1709 ;;; the correct one using the code-location's pc. We use
1710 ;;; DEBUG-FUN-DEBUG-BLOCKS to return the cached block information
1711 ;;; or signal a NO-DEBUG-BLOCKS condition. The blocks are sorted by
1712 ;;; their first code-location's pc, in ascending order. Therefore, as
1713 ;;; soon as we find a block that starts with a pc greater than
1714 ;;; basic-code-location's pc, we know the previous block contains the
1715 ;;; pc. If we get to the last block, then the code-location is either
1716 ;;; in the second to last block or the last block, and we have to be
1717 ;;; careful in determining this since the last block could be code at
1718 ;;; the end of the function. We have to check for the last block being
1719 ;;; code first in order to see how to compare the code-location's pc.
1720 (defun compute-compiled-code-location-debug-block (basic-code-location)
1721   (let* ((pc (compiled-code-location-pc basic-code-location))
1722          (debug-fun (code-location-debug-fun
1723                           basic-code-location))
1724          (blocks (debug-fun-debug-blocks debug-fun))
1725          (len (length blocks)))
1726     (declare (simple-vector blocks))
1727     (setf (code-location-%debug-block basic-code-location)
1728           (if (= len 1)
1729               (svref blocks 0)
1730               (do ((i 1 (1+ i))
1731                    (end (1- len)))
1732                   ((= i end)
1733                    (let ((last (svref blocks end)))
1734                      (cond
1735                       ((debug-block-elsewhere-p last)
1736                        (if (< pc
1737                               (sb!c::compiled-debug-fun-elsewhere-pc
1738                                (compiled-debug-fun-compiler-debug-fun
1739                                 debug-fun)))
1740                            (svref blocks (1- end))
1741                            last))
1742                       ((< pc
1743                           (compiled-code-location-pc
1744                            (svref (compiled-debug-block-code-locations last)
1745                                   0)))
1746                        (svref blocks (1- end)))
1747                       (t last))))
1748                 (declare (type index i end))
1749                 (when (< pc
1750                          (compiled-code-location-pc
1751                           (svref (compiled-debug-block-code-locations
1752                                   (svref blocks i))
1753                                  0)))
1754                   (return (svref blocks (1- i)))))))))
1755
1756 ;;; Return the CODE-LOCATION's DEBUG-SOURCE.
1757 (defun code-location-debug-source (code-location)
1758   (etypecase code-location
1759     (compiled-code-location
1760      (let* ((info (compiled-debug-fun-debug-info
1761                    (code-location-debug-fun code-location)))
1762             (sources (sb!c::compiled-debug-info-source info))
1763             (len (length sources)))
1764        (declare (list sources))
1765        (when (zerop len)
1766          (debug-signal 'no-debug-blocks :debug-fun
1767                        (code-location-debug-fun code-location)))
1768        (if (= len 1)
1769            (car sources)
1770            (do ((prev sources src)
1771                 (src (cdr sources) (cdr src))
1772                 (offset (code-location-toplevel-form-offset code-location)))
1773                ((null src) (car prev))
1774              (when (< offset (sb!c::debug-source-source-root (car src)))
1775                (return (car prev)))))))
1776     ;; (There used to be more cases back before sbcl-0.7.0, when we
1777     ;; did special tricks to debug the IR1 interpreter.)
1778     ))
1779
1780 ;;; Returns the number of top level forms before the one containing
1781 ;;; CODE-LOCATION as seen by the compiler in some compilation unit. (A
1782 ;;; compilation unit is not necessarily a single file, see the section
1783 ;;; on debug-sources.)
1784 (defun code-location-toplevel-form-offset (code-location)
1785   (when (code-location-unknown-p code-location)
1786     (error 'unknown-code-location :code-location code-location))
1787   (let ((tlf-offset (code-location-%tlf-offset code-location)))
1788     (cond ((eq tlf-offset :unparsed)
1789            (etypecase code-location
1790              (compiled-code-location
1791               (unless (fill-in-code-location code-location)
1792                 ;; This check should be unnecessary. We're missing
1793                 ;; debug info the compiler should have dumped.
1794                 (bug "unknown code location"))
1795               (code-location-%tlf-offset code-location))
1796              ;; (There used to be more cases back before sbcl-0.7.0,,
1797              ;; when we did special tricks to debug the IR1
1798              ;; interpreter.)
1799              ))
1800           (t tlf-offset))))
1801
1802 ;;; Return the number of the form corresponding to CODE-LOCATION. The
1803 ;;; form number is derived by a walking the subforms of a top level
1804 ;;; form in depth-first order.
1805 (defun code-location-form-number (code-location)
1806   (when (code-location-unknown-p code-location)
1807     (error 'unknown-code-location :code-location code-location))
1808   (let ((form-num (code-location-%form-number code-location)))
1809     (cond ((eq form-num :unparsed)
1810            (etypecase code-location
1811              (compiled-code-location
1812               (unless (fill-in-code-location code-location)
1813                 ;; This check should be unnecessary. We're missing
1814                 ;; debug info the compiler should have dumped.
1815                 (bug "unknown code location"))
1816               (code-location-%form-number code-location))
1817              ;; (There used to be more cases back before sbcl-0.7.0,,
1818              ;; when we did special tricks to debug the IR1
1819              ;; interpreter.)
1820              ))
1821           (t form-num))))
1822
1823 ;;; Return the kind of CODE-LOCATION, one of:
1824 ;;;  :INTERPRETED, :UNKNOWN-RETURN, :KNOWN-RETURN, :INTERNAL-ERROR,
1825 ;;;  :NON-LOCAL-EXIT, :BLOCK-START, :CALL-SITE, :SINGLE-VALUE-RETURN,
1826 ;;;  :NON-LOCAL-ENTRY
1827 (defun code-location-kind (code-location)
1828   (when (code-location-unknown-p code-location)
1829     (error 'unknown-code-location :code-location code-location))
1830   (etypecase code-location
1831     (compiled-code-location
1832      (let ((kind (compiled-code-location-kind code-location)))
1833        (cond ((not (eq kind :unparsed)) kind)
1834              ((not (fill-in-code-location code-location))
1835               ;; This check should be unnecessary. We're missing
1836               ;; debug info the compiler should have dumped.
1837               (bug "unknown code location"))
1838              (t
1839               (compiled-code-location-kind code-location)))))
1840     ;; (There used to be more cases back before sbcl-0.7.0,,
1841     ;; when we did special tricks to debug the IR1
1842     ;; interpreter.)
1843     ))
1844
1845 ;;; This returns CODE-LOCATION's live-set if it is available. If
1846 ;;; there is no debug-block information, this returns NIL.
1847 (defun compiled-code-location-live-set (code-location)
1848   (if (code-location-unknown-p code-location)
1849       nil
1850       (let ((live-set (compiled-code-location-%live-set code-location)))
1851         (cond ((eq live-set :unparsed)
1852                (unless (fill-in-code-location code-location)
1853                  ;; This check should be unnecessary. We're missing
1854                  ;; debug info the compiler should have dumped.
1855                  ;;
1856                  ;; FIXME: This error and comment happen over and over again.
1857                  ;; Make them a shared function.
1858                  (bug "unknown code location"))
1859                (compiled-code-location-%live-set code-location))
1860               (t live-set)))))
1861
1862 ;;; true if OBJ1 and OBJ2 are the same place in the code
1863 (defun code-location= (obj1 obj2)
1864   (etypecase obj1
1865     (compiled-code-location
1866      (etypecase obj2
1867        (compiled-code-location
1868         (and (eq (code-location-debug-fun obj1)
1869                  (code-location-debug-fun obj2))
1870              (sub-compiled-code-location= obj1 obj2)))
1871        ;; (There used to be more cases back before sbcl-0.7.0,,
1872        ;; when we did special tricks to debug the IR1
1873        ;; interpreter.)
1874        ))
1875     ;; (There used to be more cases back before sbcl-0.7.0,,
1876     ;; when we did special tricks to debug IR1-interpreted code.)
1877     ))
1878 (defun sub-compiled-code-location= (obj1 obj2)
1879   (= (compiled-code-location-pc obj1)
1880      (compiled-code-location-pc obj2)))
1881
1882 ;;; Fill in CODE-LOCATION's :UNPARSED slots, returning T or NIL
1883 ;;; depending on whether the code-location was known in its
1884 ;;; DEBUG-FUN's debug-block information. This may signal a
1885 ;;; NO-DEBUG-BLOCKS condition due to DEBUG-FUN-DEBUG-BLOCKS, and
1886 ;;; it assumes the %UNKNOWN-P slot is already set or going to be set.
1887 (defun fill-in-code-location (code-location)
1888   (declare (type compiled-code-location code-location))
1889   (let* ((debug-fun (code-location-debug-fun code-location))
1890          (blocks (debug-fun-debug-blocks debug-fun)))
1891     (declare (simple-vector blocks))
1892     (dotimes (i (length blocks) nil)
1893       (let* ((block (svref blocks i))
1894              (locations (compiled-debug-block-code-locations block)))
1895         (declare (simple-vector locations))
1896         (dotimes (j (length locations))
1897           (let ((loc (svref locations j)))
1898             (when (sub-compiled-code-location= code-location loc)
1899               (setf (code-location-%debug-block code-location) block)
1900               (setf (code-location-%tlf-offset code-location)
1901                     (code-location-%tlf-offset loc))
1902               (setf (code-location-%form-number code-location)
1903                     (code-location-%form-number loc))
1904               (setf (compiled-code-location-%live-set code-location)
1905                     (compiled-code-location-%live-set loc))
1906               (setf (compiled-code-location-kind code-location)
1907                     (compiled-code-location-kind loc))
1908               (return-from fill-in-code-location t))))))))
1909 \f
1910 ;;;; operations on DEBUG-BLOCKs
1911
1912 ;;; Execute FORMS in a context with CODE-VAR bound to each
1913 ;;; CODE-LOCATION in DEBUG-BLOCK, and return the value of RESULT.
1914 (defmacro do-debug-block-locations ((code-var debug-block &optional result)
1915                                     &body body)
1916   (let ((code-locations (gensym))
1917         (i (gensym)))
1918     `(let ((,code-locations (debug-block-code-locations ,debug-block)))
1919        (declare (simple-vector ,code-locations))
1920        (dotimes (,i (length ,code-locations) ,result)
1921          (let ((,code-var (svref ,code-locations ,i)))
1922            ,@body)))))
1923
1924 ;;; Return the name of the function represented by DEBUG-FUN.
1925 ;;; This may be a string or a cons; do not assume it is a symbol.
1926 (defun debug-block-fun-name (debug-block)
1927   (etypecase debug-block
1928     (compiled-debug-block
1929      (let ((code-locs (compiled-debug-block-code-locations debug-block)))
1930        (declare (simple-vector code-locs))
1931        (if (zerop (length code-locs))
1932            "??? Can't get name of debug-block's function."
1933            (debug-fun-name
1934             (code-location-debug-fun (svref code-locs 0))))))
1935     ;; (There used to be more cases back before sbcl-0.7.0, when we
1936     ;; did special tricks to debug the IR1 interpreter.)
1937     ))
1938
1939 (defun debug-block-code-locations (debug-block)
1940   (etypecase debug-block
1941     (compiled-debug-block
1942      (compiled-debug-block-code-locations debug-block))
1943     ;; (There used to be more cases back before sbcl-0.7.0, when we
1944     ;; did special tricks to debug the IR1 interpreter.)
1945     ))
1946 \f
1947 ;;;; operations on debug variables
1948
1949 (defun debug-var-symbol-name (debug-var)
1950   (symbol-name (debug-var-symbol debug-var)))
1951
1952 ;;; FIXME: Make sure that this isn't called anywhere that it wouldn't
1953 ;;; be acceptable to have NIL returned, or that it's only called on
1954 ;;; DEBUG-VARs whose symbols have non-NIL packages.
1955 (defun debug-var-package-name (debug-var)
1956   (package-name (symbol-package (debug-var-symbol debug-var))))
1957
1958 ;;; Return the value stored for DEBUG-VAR in frame, or if the value is
1959 ;;; not :VALID, then signal an INVALID-VALUE error.
1960 (defun debug-var-valid-value (debug-var frame)
1961   (unless (eq (debug-var-validity debug-var (frame-code-location frame))
1962               :valid)
1963     (error 'invalid-value :debug-var debug-var :frame frame))
1964   (debug-var-value debug-var frame))
1965
1966 ;;; Returns the value stored for DEBUG-VAR in frame. The value may be
1967 ;;; invalid. This is SETFable.
1968 (defun debug-var-value (debug-var frame)
1969   (aver (typep frame 'compiled-frame))
1970   (let ((res (access-compiled-debug-var-slot debug-var frame)))
1971     (if (indirect-value-cell-p res)
1972         (value-cell-ref res)
1973         res)))
1974
1975 ;;; This returns what is stored for the variable represented by
1976 ;;; DEBUG-VAR relative to the FRAME. This may be an indirect value
1977 ;;; cell if the variable is both closed over and set.
1978 (defun access-compiled-debug-var-slot (debug-var frame)
1979   (declare (optimize (speed 1)))
1980   (let ((escaped (compiled-frame-escaped frame)))
1981     (if escaped
1982         (sub-access-debug-var-slot
1983          (frame-pointer frame)
1984          (compiled-debug-var-sc-offset debug-var)
1985          escaped)
1986       (sub-access-debug-var-slot
1987        (frame-pointer frame)
1988        (or (compiled-debug-var-save-sc-offset debug-var)
1989            (compiled-debug-var-sc-offset debug-var))))))
1990
1991 ;;; a helper function for working with possibly-invalid values:
1992 ;;; Do (MAKE-LISP-OBJ VAL) only if the value looks valid.
1993 ;;;
1994 ;;; (Such values can arise in registers on machines with conservative
1995 ;;; GC, and might also arise in debug variable locations when
1996 ;;; those variables are invalid.)
1997 (defun make-valid-lisp-obj (val)
1998   (if (or
1999        ;; fixnum
2000        (zerop (logand val 3))
2001        ;; character
2002        (and (zerop (logand val #xffff0000)) ; Top bits zero
2003             (= (logand val #xff) sb!vm:base-char-widetag)) ; char tag
2004        ;; unbound marker
2005        (= val sb!vm:unbound-marker-widetag)
2006        ;; pointer
2007        (and (logand val 1)
2008             ;; Check that the pointer is valid. XXX Could do a better
2009             ;; job. FIXME: e.g. by calling out to an is_valid_pointer
2010             ;; routine in the C runtime support code
2011             (or (< sb!vm:read-only-space-start val
2012                    (* sb!vm:*read-only-space-free-pointer*
2013                       sb!vm:n-word-bytes))
2014                 (< sb!vm:static-space-start val
2015                    (* sb!vm:*static-space-free-pointer*
2016                       sb!vm:n-word-bytes))
2017                 (< sb!vm:dynamic-space-start val
2018                    (sap-int (dynamic-space-free-pointer))))))
2019       (make-lisp-obj val)
2020       :invalid-object))
2021
2022 #!-x86
2023 (defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
2024   (macrolet ((with-escaped-value ((var) &body forms)
2025                `(if escaped
2026                     (let ((,var (sb!vm:context-register
2027                                  escaped
2028                                  (sb!c:sc-offset-offset sc-offset))))
2029                       ,@forms)
2030                     :invalid-value-for-unescaped-register-storage))
2031              (escaped-float-value (format)
2032                `(if escaped
2033                     (sb!vm:context-float-register
2034                      escaped
2035                      (sb!c:sc-offset-offset sc-offset)
2036                      ',format)
2037                     :invalid-value-for-unescaped-register-storage))
2038              (with-nfp ((var) &body body)
2039                `(let ((,var (if escaped
2040                                 (sb!sys:int-sap
2041                                  (sb!vm:context-register escaped
2042                                                          sb!vm::nfp-offset))
2043                                 #!-alpha
2044                                 (sb!sys:sap-ref-sap fp (* nfp-save-offset
2045                                                           sb!vm:n-word-bytes))
2046                                 #!+alpha
2047                                 (sb!vm::make-number-stack-pointer
2048                                  (sb!sys:sap-ref-32 fp (* nfp-save-offset
2049                                                           sb!vm:n-word-bytes))))))
2050                   ,@body)))
2051     (ecase (sb!c:sc-offset-scn sc-offset)
2052       ((#.sb!vm:any-reg-sc-number
2053         #.sb!vm:descriptor-reg-sc-number
2054         #!+rt #.sb!vm:word-pointer-reg-sc-number)
2055        (sb!sys:without-gcing
2056         (with-escaped-value (val) (sb!kernel:make-lisp-obj val))))
2057                             
2058       (#.sb!vm:base-char-reg-sc-number
2059        (with-escaped-value (val)
2060          (code-char val)))
2061       (#.sb!vm:sap-reg-sc-number
2062        (with-escaped-value (val)
2063          (sb!sys:int-sap val)))
2064       (#.sb!vm:signed-reg-sc-number
2065        (with-escaped-value (val)
2066          (if (logbitp (1- sb!vm:n-word-bits) val)
2067              (logior val (ash -1 sb!vm:n-word-bits))
2068              val)))
2069       (#.sb!vm:unsigned-reg-sc-number
2070        (with-escaped-value (val)
2071          val))
2072       (#.sb!vm:non-descriptor-reg-sc-number
2073        (error "Local non-descriptor register access?"))
2074       (#.sb!vm:interior-reg-sc-number
2075        (error "Local interior register access?"))
2076       (#.sb!vm:single-reg-sc-number
2077        (escaped-float-value single-float))
2078       (#.sb!vm:double-reg-sc-number
2079        (escaped-float-value double-float))
2080       #!+long-float
2081       (#.sb!vm:long-reg-sc-number
2082        (escaped-float-value long-float))
2083       (#.sb!vm:complex-single-reg-sc-number
2084        (if escaped
2085            (complex
2086             (sb!vm:context-float-register
2087              escaped (sb!c:sc-offset-offset sc-offset) 'single-float)
2088             (sb!vm:context-float-register
2089              escaped (1+ (sb!c:sc-offset-offset sc-offset)) 'single-float))
2090            :invalid-value-for-unescaped-register-storage))
2091       (#.sb!vm:complex-double-reg-sc-number
2092        (if escaped
2093            (complex
2094             (sb!vm:context-float-register
2095              escaped (sb!c:sc-offset-offset sc-offset) 'double-float)
2096             (sb!vm:context-float-register
2097              escaped (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 2 #!-sparc 1)
2098              'double-float))
2099            :invalid-value-for-unescaped-register-storage))
2100       #!+long-float
2101       (#.sb!vm:complex-long-reg-sc-number
2102        (if escaped
2103            (complex
2104             (sb!vm:context-float-register
2105              escaped (sb!c:sc-offset-offset sc-offset) 'long-float)
2106             (sb!vm:context-float-register
2107              escaped (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4)
2108              'long-float))
2109            :invalid-value-for-unescaped-register-storage))
2110       (#.sb!vm:single-stack-sc-number
2111        (with-nfp (nfp)
2112          (sb!sys:sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset)
2113                                        sb!vm:n-word-bytes))))
2114       (#.sb!vm:double-stack-sc-number
2115        (with-nfp (nfp)
2116          (sb!sys:sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset)
2117                                        sb!vm:n-word-bytes))))
2118       #!+long-float
2119       (#.sb!vm:long-stack-sc-number
2120        (with-nfp (nfp)
2121          (sb!sys:sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset)
2122                                      sb!vm:n-word-bytes))))
2123       (#.sb!vm:complex-single-stack-sc-number
2124        (with-nfp (nfp)
2125          (complex
2126           (sb!sys:sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset)
2127                                         sb!vm:n-word-bytes))
2128           (sb!sys:sap-ref-single nfp (* (1+ (sb!c:sc-offset-offset sc-offset))
2129                                         sb!vm:n-word-bytes)))))
2130       (#.sb!vm:complex-double-stack-sc-number
2131        (with-nfp (nfp)
2132          (complex
2133           (sb!sys:sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset)
2134                                         sb!vm:n-word-bytes))
2135           (sb!sys:sap-ref-double nfp (* (+ (sb!c:sc-offset-offset sc-offset) 2)
2136                                         sb!vm:n-word-bytes)))))
2137       #!+long-float
2138       (#.sb!vm:complex-long-stack-sc-number
2139        (with-nfp (nfp)
2140          (complex
2141           (sb!sys:sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset)
2142                                       sb!vm:n-word-bytes))
2143           (sb!sys:sap-ref-long nfp (* (+ (sb!c:sc-offset-offset sc-offset)
2144                                          #!+sparc 4)
2145                                       sb!vm:n-word-bytes)))))
2146       (#.sb!vm:control-stack-sc-number
2147        (sb!kernel:stack-ref fp (sb!c:sc-offset-offset sc-offset)))
2148       (#.sb!vm:base-char-stack-sc-number
2149        (with-nfp (nfp)
2150          (code-char (sb!sys:sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
2151                                               sb!vm:n-word-bytes)))))
2152       (#.sb!vm:unsigned-stack-sc-number
2153        (with-nfp (nfp)
2154          (sb!sys:sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
2155                                    sb!vm:n-word-bytes))))
2156       (#.sb!vm:signed-stack-sc-number
2157        (with-nfp (nfp)
2158          (sb!sys:signed-sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
2159                                           sb!vm:n-word-bytes))))
2160       (#.sb!vm:sap-stack-sc-number
2161        (with-nfp (nfp)
2162          (sb!sys:sap-ref-sap nfp (* (sb!c:sc-offset-offset sc-offset)
2163                                     sb!vm:n-word-bytes)))))))
2164
2165 #!+x86
2166 (defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
2167   (declare (type system-area-pointer fp))
2168   (macrolet ((with-escaped-value ((var) &body forms)
2169                `(if escaped
2170                     (let ((,var (sb!vm:context-register
2171                                  escaped
2172                                  (sb!c:sc-offset-offset sc-offset))))
2173                       ,@forms)
2174                     :invalid-value-for-unescaped-register-storage))
2175              (escaped-float-value (format)
2176                `(if escaped
2177                     (sb!vm:context-float-register
2178                      escaped (sb!c:sc-offset-offset sc-offset) ',format)
2179                     :invalid-value-for-unescaped-register-storage))
2180              (escaped-complex-float-value (format)
2181                `(if escaped
2182                     (complex
2183                      (sb!vm:context-float-register
2184                       escaped (sb!c:sc-offset-offset sc-offset) ',format)
2185                      (sb!vm:context-float-register
2186                       escaped (1+ (sb!c:sc-offset-offset sc-offset)) ',format))
2187                     :invalid-value-for-unescaped-register-storage)))
2188     (ecase (sb!c:sc-offset-scn sc-offset)
2189       ((#.sb!vm:any-reg-sc-number #.sb!vm:descriptor-reg-sc-number)
2190        (without-gcing
2191         (with-escaped-value (val)
2192           (make-valid-lisp-obj val))))
2193       (#.sb!vm:base-char-reg-sc-number
2194        (with-escaped-value (val)
2195          (code-char val)))
2196       (#.sb!vm:sap-reg-sc-number
2197        (with-escaped-value (val)
2198          (int-sap val)))
2199       (#.sb!vm:signed-reg-sc-number
2200        (with-escaped-value (val)
2201          (if (logbitp (1- sb!vm:n-word-bits) val)
2202              (logior val (ash -1 sb!vm:n-word-bits))
2203              val)))
2204       (#.sb!vm:unsigned-reg-sc-number
2205        (with-escaped-value (val)
2206          val))
2207       (#.sb!vm:single-reg-sc-number
2208        (escaped-float-value single-float))
2209       (#.sb!vm:double-reg-sc-number
2210        (escaped-float-value double-float))
2211       #!+long-float
2212       (#.sb!vm:long-reg-sc-number
2213        (escaped-float-value long-float))
2214       (#.sb!vm:complex-single-reg-sc-number
2215        (escaped-complex-float-value single-float))
2216       (#.sb!vm:complex-double-reg-sc-number
2217        (escaped-complex-float-value double-float))
2218       #!+long-float
2219       (#.sb!vm:complex-long-reg-sc-number
2220        (escaped-complex-float-value long-float))
2221       (#.sb!vm:single-stack-sc-number
2222        (sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2223                                 sb!vm:n-word-bytes))))
2224       (#.sb!vm:double-stack-sc-number
2225        (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
2226                                 sb!vm:n-word-bytes))))
2227       #!+long-float
2228       (#.sb!vm:long-stack-sc-number
2229        (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
2230                               sb!vm:n-word-bytes))))
2231       (#.sb!vm:complex-single-stack-sc-number
2232        (complex
2233         (sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2234                                  sb!vm:n-word-bytes)))
2235         (sap-ref-single fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
2236                                  sb!vm:n-word-bytes)))))
2237       (#.sb!vm:complex-double-stack-sc-number
2238        (complex
2239         (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
2240                                  sb!vm:n-word-bytes)))
2241         (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 4)
2242                                  sb!vm:n-word-bytes)))))
2243       #!+long-float
2244       (#.sb!vm:complex-long-stack-sc-number
2245        (complex
2246         (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
2247                                sb!vm:n-word-bytes)))
2248         (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 6)
2249                                sb!vm:n-word-bytes)))))
2250       (#.sb!vm:control-stack-sc-number
2251        (stack-ref fp (sb!c:sc-offset-offset sc-offset)))
2252       (#.sb!vm:base-char-stack-sc-number
2253        (code-char
2254         (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2255                              sb!vm:n-word-bytes)))))
2256       (#.sb!vm:unsigned-stack-sc-number
2257        (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2258                             sb!vm:n-word-bytes))))
2259       (#.sb!vm:signed-stack-sc-number
2260        (signed-sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2261                                    sb!vm:n-word-bytes))))
2262       (#.sb!vm:sap-stack-sc-number
2263        (sap-ref-sap fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2264                              sb!vm:n-word-bytes)))))))
2265
2266 ;;; This stores value as the value of DEBUG-VAR in FRAME. In the
2267 ;;; COMPILED-DEBUG-VAR case, access the current value to determine if
2268 ;;; it is an indirect value cell. This occurs when the variable is
2269 ;;; both closed over and set.
2270 (defun %set-debug-var-value (debug-var frame new-value)
2271   (aver (typep frame 'compiled-frame))
2272   (let ((old-value (access-compiled-debug-var-slot debug-var frame)))
2273     (if (indirect-value-cell-p old-value)
2274         (value-cell-set old-value new-value)
2275         (set-compiled-debug-var-slot debug-var frame new-value)))
2276   new-value)
2277
2278 ;;; This stores VALUE for the variable represented by debug-var
2279 ;;; relative to the frame. This assumes the location directly contains
2280 ;;; the variable's value; that is, there is no indirect value cell
2281 ;;; currently there in case the variable is both closed over and set.
2282 (defun set-compiled-debug-var-slot (debug-var frame value)
2283   (let ((escaped (compiled-frame-escaped frame)))
2284     (if escaped
2285         (sub-set-debug-var-slot (frame-pointer frame)
2286                                 (compiled-debug-var-sc-offset debug-var)
2287                                 value escaped)
2288         (sub-set-debug-var-slot
2289          (frame-pointer frame)
2290          (or (compiled-debug-var-save-sc-offset debug-var)
2291              (compiled-debug-var-sc-offset debug-var))
2292          value))))
2293
2294 #!-x86
2295 (defun sub-set-debug-var-slot (fp sc-offset value &optional escaped)
2296   (macrolet ((set-escaped-value (val)
2297                `(if escaped
2298                     (setf (sb!vm:context-register
2299                            escaped
2300                            (sb!c:sc-offset-offset sc-offset))
2301                           ,val)
2302                     value))
2303              (set-escaped-float-value (format val)
2304                `(if escaped
2305                     (setf (sb!vm:context-float-register
2306                            escaped
2307                            (sb!c:sc-offset-offset sc-offset)
2308                            ',format)
2309                           ,val)
2310                     value))
2311              (with-nfp ((var) &body body)
2312                `(let ((,var (if escaped
2313                                 (int-sap
2314                                  (sb!vm:context-register escaped
2315                                                          sb!vm::nfp-offset))
2316                                 #!-alpha
2317                                 (sap-ref-sap fp
2318                                              (* nfp-save-offset
2319                                                 sb!vm:n-word-bytes))
2320                                 #!+alpha
2321                                 (sb!vm::make-number-stack-pointer
2322                                  (sap-ref-32 fp
2323                                              (* nfp-save-offset
2324                                                 sb!vm:n-word-bytes))))))
2325                   ,@body)))
2326     (ecase (sb!c:sc-offset-scn sc-offset)
2327       ((#.sb!vm:any-reg-sc-number
2328         #.sb!vm:descriptor-reg-sc-number
2329         #!+rt #.sb!vm:word-pointer-reg-sc-number)
2330        (without-gcing
2331         (set-escaped-value
2332           (get-lisp-obj-address value))))
2333       (#.sb!vm:base-char-reg-sc-number
2334        (set-escaped-value (char-code value)))
2335       (#.sb!vm:sap-reg-sc-number
2336        (set-escaped-value (sap-int value)))
2337       (#.sb!vm:signed-reg-sc-number
2338        (set-escaped-value (logand value (1- (ash 1 sb!vm:n-word-bits)))))
2339       (#.sb!vm:unsigned-reg-sc-number
2340        (set-escaped-value value))
2341       (#.sb!vm:non-descriptor-reg-sc-number
2342        (error "Local non-descriptor register access?"))
2343       (#.sb!vm:interior-reg-sc-number
2344        (error "Local interior register access?"))
2345       (#.sb!vm:single-reg-sc-number
2346        (set-escaped-float-value single-float value))
2347       (#.sb!vm:double-reg-sc-number
2348        (set-escaped-float-value double-float value))
2349       #!+long-float
2350       (#.sb!vm:long-reg-sc-number
2351        (set-escaped-float-value long-float value))
2352       (#.sb!vm:complex-single-reg-sc-number
2353        (when escaped
2354          (setf (sb!vm:context-float-register escaped
2355                                              (sb!c:sc-offset-offset sc-offset)
2356                                              'single-float)
2357                (realpart value))
2358          (setf (sb!vm:context-float-register
2359                 escaped (1+ (sb!c:sc-offset-offset sc-offset))
2360                 'single-float)
2361                (imagpart value)))
2362        value)
2363       (#.sb!vm:complex-double-reg-sc-number
2364        (when escaped
2365          (setf (sb!vm:context-float-register
2366                 escaped (sb!c:sc-offset-offset sc-offset) 'double-float)
2367                (realpart value))
2368          (setf (sb!vm:context-float-register
2369                 escaped
2370                 (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 2 #!-sparc 1)
2371                 'double-float)
2372                (imagpart value)))
2373        value)
2374       #!+long-float
2375       (#.sb!vm:complex-long-reg-sc-number
2376        (when escaped
2377          (setf (sb!vm:context-float-register
2378                 escaped (sb!c:sc-offset-offset sc-offset) 'long-float)
2379                (realpart value))
2380          (setf (sb!vm:context-float-register
2381                 escaped
2382                 (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4)
2383                 'long-float)
2384                (imagpart value)))
2385        value)
2386       (#.sb!vm:single-stack-sc-number
2387        (with-nfp (nfp)
2388          (setf (sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset)
2389                                       sb!vm:n-word-bytes))
2390                (the single-float value))))
2391       (#.sb!vm:double-stack-sc-number
2392        (with-nfp (nfp)
2393          (setf (sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset)
2394                                       sb!vm:n-word-bytes))
2395                (the double-float value))))
2396       #!+long-float
2397       (#.sb!vm:long-stack-sc-number
2398        (with-nfp (nfp)
2399          (setf (sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset)
2400                                     sb!vm:n-word-bytes))
2401                (the long-float value))))
2402       (#.sb!vm:complex-single-stack-sc-number
2403        (with-nfp (nfp)
2404          (setf (sap-ref-single
2405                 nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes))
2406                (the single-float (realpart value)))
2407          (setf (sap-ref-single
2408                 nfp (* (1+ (sb!c:sc-offset-offset sc-offset))
2409                        sb!vm:n-word-bytes))
2410                (the single-float (realpart value)))))
2411       (#.sb!vm:complex-double-stack-sc-number
2412        (with-nfp (nfp)
2413          (setf (sap-ref-double
2414                 nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes))
2415                (the double-float (realpart value)))
2416          (setf (sap-ref-double
2417                 nfp (* (+ (sb!c:sc-offset-offset sc-offset) 2)
2418                        sb!vm:n-word-bytes))
2419                (the double-float (realpart value)))))
2420       #!+long-float
2421       (#.sb!vm:complex-long-stack-sc-number
2422        (with-nfp (nfp)
2423          (setf (sap-ref-long
2424                 nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes))
2425                (the long-float (realpart value)))
2426          (setf (sap-ref-long
2427                 nfp (* (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4)
2428                        sb!vm:n-word-bytes))
2429                (the long-float (realpart value)))))
2430       (#.sb!vm:control-stack-sc-number
2431        (setf (stack-ref fp (sb!c:sc-offset-offset sc-offset)) value))
2432       (#.sb!vm:base-char-stack-sc-number
2433        (with-nfp (nfp)
2434          (setf (sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
2435                                          sb!vm:n-word-bytes))
2436                (char-code (the character value)))))
2437       (#.sb!vm:unsigned-stack-sc-number
2438        (with-nfp (nfp)
2439          (setf (sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
2440                                   sb!vm:n-word-bytes))
2441                (the (unsigned-byte 32) value))))
2442       (#.sb!vm:signed-stack-sc-number
2443        (with-nfp (nfp)
2444          (setf (signed-sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
2445                                          sb!vm:n-word-bytes))
2446                (the (signed-byte 32) value))))
2447       (#.sb!vm:sap-stack-sc-number
2448        (with-nfp (nfp)
2449          (setf (sap-ref-sap nfp (* (sb!c:sc-offset-offset sc-offset)
2450                                    sb!vm:n-word-bytes))
2451                (the system-area-pointer value)))))))
2452
2453 #!+x86
2454 (defun sub-set-debug-var-slot (fp sc-offset value &optional escaped)
2455   (macrolet ((set-escaped-value (val)
2456                `(if escaped
2457                     (setf (sb!vm:context-register
2458                            escaped
2459                            (sb!c:sc-offset-offset sc-offset))
2460                           ,val)
2461                     value)))
2462     (ecase (sb!c:sc-offset-scn sc-offset)
2463       ((#.sb!vm:any-reg-sc-number #.sb!vm:descriptor-reg-sc-number)
2464        (without-gcing
2465         (set-escaped-value
2466           (get-lisp-obj-address value))))
2467       (#.sb!vm:base-char-reg-sc-number
2468        (set-escaped-value (char-code value)))
2469       (#.sb!vm:sap-reg-sc-number
2470        (set-escaped-value (sap-int value)))
2471       (#.sb!vm:signed-reg-sc-number
2472        (set-escaped-value (logand value (1- (ash 1 sb!vm:n-word-bits)))))
2473       (#.sb!vm:unsigned-reg-sc-number
2474        (set-escaped-value value))
2475       (#.sb!vm:single-reg-sc-number
2476         #+nil ;; don't have escaped floats.
2477        (set-escaped-float-value single-float value))
2478       (#.sb!vm:double-reg-sc-number
2479         #+nil ;;  don't have escaped floats -- still in npx?
2480        (set-escaped-float-value double-float value))
2481       #!+long-float
2482       (#.sb!vm:long-reg-sc-number
2483         #+nil ;;  don't have escaped floats -- still in npx?
2484        (set-escaped-float-value long-float value))
2485       (#.sb!vm:single-stack-sc-number
2486        (setf (sap-ref-single
2487               fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2488                        sb!vm:n-word-bytes)))
2489              (the single-float value)))
2490       (#.sb!vm:double-stack-sc-number
2491        (setf (sap-ref-double
2492               fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
2493                        sb!vm:n-word-bytes)))
2494              (the double-float value)))
2495       #!+long-float
2496       (#.sb!vm:long-stack-sc-number
2497        (setf (sap-ref-long
2498               fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
2499                        sb!vm:n-word-bytes)))
2500              (the long-float value)))
2501       (#.sb!vm:complex-single-stack-sc-number
2502        (setf (sap-ref-single
2503               fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2504                        sb!vm:n-word-bytes)))
2505              (realpart (the (complex single-float) value)))
2506        (setf (sap-ref-single
2507               fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
2508                        sb!vm:n-word-bytes)))
2509              (imagpart (the (complex single-float) value))))
2510       (#.sb!vm:complex-double-stack-sc-number
2511        (setf (sap-ref-double
2512               fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
2513                        sb!vm:n-word-bytes)))
2514              (realpart (the (complex double-float) value)))
2515        (setf (sap-ref-double
2516               fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 4)
2517                        sb!vm:n-word-bytes)))
2518              (imagpart (the (complex double-float) value))))
2519       #!+long-float
2520       (#.sb!vm:complex-long-stack-sc-number
2521        (setf (sap-ref-long
2522               fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
2523                        sb!vm:n-word-bytes)))
2524              (realpart (the (complex long-float) value)))
2525        (setf (sap-ref-long
2526               fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 6)
2527                        sb!vm:n-word-bytes)))
2528              (imagpart (the (complex long-float) value))))
2529       (#.sb!vm:control-stack-sc-number
2530        (setf (stack-ref fp (sb!c:sc-offset-offset sc-offset)) value))
2531       (#.sb!vm:base-char-stack-sc-number
2532        (setf (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2533                                          sb!vm:n-word-bytes)))
2534              (char-code (the character value))))
2535       (#.sb!vm:unsigned-stack-sc-number
2536        (setf (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2537                                          sb!vm:n-word-bytes)))
2538              (the (unsigned-byte 32) value)))
2539       (#.sb!vm:signed-stack-sc-number
2540        (setf (signed-sap-ref-32
2541               fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2542                        sb!vm:n-word-bytes)))
2543              (the (signed-byte 32) value)))
2544       (#.sb!vm:sap-stack-sc-number
2545        (setf (sap-ref-sap fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
2546                                           sb!vm:n-word-bytes)))
2547              (the system-area-pointer value))))))
2548
2549 ;;; The method for setting and accessing COMPILED-DEBUG-VAR values use
2550 ;;; this to determine if the value stored is the actual value or an
2551 ;;; indirection cell.
2552 (defun indirect-value-cell-p (x)
2553   (and (= (lowtag-of x) sb!vm:other-pointer-lowtag)
2554        (= (widetag-of x) sb!vm:value-cell-header-widetag)))
2555
2556 ;;; Return three values reflecting the validity of DEBUG-VAR's value
2557 ;;; at BASIC-CODE-LOCATION:
2558 ;;;   :VALID    The value is known to be available.
2559 ;;;   :INVALID  The value is known to be unavailable.
2560 ;;;   :UNKNOWN  The value's availability is unknown.
2561 ;;;
2562 ;;; If the variable is always alive, then it is valid. If the
2563 ;;; code-location is unknown, then the variable's validity is
2564 ;;; :unknown. Once we've called CODE-LOCATION-UNKNOWN-P, we know the
2565 ;;; live-set information has been cached in the code-location.
2566 (defun debug-var-validity (debug-var basic-code-location)
2567   (etypecase debug-var
2568     (compiled-debug-var
2569      (compiled-debug-var-validity debug-var basic-code-location))
2570     ;; (There used to be more cases back before sbcl-0.7.0, when
2571     ;; we did special tricks to debug the IR1 interpreter.)
2572     ))
2573
2574 ;;; This is the method for DEBUG-VAR-VALIDITY for COMPILED-DEBUG-VARs.
2575 ;;; For safety, make sure basic-code-location is what we think.
2576 (defun compiled-debug-var-validity (debug-var basic-code-location)
2577   (declare (type compiled-code-location basic-code-location))
2578   (cond ((debug-var-alive-p debug-var)
2579          (let ((debug-fun (code-location-debug-fun basic-code-location)))
2580            (if (>= (compiled-code-location-pc basic-code-location)
2581                    (sb!c::compiled-debug-fun-start-pc
2582                     (compiled-debug-fun-compiler-debug-fun debug-fun)))
2583                :valid
2584                :invalid)))
2585         ((code-location-unknown-p basic-code-location) :unknown)
2586         (t
2587          (let ((pos (position debug-var
2588                               (debug-fun-debug-vars
2589                                (code-location-debug-fun
2590                                 basic-code-location)))))
2591            (unless pos
2592              (error 'unknown-debug-var
2593                     :debug-var debug-var
2594                     :debug-fun
2595                     (code-location-debug-fun basic-code-location)))
2596            ;; There must be live-set info since basic-code-location is known.
2597            (if (zerop (sbit (compiled-code-location-live-set
2598                              basic-code-location)
2599                             pos))
2600                :invalid
2601                :valid)))))
2602 \f
2603 ;;;; sources
2604
2605 ;;; This code produces and uses what we call source-paths. A
2606 ;;; source-path is a list whose first element is a form number as
2607 ;;; returned by CODE-LOCATION-FORM-NUMBER and whose last element is a
2608 ;;; top level form number as returned by
2609 ;;; CODE-LOCATION-TOPLEVEL-FORM-NUMBER. The elements from the last to
2610 ;;; the first, exclusively, are the numbered subforms into which to
2611 ;;; descend. For example:
2612 ;;;    (defun foo (x)
2613 ;;;      (let ((a (aref x 3)))
2614 ;;;     (cons a 3)))
2615 ;;; The call to AREF in this example is form number 5. Assuming this
2616 ;;; DEFUN is the 11'th top level form, the source-path for the AREF
2617 ;;; call is as follows:
2618 ;;;    (5 1 0 1 3 11)
2619 ;;; Given the DEFUN, 3 gets you the LET, 1 gets you the bindings, 0
2620 ;;; gets the first binding, and 1 gets the AREF form.
2621
2622 ;;; temporary buffer used to build form-number => source-path translation in
2623 ;;; FORM-NUMBER-TRANSLATIONS
2624 (defvar *form-number-temp* (make-array 10 :fill-pointer 0 :adjustable t))
2625
2626 ;;; table used to detect CAR circularities in FORM-NUMBER-TRANSLATIONS
2627 (defvar *form-number-circularity-table* (make-hash-table :test 'eq))
2628
2629 ;;; This returns a table mapping form numbers to source-paths. A
2630 ;;; source-path indicates a descent into the TOPLEVEL-FORM form,
2631 ;;; going directly to the subform corressponding to the form number.
2632 ;;;
2633 ;;; The vector elements are in the same format as the compiler's
2634 ;;; NODE-SOURCE-PATH; that is, the first element is the form number and
2635 ;;; the last is the TOPLEVEL-FORM number.
2636 (defun form-number-translations (form tlf-number)
2637   (clrhash *form-number-circularity-table*)
2638   (setf (fill-pointer *form-number-temp*) 0)
2639   (sub-translate-form-numbers form (list tlf-number))
2640   (coerce *form-number-temp* 'simple-vector))
2641 (defun sub-translate-form-numbers (form path)
2642   (unless (gethash form *form-number-circularity-table*)
2643     (setf (gethash form *form-number-circularity-table*) t)
2644     (vector-push-extend (cons (fill-pointer *form-number-temp*) path)
2645                         *form-number-temp*)
2646     (let ((pos 0)
2647           (subform form)
2648           (trail form))
2649       (declare (fixnum pos))
2650       (macrolet ((frob ()
2651                    '(progn
2652                       (when (atom subform) (return))
2653                       (let ((fm (car subform)))
2654                         (when (consp fm)
2655                           (sub-translate-form-numbers fm (cons pos path)))
2656                         (incf pos))
2657                       (setq subform (cdr subform))
2658                       (when (eq subform trail) (return)))))
2659         (loop
2660           (frob)
2661           (frob)
2662           (setq trail (cdr trail)))))))
2663
2664 ;;; FORM is a top level form, and path is a source-path into it. This
2665 ;;; returns the form indicated by the source-path. Context is the
2666 ;;; number of enclosing forms to return instead of directly returning
2667 ;;; the source-path form. When context is non-zero, the form returned
2668 ;;; contains a marker, #:****HERE****, immediately before the form
2669 ;;; indicated by path.
2670 (defun source-path-context (form path context)
2671   (declare (type unsigned-byte context))
2672   ;; Get to the form indicated by path or the enclosing form indicated
2673   ;; by context and path.
2674   (let ((path (reverse (butlast (cdr path)))))
2675     (dotimes (i (- (length path) context))
2676       (let ((index (first path)))
2677         (unless (and (listp form) (< index (length form)))
2678           (error "Source path no longer exists."))
2679         (setq form (elt form index))
2680         (setq path (rest path))))
2681     ;; Recursively rebuild the source form resulting from the above
2682     ;; descent, copying the beginning of each subform up to the next
2683     ;; subform we descend into according to path. At the bottom of the
2684     ;; recursion, we return the form indicated by path preceded by our
2685     ;; marker, and this gets spliced into the resulting list structure
2686     ;; on the way back up.
2687     (labels ((frob (form path level)
2688                (if (or (zerop level) (null path))
2689                    (if (zerop context)
2690                        form
2691                        `(#:***here*** ,form))
2692                    (let ((n (first path)))
2693                      (unless (and (listp form) (< n (length form)))
2694                        (error "Source path no longer exists."))
2695                      (let ((res (frob (elt form n) (rest path) (1- level))))
2696                        (nconc (subseq form 0 n)
2697                               (cons res (nthcdr (1+ n) form))))))))
2698       (frob form path context))))
2699 \f
2700 ;;;; PREPROCESS-FOR-EVAL
2701
2702 ;;; Return a function of one argument that evaluates form in the
2703 ;;; lexical context of the BASIC-CODE-LOCATION LOC, or signal a
2704 ;;; NO-DEBUG-VARS condition when the LOC's DEBUG-FUN has no
2705 ;;; DEBUG-VAR information available.
2706 ;;;
2707 ;;; The returned function takes the frame to get values from as its
2708 ;;; argument, and it returns the values of FORM. The returned function
2709 ;;; can signal the following conditions: INVALID-VALUE,
2710 ;;; AMBIGUOUS-VAR-NAME, and FRAME-FUN-MISMATCH.
2711 (defun preprocess-for-eval (form loc)
2712   (declare (type code-location loc))
2713   (let ((n-frame (gensym))
2714         (fun (code-location-debug-fun loc)))
2715     (unless (debug-var-info-available fun)
2716       (debug-signal 'no-debug-vars :debug-fun fun))
2717     (sb!int:collect ((binds)
2718                      (specs))
2719       (do-debug-fun-vars (var fun)
2720         (let ((validity (debug-var-validity var loc)))
2721           (unless (eq validity :invalid)
2722             (let* ((sym (debug-var-symbol var))
2723                    (found (assoc sym (binds))))
2724               (if found
2725                   (setf (second found) :ambiguous)
2726                   (binds (list sym validity var)))))))
2727       (dolist (bind (binds))
2728         (let ((name (first bind))
2729               (var (third bind)))
2730           (ecase (second bind)
2731             (:valid
2732              (specs `(,name (debug-var-value ',var ,n-frame))))
2733             (:unknown
2734              (specs `(,name (debug-signal 'invalid-value
2735                                           :debug-var ',var
2736                                           :frame ,n-frame))))
2737             (:ambiguous
2738              (specs `(,name (debug-signal 'ambiguous-var-name
2739                                           :name ',name
2740                                           :frame ,n-frame)))))))
2741       (let ((res (coerce `(lambda (,n-frame)
2742                             (declare (ignorable ,n-frame))
2743                             (symbol-macrolet ,(specs) ,form))
2744                          'function)))
2745         (lambda (frame)
2746           ;; This prevents these functions from being used in any
2747           ;; location other than a function return location, so maybe
2748           ;; this should only check whether FRAME's DEBUG-FUN is the
2749           ;; same as LOC's.
2750           (unless (code-location= (frame-code-location frame) loc)
2751             (debug-signal 'frame-fun-mismatch
2752                           :code-location loc :form form :frame frame))
2753           (funcall res frame))))))
2754 \f
2755 ;;;; breakpoints
2756
2757 ;;;; user-visible interface
2758
2759 ;;; Create and return a breakpoint. When program execution encounters
2760 ;;; the breakpoint, the system calls HOOK-FUN. HOOK-FUN takes the
2761 ;;; current frame for the function in which the program is running and
2762 ;;; the breakpoint object.
2763 ;;;
2764 ;;; WHAT and KIND determine where in a function the system invokes
2765 ;;; HOOK-FUN. WHAT is either a code-location or a DEBUG-FUN. KIND is
2766 ;;; one of :CODE-LOCATION, :FUN-START, or :FUN-END. Since the starts
2767 ;;; and ends of functions may not have code-locations representing
2768 ;;; them, designate these places by supplying WHAT as a DEBUG-FUN and
2769 ;;; KIND indicating the :FUN-START or :FUN-END. When WHAT is a
2770 ;;; DEBUG-FUN and kind is :FUN-END, then HOOK-FUN must take two
2771 ;;; additional arguments, a list of values returned by the function
2772 ;;; and a FUN-END-COOKIE.
2773 ;;;
2774 ;;; INFO is information supplied by and used by the user.
2775 ;;;
2776 ;;; FUN-END-COOKIE is a function. To implement :FUN-END
2777 ;;; breakpoints, the system uses starter breakpoints to establish the
2778 ;;; :FUN-END breakpoint for each invocation of the function. Upon
2779 ;;; each entry, the system creates a unique cookie to identify the
2780 ;;; invocation, and when the user supplies a function for this
2781 ;;; argument, the system invokes it on the frame and the cookie. The
2782 ;;; system later invokes the :FUN-END breakpoint hook on the same
2783 ;;; cookie. The user may save the cookie for comparison in the hook
2784 ;;; function.
2785 ;;;
2786 ;;; Signal an error if WHAT is an unknown code-location.
2787 (defun make-breakpoint (hook-fun what
2788                         &key (kind :code-location) info fun-end-cookie)
2789   (etypecase what
2790     (code-location
2791      (when (code-location-unknown-p what)
2792        (error "cannot make a breakpoint at an unknown code location: ~S"
2793               what))
2794      (aver (eq kind :code-location))
2795      (let ((bpt (%make-breakpoint hook-fun what kind info)))
2796        (etypecase what
2797          (compiled-code-location
2798           ;; This slot is filled in due to calling CODE-LOCATION-UNKNOWN-P.
2799           (when (eq (compiled-code-location-kind what) :unknown-return)
2800             (let ((other-bpt (%make-breakpoint hook-fun what
2801                                                :unknown-return-partner
2802                                                info)))
2803               (setf (breakpoint-unknown-return-partner bpt) other-bpt)
2804               (setf (breakpoint-unknown-return-partner other-bpt) bpt))))
2805          ;; (There used to be more cases back before sbcl-0.7.0,,
2806          ;; when we did special tricks to debug the IR1
2807          ;; interpreter.)
2808          )
2809        bpt))
2810     (compiled-debug-fun
2811      (ecase kind
2812        (:fun-start
2813         (%make-breakpoint hook-fun what kind info))
2814        (:fun-end
2815         (unless (eq (sb!c::compiled-debug-fun-returns
2816                      (compiled-debug-fun-compiler-debug-fun what))
2817                     :standard)
2818           (error ":FUN-END breakpoints are currently unsupported ~
2819                   for the known return convention."))
2820
2821         (let* ((bpt (%make-breakpoint hook-fun what kind info))
2822                (starter (compiled-debug-fun-end-starter what)))
2823           (unless starter
2824             (setf starter (%make-breakpoint #'list what :fun-start nil))
2825             (setf (breakpoint-hook-fun starter)
2826                   (fun-end-starter-hook starter what))
2827             (setf (compiled-debug-fun-end-starter what) starter))
2828           (setf (breakpoint-start-helper bpt) starter)
2829           (push bpt (breakpoint-%info starter))
2830           (setf (breakpoint-cookie-fun bpt) fun-end-cookie)
2831           bpt))))))
2832
2833 ;;; These are unique objects created upon entry into a function by a
2834 ;;; :FUN-END breakpoint's starter hook. These are only created
2835 ;;; when users supply :FUN-END-COOKIE to MAKE-BREAKPOINT. Also,
2836 ;;; the :FUN-END breakpoint's hook is called on the same cookie
2837 ;;; when it is created.
2838 (defstruct (fun-end-cookie
2839             (:print-object (lambda (obj str)
2840                              (print-unreadable-object (obj str :type t))))
2841             (:constructor make-fun-end-cookie (bogus-lra debug-fun))
2842             (:copier nil))
2843   ;; a pointer to the bogus-lra created for :FUN-END breakpoints
2844   bogus-lra
2845   ;; the DEBUG-FUN associated with this cookie
2846   debug-fun)
2847
2848 ;;; This maps bogus-lra-components to cookies, so that
2849 ;;; HANDLE-FUN-END-BREAKPOINT can find the appropriate cookie for the
2850 ;;; breakpoint hook.
2851 (defvar *fun-end-cookies* (make-hash-table :test 'eq))
2852
2853 ;;; This returns a hook function for the start helper breakpoint
2854 ;;; associated with a :FUN-END breakpoint. The returned function
2855 ;;; makes a fake LRA that all returns go through, and this piece of
2856 ;;; fake code actually breaks. Upon return from the break, the code
2857 ;;; provides the returnee with any values. Since the returned function
2858 ;;; effectively activates FUN-END-BPT on each entry to DEBUG-FUN's
2859 ;;; function, we must establish breakpoint-data about FUN-END-BPT.
2860 (defun fun-end-starter-hook (starter-bpt debug-fun)
2861   (declare (type breakpoint starter-bpt)
2862            (type compiled-debug-fun debug-fun))
2863   (lambda (frame breakpoint)
2864     (declare (ignore breakpoint)
2865              (type frame frame))
2866     (let ((lra-sc-offset
2867            (sb!c::compiled-debug-fun-return-pc
2868             (compiled-debug-fun-compiler-debug-fun debug-fun))))
2869       (multiple-value-bind (lra component offset)
2870           (make-bogus-lra
2871            (get-context-value frame
2872                               lra-save-offset
2873                               lra-sc-offset))
2874         (setf (get-context-value frame
2875                                  lra-save-offset
2876                                  lra-sc-offset)
2877               lra)
2878         (let ((end-bpts (breakpoint-%info starter-bpt)))
2879           (let ((data (breakpoint-data component offset)))
2880             (setf (breakpoint-data-breakpoints data) end-bpts)
2881             (dolist (bpt end-bpts)
2882               (setf (breakpoint-internal-data bpt) data)))
2883           (let ((cookie (make-fun-end-cookie lra debug-fun)))
2884             (setf (gethash component *fun-end-cookies*) cookie)
2885             (dolist (bpt end-bpts)
2886               (let ((fun (breakpoint-cookie-fun bpt)))
2887                 (when fun (funcall fun frame cookie))))))))))
2888
2889 ;;; This takes a FUN-END-COOKIE and a frame, and it returns
2890 ;;; whether the cookie is still valid. A cookie becomes invalid when
2891 ;;; the frame that established the cookie has exited. Sometimes cookie
2892 ;;; holders are unaware of cookie invalidation because their
2893 ;;; :FUN-END breakpoint hooks didn't run due to THROW'ing.
2894 ;;;
2895 ;;; This takes a frame as an efficiency hack since the user probably
2896 ;;; has a frame object in hand when using this routine, and it saves
2897 ;;; repeated parsing of the stack and consing when asking whether a
2898 ;;; series of cookies is valid.
2899 (defun fun-end-cookie-valid-p (frame cookie)
2900   (let ((lra (fun-end-cookie-bogus-lra cookie))
2901         (lra-sc-offset (sb!c::compiled-debug-fun-return-pc
2902                         (compiled-debug-fun-compiler-debug-fun
2903                          (fun-end-cookie-debug-fun cookie)))))
2904     (do ((frame frame (frame-down frame)))
2905         ((not frame) nil)
2906       (when (and (compiled-frame-p frame)
2907                  (#!-x86 eq #!+x86 sap=
2908                   lra
2909                   (get-context-value frame lra-save-offset lra-sc-offset)))
2910         (return t)))))
2911 \f
2912 ;;;; ACTIVATE-BREAKPOINT
2913
2914 ;;; Cause the system to invoke the breakpoint's hook function until
2915 ;;; the next call to DEACTIVATE-BREAKPOINT or DELETE-BREAKPOINT. The
2916 ;;; system invokes breakpoint hook functions in the opposite order
2917 ;;; that you activate them.
2918 (defun activate-breakpoint (breakpoint)
2919   (when (eq (breakpoint-status breakpoint) :deleted)
2920     (error "cannot activate a deleted breakpoint: ~S" breakpoint))
2921   (unless (eq (breakpoint-status breakpoint) :active)
2922     (ecase (breakpoint-kind breakpoint)
2923       (:code-location
2924        (let ((loc (breakpoint-what breakpoint)))
2925          (etypecase loc
2926            (compiled-code-location
2927             (activate-compiled-code-location-breakpoint breakpoint)
2928             (let ((other (breakpoint-unknown-return-partner breakpoint)))
2929               (when other
2930                 (activate-compiled-code-location-breakpoint other))))
2931            ;; (There used to be more cases back before sbcl-0.7.0, when
2932            ;; we did special tricks to debug the IR1 interpreter.)
2933            )))
2934       (:fun-start
2935        (etypecase (breakpoint-what breakpoint)
2936          (compiled-debug-fun
2937           (activate-compiled-fun-start-breakpoint breakpoint))
2938          ;; (There used to be more cases back before sbcl-0.7.0, when
2939          ;; we did special tricks to debug the IR1 interpreter.)
2940          ))
2941       (:fun-end
2942        (etypecase (breakpoint-what breakpoint)
2943          (compiled-debug-fun
2944           (let ((starter (breakpoint-start-helper breakpoint)))
2945             (unless (eq (breakpoint-status starter) :active)
2946               ;; may already be active by some other :FUN-END breakpoint
2947               (activate-compiled-fun-start-breakpoint starter)))
2948           (setf (breakpoint-status breakpoint) :active))
2949          ;; (There used to be more cases back before sbcl-0.7.0, when
2950          ;; we did special tricks to debug the IR1 interpreter.)
2951          ))))
2952   breakpoint)
2953
2954 (defun activate-compiled-code-location-breakpoint (breakpoint)
2955   (declare (type breakpoint breakpoint))
2956   (let ((loc (breakpoint-what breakpoint)))
2957     (declare (type compiled-code-location loc))
2958     (sub-activate-breakpoint
2959      breakpoint
2960      (breakpoint-data (compiled-debug-fun-component
2961                        (code-location-debug-fun loc))
2962                       (+ (compiled-code-location-pc loc)
2963                          (if (or (eq (breakpoint-kind breakpoint)
2964                                      :unknown-return-partner)
2965                                  (eq (compiled-code-location-kind loc)
2966                                      :single-value-return))
2967                              sb!vm:single-value-return-byte-offset
2968                              0))))))
2969
2970 (defun activate-compiled-fun-start-breakpoint (breakpoint)
2971   (declare (type breakpoint breakpoint))
2972   (let ((debug-fun (breakpoint-what breakpoint)))
2973     (sub-activate-breakpoint
2974      breakpoint
2975      (breakpoint-data (compiled-debug-fun-component debug-fun)
2976                       (sb!c::compiled-debug-fun-start-pc
2977                        (compiled-debug-fun-compiler-debug-fun
2978                         debug-fun))))))
2979
2980 (defun sub-activate-breakpoint (breakpoint data)
2981   (declare (type breakpoint breakpoint)
2982            (type breakpoint-data data))
2983   (setf (breakpoint-status breakpoint) :active)
2984   (without-interrupts
2985    (unless (breakpoint-data-breakpoints data)
2986      (setf (breakpoint-data-instruction data)
2987            (without-gcing
2988             (breakpoint-install (get-lisp-obj-address
2989                                  (breakpoint-data-component data))
2990                                 (breakpoint-data-offset data)))))
2991    (setf (breakpoint-data-breakpoints data)
2992          (append (breakpoint-data-breakpoints data) (list breakpoint)))
2993    (setf (breakpoint-internal-data breakpoint) data)))
2994 \f
2995 ;;;; DEACTIVATE-BREAKPOINT
2996
2997 ;;; Stop the system from invoking the breakpoint's hook function.
2998 (defun deactivate-breakpoint (breakpoint)
2999   (when (eq (breakpoint-status breakpoint) :active)
3000     (without-interrupts
3001      (let ((loc (breakpoint-what breakpoint)))
3002        (etypecase loc
3003          ((or compiled-code-location compiled-debug-fun)
3004           (deactivate-compiled-breakpoint breakpoint)
3005           (let ((other (breakpoint-unknown-return-partner breakpoint)))
3006             (when other
3007               (deactivate-compiled-breakpoint other))))
3008          ;; (There used to be more cases back before sbcl-0.7.0, when
3009          ;; we did special tricks to debug the IR1 interpreter.)
3010          ))))
3011   breakpoint)
3012
3013 (defun deactivate-compiled-breakpoint (breakpoint)
3014   (if (eq (breakpoint-kind breakpoint) :fun-end)
3015       (let ((starter (breakpoint-start-helper breakpoint)))
3016         (unless (find-if (lambda (bpt)
3017                            (and (not (eq bpt breakpoint))
3018                                 (eq (breakpoint-status bpt) :active)))
3019                          (breakpoint-%info starter))
3020           (deactivate-compiled-breakpoint starter)))
3021       (let* ((data (breakpoint-internal-data breakpoint))
3022              (bpts (delete breakpoint (breakpoint-data-breakpoints data))))
3023         (setf (breakpoint-internal-data breakpoint) nil)
3024         (setf (breakpoint-data-breakpoints data) bpts)
3025         (unless bpts
3026           (without-gcing
3027            (breakpoint-remove (get-lisp-obj-address
3028                                (breakpoint-data-component data))
3029                               (breakpoint-data-offset data)
3030                               (breakpoint-data-instruction data)))
3031           (delete-breakpoint-data data))))
3032   (setf (breakpoint-status breakpoint) :inactive)
3033   breakpoint)
3034 \f
3035 ;;;; BREAKPOINT-INFO
3036
3037 ;;; Return the user-maintained info associated with breakpoint. This
3038 ;;; is SETF'able.
3039 (defun breakpoint-info (breakpoint)
3040   (breakpoint-%info breakpoint))
3041 (defun %set-breakpoint-info (breakpoint value)
3042   (setf (breakpoint-%info breakpoint) value)
3043   (let ((other (breakpoint-unknown-return-partner breakpoint)))
3044     (when other
3045       (setf (breakpoint-%info other) value))))
3046 \f
3047 ;;;; BREAKPOINT-ACTIVE-P and DELETE-BREAKPOINT
3048
3049 (defun breakpoint-active-p (breakpoint)
3050   (ecase (breakpoint-status breakpoint)
3051     (:active t)
3052     ((:inactive :deleted) nil)))
3053
3054 ;;; Free system storage and remove computational overhead associated
3055 ;;; with breakpoint. After calling this, breakpoint is completely
3056 ;;; impotent and can never become active again.
3057 (defun delete-breakpoint (breakpoint)
3058   (let ((status (breakpoint-status breakpoint)))
3059     (unless (eq status :deleted)
3060       (when (eq status :active)
3061         (deactivate-breakpoint breakpoint))
3062       (setf (breakpoint-status breakpoint) :deleted)
3063       (let ((other (breakpoint-unknown-return-partner breakpoint)))
3064         (when other
3065           (setf (breakpoint-status other) :deleted)))
3066       (when (eq (breakpoint-kind breakpoint) :fun-end)
3067         (let* ((starter (breakpoint-start-helper breakpoint))
3068                (breakpoints (delete breakpoint
3069                                     (the list (breakpoint-info starter)))))
3070           (setf (breakpoint-info starter) breakpoints)
3071           (unless breakpoints
3072             (delete-breakpoint starter)
3073             (setf (compiled-debug-fun-end-starter
3074                    (breakpoint-what breakpoint))
3075                   nil))))))
3076   breakpoint)
3077 \f
3078 ;;;; C call out stubs
3079
3080 ;;; This actually installs the break instruction in the component. It
3081 ;;; returns the overwritten bits. You must call this in a context in
3082 ;;; which GC is disabled, so that Lisp doesn't move objects around
3083 ;;; that C is pointing to.
3084 (sb!alien:define-alien-routine "breakpoint_install" sb!alien:unsigned-long
3085   (code-obj sb!alien:unsigned-long)
3086   (pc-offset sb!alien:int))
3087
3088 ;;; This removes the break instruction and replaces the original
3089 ;;; instruction. You must call this in a context in which GC is disabled
3090 ;;; so Lisp doesn't move objects around that C is pointing to.
3091 (sb!alien:define-alien-routine "breakpoint_remove" sb!alien:void
3092   (code-obj sb!alien:unsigned-long)
3093   (pc-offset sb!alien:int)
3094   (old-inst sb!alien:unsigned-long))
3095
3096 (sb!alien:define-alien-routine "breakpoint_do_displaced_inst" sb!alien:void
3097   (scp (* os-context-t))
3098   (orig-inst sb!alien:unsigned-long))
3099
3100 ;;;; breakpoint handlers (layer between C and exported interface)
3101
3102 ;;; This maps components to a mapping of offsets to BREAKPOINT-DATAs.
3103 (defvar *component-breakpoint-offsets* (make-hash-table :test 'eq))
3104
3105 ;;; This returns the BREAKPOINT-DATA object associated with component cross
3106 ;;; offset. If none exists, this makes one, installs it, and returns it.
3107 (defun breakpoint-data (component offset &optional (create t))
3108   (flet ((install-breakpoint-data ()
3109            (when create
3110              (let ((data (make-breakpoint-data component offset)))
3111                (push (cons offset data)
3112                      (gethash component *component-breakpoint-offsets*))
3113                data))))
3114     (let ((offsets (gethash component *component-breakpoint-offsets*)))
3115       (if offsets
3116           (let ((data (assoc offset offsets)))
3117             (if data
3118                 (cdr data)
3119                 (install-breakpoint-data)))
3120           (install-breakpoint-data)))))
3121
3122 ;;; We use this when there are no longer any active breakpoints
3123 ;;; corresponding to DATA.
3124 (defun delete-breakpoint-data (data)
3125   (let* ((component (breakpoint-data-component data))
3126          (offsets (delete (breakpoint-data-offset data)
3127                           (gethash component *component-breakpoint-offsets*)
3128                           :key #'car)))
3129     (if offsets
3130         (setf (gethash component *component-breakpoint-offsets*) offsets)
3131         (remhash component *component-breakpoint-offsets*)))
3132   (values))
3133
3134 ;;; The C handler for interrupts calls this when it has a
3135 ;;; debugging-tool break instruction. This does *not* handle all
3136 ;;; breaks; for example, it does not handle breaks for internal
3137 ;;; errors.
3138 (defun handle-breakpoint (offset component signal-context)
3139   (let ((data (breakpoint-data component offset nil)))
3140     (unless data
3141       (error "unknown breakpoint in ~S at offset ~S"
3142               (debug-fun-name (debug-fun-from-pc component offset))
3143               offset))
3144     (let ((breakpoints (breakpoint-data-breakpoints data)))
3145       (if (or (null breakpoints)
3146               (eq (breakpoint-kind (car breakpoints)) :fun-end))
3147           (handle-fun-end-breakpoint-aux breakpoints data signal-context)
3148           (handle-breakpoint-aux breakpoints data
3149                                  offset component signal-context)))))
3150
3151 ;;; This holds breakpoint-datas while invoking the breakpoint hooks
3152 ;;; associated with that particular component and location. While they
3153 ;;; are executing, if we hit the location again, we ignore the
3154 ;;; breakpoint to avoid infinite recursion. fun-end breakpoints
3155 ;;; must work differently since the breakpoint-data is unique for each
3156 ;;; invocation.
3157 (defvar *executing-breakpoint-hooks* nil)
3158
3159 ;;; This handles code-location and DEBUG-FUN :FUN-START
3160 ;;; breakpoints.
3161 (defun handle-breakpoint-aux (breakpoints data offset component signal-context)
3162   (unless breakpoints
3163     (bug "breakpoint that nobody wants"))
3164   (unless (member data *executing-breakpoint-hooks*)
3165     (let ((*executing-breakpoint-hooks* (cons data
3166                                               *executing-breakpoint-hooks*)))
3167       (invoke-breakpoint-hooks breakpoints component offset)))
3168   ;; At this point breakpoints may not hold the same list as
3169   ;; BREAKPOINT-DATA-BREAKPOINTS since invoking hooks may have allowed
3170   ;; a breakpoint deactivation. In fact, if all breakpoints were
3171   ;; deactivated then data is invalid since it was deleted and so the
3172   ;; correct one must be looked up if it is to be used. If there are
3173   ;; no more breakpoints active at this location, then the normal
3174   ;; instruction has been put back, and we do not need to
3175   ;; DO-DISPLACED-INST.
3176   (let ((data (breakpoint-data component offset nil)))
3177     (when (and data (breakpoint-data-breakpoints data))
3178       ;; The breakpoint is still active, so we need to execute the
3179       ;; displaced instruction and leave the breakpoint instruction
3180       ;; behind. The best way to do this is different on each machine,
3181       ;; so we just leave it up to the C code.
3182       (breakpoint-do-displaced-inst signal-context
3183                                     (breakpoint-data-instruction data))
3184       ;; Some platforms have no usable sigreturn() call.  If your
3185       ;; implementation of arch_do_displaced_inst() _does_ sigreturn(),
3186       ;; it's polite to warn here
3187       #!+(and sparc solaris)
3188       (error "BREAKPOINT-DO-DISPLACED-INST returned?"))))
3189
3190 (defun invoke-breakpoint-hooks (breakpoints component offset)
3191   (let* ((debug-fun (debug-fun-from-pc component offset))
3192          (frame (do ((f (top-frame) (frame-down f)))
3193                     ((eq debug-fun (frame-debug-fun f)) f))))
3194     (dolist (bpt breakpoints)
3195       (funcall (breakpoint-hook-fun bpt)
3196                frame
3197                ;; If this is an :UNKNOWN-RETURN-PARTNER, then pass the
3198                ;; hook function the original breakpoint, so that users
3199                ;; aren't forced to confront the fact that some
3200                ;; breakpoints really are two.
3201                (if (eq (breakpoint-kind bpt) :unknown-return-partner)
3202                    (breakpoint-unknown-return-partner bpt)
3203                    bpt)))))
3204
3205 (defun handle-fun-end-breakpoint (offset component context)
3206   (let ((data (breakpoint-data component offset nil)))
3207     (unless data
3208       (error "unknown breakpoint in ~S at offset ~S"
3209               (debug-fun-name (debug-fun-from-pc component offset))
3210               offset))
3211     (let ((breakpoints (breakpoint-data-breakpoints data)))
3212       (when breakpoints
3213         (aver (eq (breakpoint-kind (car breakpoints)) :fun-end))
3214         (handle-fun-end-breakpoint-aux breakpoints data context)))))
3215
3216 ;;; Either HANDLE-BREAKPOINT calls this for :FUN-END breakpoints
3217 ;;; [old C code] or HANDLE-FUN-END-BREAKPOINT calls this directly
3218 ;;; [new C code].
3219 (defun handle-fun-end-breakpoint-aux (breakpoints data signal-context)
3220   (delete-breakpoint-data data)
3221   (let* ((scp
3222           (locally
3223             (declare (optimize (inhibit-warnings 3)))
3224             (sb!alien:sap-alien signal-context (* os-context-t))))
3225          (frame (do ((cfp (sb!vm:context-register scp sb!vm::cfp-offset))
3226                      (f (top-frame) (frame-down f)))
3227                     ((= cfp (sap-int (frame-pointer f))) f)
3228                   (declare (type (unsigned-byte #.sb!vm:n-word-bits) cfp))))
3229          (component (breakpoint-data-component data))
3230          (cookie (gethash component *fun-end-cookies*)))
3231     (remhash component *fun-end-cookies*)
3232     (dolist (bpt breakpoints)
3233       (funcall (breakpoint-hook-fun bpt)
3234                frame bpt
3235                (get-fun-end-breakpoint-values scp)
3236                cookie))))
3237
3238 (defun get-fun-end-breakpoint-values (scp)
3239   (let ((ocfp (int-sap (sb!vm:context-register
3240                         scp
3241                         #!-x86 sb!vm::ocfp-offset
3242                         #!+x86 sb!vm::ebx-offset)))
3243         (nargs (make-lisp-obj
3244                 (sb!vm:context-register scp sb!vm::nargs-offset)))
3245         (reg-arg-offsets '#.sb!vm::*register-arg-offsets*)
3246         (results nil))
3247     (without-gcing
3248      (dotimes (arg-num nargs)
3249        (push (if reg-arg-offsets
3250                  (make-lisp-obj
3251                   (sb!vm:context-register scp (pop reg-arg-offsets)))
3252                (stack-ref ocfp arg-num))
3253              results)))
3254     (nreverse results)))
3255 \f
3256 ;;;; MAKE-BOGUS-LRA (used for :FUN-END breakpoints)
3257
3258 (defconstant bogus-lra-constants
3259   #!-x86 2 #!+x86 3)
3260 (defconstant known-return-p-slot
3261   (+ sb!vm:code-constants-offset #!-x86 1 #!+x86 2))
3262
3263 ;;; Make a bogus LRA object that signals a breakpoint trap when
3264 ;;; returned to. If the breakpoint trap handler returns, REAL-LRA is
3265 ;;; returned to. Three values are returned: the bogus LRA object, the
3266 ;;; code component it is part of, and the PC offset for the trap
3267 ;;; instruction.
3268 (defun make-bogus-lra (real-lra &optional known-return-p)
3269   (without-gcing
3270    ;; These are really code labels, not variables: but this way we get
3271    ;; their addresses.
3272    (let* ((src-start (foreign-symbol-address "fun_end_breakpoint_guts"))
3273           (src-end (foreign-symbol-address "fun_end_breakpoint_end"))
3274           (trap-loc (foreign-symbol-address "fun_end_breakpoint_trap"))
3275           (length (sap- src-end src-start))
3276           (code-object
3277            (%primitive sb!c:allocate-code-object (1+ bogus-lra-constants)
3278                        length))
3279           (dst-start (code-instructions code-object)))
3280      (declare (type system-area-pointer
3281                     src-start src-end dst-start trap-loc)
3282               (type index length))
3283      (setf (%code-debug-info code-object) :bogus-lra)
3284      (setf (code-header-ref code-object sb!vm:code-trace-table-offset-slot)
3285            length)
3286      #!-x86
3287      (setf (code-header-ref code-object real-lra-slot) real-lra)
3288      #!+x86
3289      (multiple-value-bind (offset code) (compute-lra-data-from-pc real-lra)
3290        (setf (code-header-ref code-object real-lra-slot) code)
3291        (setf (code-header-ref code-object (1+ real-lra-slot)) offset))
3292      (setf (code-header-ref code-object known-return-p-slot)
3293            known-return-p)
3294      (system-area-copy src-start 0 dst-start 0 (* length sb!vm:n-byte-bits))
3295      (sb!vm:sanctify-for-execution code-object)
3296      #!+x86
3297      (values dst-start code-object (sap- trap-loc src-start))
3298      #!-x86
3299      (let ((new-lra (make-lisp-obj (+ (sap-int dst-start)
3300                                       sb!vm:other-pointer-lowtag))))
3301        (set-header-data
3302         new-lra
3303         (logandc2 (+ sb!vm:code-constants-offset bogus-lra-constants 1)
3304                   1))
3305        (sb!vm:sanctify-for-execution code-object)
3306        (values new-lra code-object (sap- trap-loc src-start))))))
3307 \f
3308 ;;;; miscellaneous
3309
3310 ;;; This appears here because it cannot go with the DEBUG-FUN
3311 ;;; interface since DO-DEBUG-BLOCK-LOCATIONS isn't defined until after
3312 ;;; the DEBUG-FUN routines.
3313
3314 ;;; Return a code-location before the body of a function and after all
3315 ;;; the arguments are in place; or if that location can't be
3316 ;;; determined due to a lack of debug information, return NIL.
3317 (defun debug-fun-start-location (debug-fun)
3318   (etypecase debug-fun
3319     (compiled-debug-fun
3320      (code-location-from-pc debug-fun
3321                             (sb!c::compiled-debug-fun-start-pc
3322                              (compiled-debug-fun-compiler-debug-fun
3323                               debug-fun))
3324                             nil))
3325     ;; (There used to be more cases back before sbcl-0.7.0, when
3326     ;; we did special tricks to debug the IR1 interpreter.)
3327     ))