debug-int.lisp 188 KB
Newer Older
1
;;; -*- Mode: Lisp; Log: code.log; Package: DI -*-
chiles's avatar
chiles committed
2
3
;;;
;;; **********************************************************************
4
5
6
7
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
8
  "$Header: /project/cmucl/cvsroot/src/code/debug-int.lisp,v 1.142 2010-07-14 23:08:59 rtoy Exp $")
9
;;;
chiles's avatar
chiles committed
10
11
12
13
14
;;; **********************************************************************
;;;
;;; This file contains the implementation of the programmer's interface
;;; to writing debugging tools.
;;;
chiles's avatar
   
chiles committed
15
;;; Written by Bill Chiles and Rob Maclachlan.
chiles's avatar
chiles committed
16
;;;
17
;;; X86 support by Douglas Crosher 1996,1997,1998.
chiles's avatar
chiles committed
18

ram's avatar
ram committed
19
(in-package "DEBUG-INTERNALS")
chiles's avatar
   
chiles committed
20

21
(intl:textdomain "cmucl")
chiles's avatar
chiles committed
22
23
24
25
26
27

;;; The compiler's debug-source structure is almost exactly what we want, so
;;; just get these symbols and export them.
;;;
(import '(c::debug-source-from c::debug-source-name c::debug-source-created
	  c::debug-source-compiled c::debug-source-start-positions
28
	  c::make-debug-source c::debug-source c::debug-source-p))
chiles's avatar
chiles committed
29
30
31
32
33

(export '(debug-variable-name debug-variable-package debug-variable-symbol
	  debug-variable-id debug-variable-value debug-variable-validity
	  debug-variable-valid-value debug-variable debug-variable-p

34
	  top-frame frame-down frame-up flush-frames-above frame-debug-function
chiles's avatar
chiles committed
35
	  frame-code-location eval-in-frame return-from-frame frame-catches
36
	  frame-number frame frame-p find-debug-tag-for-frame
chiles's avatar
chiles committed
37

chiles's avatar
   
chiles committed
38
39
40
41
42
43
	  do-debug-function-blocks debug-function-lambda-list
	  debug-variable-info-available do-debug-function-variables
	  debug-function-symbol-variables ambiguous-debug-variables
	  preprocess-for-eval function-debug-function debug-function-function
	  debug-function-kind debug-function-name debug-function
	  debug-function-p debug-function-start-location
chiles's avatar
chiles committed
44
45
46
47
48

	  do-debug-block-locations debug-block-successors debug-block
	  debug-block-p debug-block-elsewhere-p

	  make-breakpoint activate-breakpoint deactivate-breakpoint
chiles's avatar
   
chiles committed
49
50
	  breakpoint-active-p breakpoint-hook-function breakpoint-info
	  breakpoint-kind breakpoint-what breakpoint breakpoint-p
chiles's avatar
   
chiles committed
51
	  delete-breakpoint function-end-cookie-valid-p
chiles's avatar
chiles committed
52
53
54

	  code-location-debug-function code-location-debug-block
	  code-location-top-level-form-offset code-location-form-number
wlott's avatar
wlott committed
55
56
	  code-location-debug-source code-location-kind
	  code-location code-location-p code-location-unknown-p code-location=
chiles's avatar
chiles committed
57
58
59
60
61
62
63
64
65
66

	  debug-source-from debug-source-name debug-source-created
	  debug-source-compiled debug-source-root-number
	  debug-source-start-positions form-number-translations
	  source-path-context debug-source debug-source-p

	  debug-condition no-debug-info no-debug-function-returns
	  no-debug-blocks lambda-list-unavailable

	  debug-error unhandled-condition invalid-control-stack-pointer
67
68
69
	  unknown-code-location unknown-debug-variable invalid-value
	  ambiguous-variable-name frame-function-mismatch

chiles's avatar
   
chiles committed
70
71
72
	  set-breakpoint-for-editor set-location-breakpoint-for-editor
	  delete-breakpoint-for-editor

73
	  *debugging-interpreter*))
chiles's avatar
chiles committed
74
75
76
77
78
79
80
81
82
83
84
85
86



;;;; Conditions.

;;; The interface to building debugging tools signals conditions that prevent
;;; it from adhering to its contract.  These are serious-conditions because the
;;; program using the interface must handle them before it can correctly
;;; continue execution.  These debugging conditions are not errors since it is
;;; no fault of the programmers that the conditions occur.  The interface does
;;; not provide for programs to detect these situations other than calling a
;;; routine that detects them and signals a condition.  For example,
;;; programmers call A which may fail to return successfully due to a lack of
cwang's avatar
typo    
cwang committed
87
;;; debug information, and there is no B that they could have called to realize
chiles's avatar
chiles committed
88
89
90
91
92
93
94
95
96
97
98
;;; A would fail.  It is not an error to have called A, but it is an error for
;;; the program to then ignore the signal generated by A since it cannot
;;; continue without A's correctly returning a value or performing some
;;; operation.
;;;
;;; Use DEBUG-SIGNAL to signal these conditions.
;;;

(define-condition debug-condition (serious-condition)
  ()
  (:documentation
99
   _N"All debug-conditions inherit from this type.  These are serious conditions
chiles's avatar
chiles committed
100
101
102
103
    that must be handled, but they are not programmer errors."))

(define-condition no-debug-info (debug-condition)
  ()
104
  (:documentation _N"There is absolutely no debugging information available.")
chiles's avatar
chiles committed
105
106
  (:report (lambda (condition stream)
	     (declare (ignore condition))
chiles's avatar
   
chiles committed
107
	     (fresh-line stream)
108
	     (write-line (intl:gettext "No debugging information available.") stream))))
chiles's avatar
chiles committed
109
110

(define-condition no-debug-function-returns (debug-condition)
ram's avatar
ram committed
111
112
  ((debug-function :reader no-debug-function-returns-debug-function
		   :initarg :debug-function))
chiles's avatar
chiles committed
113
  (:documentation
114
115
   (intl:gettext "The system could not return values from a frame with debug-function since
    it lacked information about returning values."))
chiles's avatar
chiles committed
116
117
118
119
  (:report (lambda (condition stream)
	     (let ((fun (debug-function-function
			 (no-debug-function-returns-debug-function condition))))
	       (format stream
120
		       (intl:gettext "~&Cannot return values from ~:[frame~;~:*~S~] since ~
chiles's avatar
   
chiles committed
121
			the debug information lacks details about returning ~
122
			values here.")
chiles's avatar
chiles committed
123
124
125
		       fun)))))

(define-condition no-debug-blocks (debug-condition)
ram's avatar
ram committed
126
127
  ((debug-function :reader no-debug-blocks-debug-function
		   :initarg :debug-function))
128
  (:documentation _N"The debug-function has no debug-block information.")
chiles's avatar
chiles committed
129
  (:report (lambda (condition stream)
130
	     (format stream (intl:gettext "~&~S has no debug-block information.")
chiles's avatar
chiles committed
131
132
		     (no-debug-blocks-debug-function condition)))))

133
(define-condition no-debug-variables (debug-condition)
ram's avatar
ram committed
134
135
  ((debug-function :reader no-debug-variables-debug-function
		   :initarg :debug-function))
136
  (:documentation _N"The debug-function has no debug-variable information.")
137
  (:report (lambda (condition stream)
138
	     (format stream (intl:gettext "~&~S has no debug-variable information.")
139
140
		     (no-debug-variables-debug-function condition)))))

chiles's avatar
chiles committed
141
(define-condition lambda-list-unavailable (debug-condition)
ram's avatar
ram committed
142
143
  ((debug-function :reader lambda-list-unavailable-debug-function
		   :initarg :debug-function))
chiles's avatar
chiles committed
144
  (:documentation
145
   _N"The debug-function has no lambda-list since argument debug-variables are
chiles's avatar
chiles committed
146
147
    unavailable.")
  (:report (lambda (condition stream)
148
	     (format stream (intl:gettext "~&~S has no lambda-list information available.")
chiles's avatar
chiles committed
149
150
		     (lambda-list-unavailable-debug-function condition)))))

151
(define-condition invalid-value (debug-condition)
ram's avatar
ram committed
152
153
154
  ((debug-variable :reader invalid-value-debug-variable
		   :initarg :debug-variable)
   (frame :reader invalid-value-frame :initarg :frame))
155
  (:report (lambda (condition stream)
156
	     (format stream (intl:gettext "~&~S has :invalid or :unknown value in ~S.")
157
158
159
160
		     (invalid-value-debug-variable condition)
		     (invalid-value-frame condition)))))

(define-condition ambiguous-variable-name (debug-condition)
ram's avatar
ram committed
161
162
  ((name :reader ambiguous-variable-name-name :initarg :name)
   (frame :reader ambiguous-variable-name-frame :initarg :frame))
163
  (:report (lambda (condition stream)
164
	     (format stream (intl:gettext "~&~S names more than one valid variable in ~S.")
165
166
		     (ambiguous-variable-name-name condition)
		     (ambiguous-variable-name-frame condition)))))
chiles's avatar
chiles committed
167
168
169
170


;;;; Errors and DEBUG-SIGNAL.

chiles's avatar
   
chiles committed
171
172
;;; The debug-internals code tries to signal all programmer errors as subtypes
;;; of debug-error.  There are calls to ERROR signalling simple-errors, but
cwang's avatar
cwang committed
173
;;; these dummy checks in the code shouldn't come up.
chiles's avatar
chiles committed
174
175
176
177
178
179
180
;;;
;;; While under development, this code also signals errors in code branches
;;; that remain unimplemented.
;;;

(define-condition debug-error (error) ()
  (:documentation
181
   _N"All programmer errors from using the interface for building debugging
chiles's avatar
chiles committed
182
183
184
    tools inherit from this type."))

(define-condition unhandled-condition (debug-error)
ram's avatar
ram committed
185
  ((condition :reader unhandled-condition-condition :initarg :condition))
chiles's avatar
chiles committed
186
  (:report (lambda (condition stream)
187
	     (format stream (intl:gettext "~&Unhandled debug-condition:~%~A")
chiles's avatar
   
chiles committed
188
		     (unhandled-condition-condition condition)))))
chiles's avatar
chiles committed
189
190

(define-condition unknown-code-location (debug-error)
ram's avatar
ram committed
191
192
  ((code-location :reader unknown-code-location-code-location
		  :initarg :code-location))
chiles's avatar
chiles committed
193
  (:report (lambda (condition stream)
194
	     (format stream (intl:gettext "~&Invalid use of an unknown code-location -- ~S.")
chiles's avatar
chiles committed
195
196
197
		     (unknown-code-location-code-location condition)))))

(define-condition unknown-debug-variable (debug-error)
ram's avatar
ram committed
198
199
200
201
  ((debug-variable :reader unknown-debug-variable-debug-variable
		   :initarg :debug-variable)
   (debug-function :reader unknown-debug-variable-debug-function
		   :initarg :debug-function))
chiles's avatar
chiles committed
202
  (:report (lambda (condition stream)
203
	     (format stream (intl:gettext "~&~S not in ~S.")
chiles's avatar
chiles committed
204
205
206
		     (unknown-debug-variable-debug-variable condition)
		     (unknown-debug-variable-debug-function condition)))))

chiles's avatar
   
chiles committed
207
208
209
210
211
(define-condition invalid-control-stack-pointer (debug-error)
  ()
  (:report (lambda (condition stream)
	     (declare (ignore condition))
	     (fresh-line stream)
212
	     (write-string (intl:gettext "Invalid control stack pointer.") stream))))
chiles's avatar
   
chiles committed
213

214
(define-condition frame-function-mismatch (debug-error)
ram's avatar
ram committed
215
216
217
218
  ((code-location :reader frame-function-mismatch-code-location
		  :initarg :code-location)
   (frame :reader frame-function-mismatch-frame :initarg :frame)
   (form :reader frame-function-mismatch-form :initarg :form))
chiles's avatar
chiles committed
219
  (:report (lambda (condition stream)
220
	     (format stream
221
		     (intl:gettext "~&Form was preprocessed for ~S,~% but called on ~S:~%  ~S")
222
223
224
		     (frame-function-mismatch-code-location condition)
		     (frame-function-mismatch-frame condition)
		     (frame-function-mismatch-form condition)))))
chiles's avatar
chiles committed
225
226
227
228
229
230
231
232
233
234


;;; DEBUG-SIGNAL -- Internal.
;;;
;;; This signals debug-conditions.  If they go unhandled, then signal an
;;; unhandled-condition error.
;;;
;;; ??? Get SIGNAL in the right package!
;;;
(defmacro debug-signal (datum &rest arguments)
chiles's avatar
   
chiles committed
235
236
  `(let ((condition (make-condition ,datum ,@arguments)))
     (signal condition)
chiles's avatar
chiles committed
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
     (error 'unhandled-condition :condition condition)))



;;;; Structures.

;;; Most of these structures model information stored in internal data
;;; structures created by the compiler.  Whenever comments preface an object or
;;; type with "compiler", they refer to the internal compiler thing, not to the
;;; object or type with the same name in the "DI" package.
;;;


;;;
;;; Debug-variables
;;;

;;; These exist for caching data stored in packed binary form in compiler
;;; debug-functions.  Debug-functions store these.
;;;
chiles's avatar
   
chiles committed
257
258
(defstruct (debug-variable (:print-function print-debug-variable)
			   (:constructor nil))
chiles's avatar
chiles committed
259
260
261
262
263
264
265
266
267
268
269
270
  ;;
  ;; String name of variable.
  (name nil :type simple-string)
  ;;
  ;; String name of package.  Nil when variable's name is uninterned.
  (package nil :type (or null simple-string))
  ;;
  ;; Unique integer identification relative to other variables with the same
  ;; name and package.
  (id 0 :type c::index)
  ;;
  ;; Whether the variable always has a valid value.
271
  (alive-p nil :type boolean))
chiles's avatar
chiles committed
272
273
274

(defun print-debug-variable (obj str n)
  (declare (ignore n))
275
  (format str "#<Debug-Variable ~A:~A:~A>"
chiles's avatar
chiles committed
276
277
278
279
280
	  (debug-variable-package obj)
	  (debug-variable-name obj)
	  (debug-variable-id obj)))

(setf (documentation 'debug-variable-name 'function)
281
  _N"Returns the name of the debug-variable.  The name is the name of the symbol
chiles's avatar
chiles committed
282
283
284
   used as an identifier when writing the code.")

(setf (documentation 'debug-variable-package 'function)
285
  _N"Returns the package name of the debug-variable.  This is the package name of
chiles's avatar
chiles committed
286
287
288
   the symbol used as an identifier when writing the code.")

(setf (documentation 'debug-variable-id 'function)
289
  _N"Returns the integer that makes debug-variable's name and package name unique
chiles's avatar
chiles committed
290
291
   with respect to other debug-variable's in the same function.")

292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312

(defstruct (compiled-debug-variable
	    (:include debug-variable)
	    (:constructor make-compiled-debug-variable
			  (name package id alive-p sc-offset save-sc-offset)))
  ;;
  ;; Storage class and offset.  (unexported).
  (sc-offset nil :type c::sc-offset)
  ;;
  ;; Storage class and offset when saved somewhere.
  (save-sc-offset nil :type (or c::sc-offset null)))

(defstruct (interpreted-debug-variable
	    (:include debug-variable
		      (alive-p t))
	    (:constructor make-interpreted-debug-variable
			  (name package ir1-var)))
  ;;
  ;; This is the IR1 structure that holds information about interpreted vars.
  (ir1-var nil :type c::lambda-var))

chiles's avatar
chiles committed
313
314
315
316
;;;
;;; Frames
;;;

rtoy's avatar
rtoy committed
317
;;; These represent call-frames on the stack.
chiles's avatar
chiles committed
318
;;;
chiles's avatar
   
chiles committed
319
(defstruct (frame (:constructor nil))
chiles's avatar
chiles committed
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
  ;;
  ;; Next frame up.  Null when top frame.
  (up nil :type (or frame null))
  ;;
  ;; Previous frame down.  Nil when the bottom frame.  Before computing the
  ;; next frame down, this slot holds the frame pointer to the control stack
  ;; for the given frame.  This lets us get the next frame down and the
  ;; return-pc for that frame.
  (%down :unparsed :type (or frame (member nil :unparsed)))
  ;;
  ;; Debug-function for function whose call this frame represents.
  (debug-function nil :type debug-function)
  ;;
  ;; Code-location to continue upon return to frame.
  (code-location nil :type code-location)
  ;;
  ;; A-list of catch-tags to code-locations.
  (%catches :unparsed :type (or list (member :unparsed)))
  ;;
  ;; Pointer to frame on control stack.  (unexported)
340
341
  ;; When is an interpreted-frame, this is an index into the interpreter's
  ;; stack.
chiles's avatar
chiles committed
342
343
344
  pointer
  ;;
  ;; This is the frame's number for prompt printing.  Top is zero.
345
  (number 0 :type index))
chiles's avatar
chiles committed
346
347

(setf (documentation 'frame-up 'function)
348
  _N"Returns the frame immediately above frame on the stack.  When frame is
chiles's avatar
chiles committed
349
350
351
   the top of the stack, this returns nil.")

(setf (documentation 'frame-debug-function 'function)
352
  _N"Returns the debug-function for the function whose call frame represents.")
chiles's avatar
chiles committed
353
354

(setf (documentation 'frame-code-location 'function)
355
  _N"Returns the code-location where the frame's debug-function will continue
chiles's avatar
chiles committed
356
357
358
   running when program execution returns to this frame.  If someone
   interrupted this frame, the result could be an unknown code-location.")

359
360
361
362
363
364

(defstruct (compiled-frame
	    (:include frame)
	    (:print-function print-compiled-frame)
	    (:constructor make-compiled-frame
			  (pointer up debug-function code-location number
365
366
367
				   #+gengc saved-state-chain
				   &optional escaped)))
  ;;
368
  ;; Indicates whether someone interrupted frame.  (unexported).
369
370
371
  ;; If escaped, this is a pointer to the state that was saved when we were
  ;; interrupted.  On the non-gengc system, this is a sigcontext pointer.
  ;; On the gengc system, this is a state pointer from saved-state-chain.
372
373
374
375
376
377
  escaped
  ;;
  ;; List of saps to saved states.  Each time we unwind past an exception,
  ;; we pop the next entry off this list.  When we get to the end of the
  ;; list, there is nothing else on the stack.
  #+gengc (saved-state-chain nil :type list))
378
379
380

(defun print-compiled-frame (obj str n)
  (declare (ignore n))
381
  (format str (intl:gettext "#<Compiled-Frame ~S~:[~;, interrupted~]>")
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
	  (debug-function-name (frame-debug-function obj))
	  (compiled-frame-escaped obj)))


(defstruct (interpreted-frame
	    (:include frame)
	    (:print-function print-interpreted-frame)
	    (:constructor make-interpreted-frame
			  (pointer up debug-function code-location number
			   real-frame closure)))
  ;;
  ;; This points to the compiled-frame for EVAL:INTERNAL-APPLY-LOOP.
  (real-frame nil :type compiled-frame)
  ;;
  ;; This is the closed over data used by the interpreter.
  (closure nil :type simple-vector))

(defun print-interpreted-frame (obj str n)
  (declare (ignore n))
  (format str "#<Interpreted-Frame ~S>"
	  (debug-function-name (frame-debug-function obj))))

chiles's avatar
chiles committed
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
;;;
;;; Debug-functions
;;;

;;; These exist for caching data stored in packed binary form in compiler
;;; debug-functions.  *compiled-debug-functions* maps a c::debug-function to a
;;; debug-function.  There should only be one debug-function in existence for
;;; any function; that is, all code-locations and other objects that reference
;;; debug-functions point to unique objects.  This is due to the overhead in
;;; cached information.
;;;
(defstruct (debug-function (:print-function print-debug-function))
  ;;
  ;; Some representation of the function arguments.  See
  ;; DEBUG-FUNCTION-LAMBDA-LIST.
  ;; NOTE: must parse vars before parsing arg list stuff.
  (%lambda-list :unparsed)
  ;;
422
  ;; Cached debug-variable information.  (unexported).
chiles's avatar
chiles committed
423
  ;; These are sorted by their name.
424
  (debug-vars :unparsed :type (or simple-vector null (member :unparsed)))
chiles's avatar
chiles committed
425
  ;;
426
  ;; Cached debug-block information.  This is nil when we have tried to parse
chiles's avatar
chiles committed
427
428
429
430
431
432
433
434
  ;; the packed binary info, but none is available.
  (blocks :unparsed :type (or simple-vector null (member :unparsed)))
  ;;
  ;; The actual function if available.
  (%function :unparsed :type (or null function (member :unparsed))))

(defun print-debug-function (obj str n)
  (declare (ignore n))
435
  (format str (intl:gettext "#<~A-Debug-Function ~S>")
436
437
	  (etypecase obj
	    (compiled-debug-function "Compiled")
438
439
	    (interpreted-debug-function "Interpreted")
	    (bogus-debug-function "Bogus"))
440
	  (debug-function-name obj)))
chiles's avatar
chiles committed
441
442
443
444
445
446
447
448
449
450
451


(defstruct (compiled-debug-function
	    (:include debug-function)
	    (:constructor %make-compiled-debug-function
			  (compiler-debug-fun component)))
  ;;
  ;; Compiler's dumped debug-function information.  (unexported).
  (compiler-debug-fun nil :type c::compiled-debug-function)
  ;;
  ;; Code object.  (unexported).
452
453
454
455
456
  component
  ;;
  ;; The :function-start breakpoint (if any) used to facilitate function
  ;; end breakpoints.
  (end-starter nil :type (or null breakpoint)))
chiles's avatar
chiles committed
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476

;;; This maps c::compiled-debug-functions to compiled-debug-functions, so we
;;; can get at cached stuff and not duplicate compiled-debug-function
;;; structures.
;;;
(defvar *compiled-debug-functions* (make-hash-table :test #'eq))

;;; MAKE-COMPILED-DEBUG-FUNCTION -- Internal.
;;;
;;; Makes a compiled-debug-function for a c::compiler-debug-function and its
;;; component.  This maps the latter to the former in
;;; *compiled-debug-functions*.  If there already is a compiled-debug-function,
;;; then this returns it from *compiled-debug-functions*.
;;;
(defun make-compiled-debug-function (compiler-debug-fun component)
  (or (gethash compiler-debug-fun *compiled-debug-functions*)
      (setf (gethash compiler-debug-fun *compiled-debug-functions*)
	    (%make-compiled-debug-function compiler-debug-fun component))))


477
478
479
480
481
482
483
(defstruct (interpreted-debug-function
	    (:include debug-function)
	    (:constructor %make-interpreted-debug-function (ir1-lambda)))
  ;;
  ;; This is the ir1 lambda this debug-function represents.
  (ir1-lambda nil :type c::clambda))

wlott's avatar
wlott committed
484
485
486
487
488
489
490
(defstruct (bogus-debug-function
	    (:include debug-function)
	    (:constructor make-bogus-debug-function
			  (%name &aux (%lambda-list nil) (debug-vars nil)
				 (blocks nil) (%function nil))))
  %name)

491
492
493
494
495
496
497
(defvar *ir1-lambda-debug-function* (make-hash-table :test #'eq))

(defun make-interpreted-debug-function (ir1-lambda)
  (let ((home-lambda (c::lambda-home ir1-lambda)))
    (or (gethash home-lambda *ir1-lambda-debug-function*)
	(setf (gethash home-lambda *ir1-lambda-debug-function*)
	      (%make-interpreted-debug-function home-lambda)))))
chiles's avatar
chiles committed
498
499
500
501
502
503
504
505

;;;
;;; Debug-blocks.
;;;

;;; These exist for caching data stored in packed binary form in compiler
;;; debug-blocks.
;;;
506
(defstruct (debug-block (:print-function print-debug-block))
chiles's avatar
chiles committed
507
508
509
510
  ;;
  ;; Code-locations where execution continues after this block.
  (successors nil :type list)
  ;;
511
512
513
514
515
  ;; This indicates whether the block is a special glob of code shared by
  ;; various functions and tucked away elsewhere in a component.  This kind of
  ;; block has no start code-location.  In an interpreted-debug-block, this is
  ;; always nil.  This slot is in all debug-blocks since it is an exported
  ;; interface.
516
  (elsewhere-p nil :type boolean))
chiles's avatar
chiles committed
517
518
519

(defun print-debug-block (obj str n)
  (declare (ignore n))
520
521
522
523
  (format str "#<~A-Debug-Block ~S>"
	  (etypecase obj
	    (compiled-debug-block "Compiled")
	    (interpreted-debug-block "Interpreted"))
chiles's avatar
chiles committed
524
525
526
	  (debug-block-function-name obj)))

(setf (documentation 'debug-block-successors 'function)
527
  _N"Returns the list of possible code-locations where execution may continue
chiles's avatar
chiles committed
528
529
530
   when the basic-block represented by debug-block completes its execution.")

(setf (documentation 'debug-block-elsewhere-p 'function)
531
  _N"Returns whether debug-block represents elsewhere code.")
chiles's avatar
chiles committed
532

533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577

(defstruct (compiled-debug-block (:include debug-block)
				 (:constructor
				  make-compiled-debug-block
				  (code-locations successors elsewhere-p)))
  ;;
  ;; Code-location information for the block.
  (code-locations nil :type simple-vector))

(defstruct (interpreted-debug-block (:include debug-block
					      (elsewhere-p nil))
				    (:constructor %make-interpreted-debug-block
						  (ir1-block)))
  ;;
  ;; This is the IR1 block this debug-block represents.
  (ir1-block nil :type c::cblock)
  ;;
  ;; Code-location information for the block.
  (locations :unparsed :type (or (member :unparsed) simple-vector)))

(defvar *ir1-block-debug-block* (make-hash-table :test #'eq))

;;; MAKE-INTERPRETED-DEBUG-BLOCK -- Internal.
;;;
;;; This makes a debug-block for the interpreter's ir1-block.  If we have it in
;;; the cache, return it.  If we need to make it, then first make debug-blocks
;;; for all the ir1-blocks in ir1-block's home lambda; this makes sure all the
;;; successors of ir1-block have debug-blocks.  We need this to fill in the
;;; resulting debug-block's successors list with debug-blocks, not ir1-blocks.
;;; After making all the possible debug-blocks we'll need to reference, go back
;;; over the list of new debug-blocks and fill in their successor slots with
;;; lists of debug-blocks.  Then look up our argument ir1-block to find its
;;; debug-block since we know we have it now.
;;;
(defun make-interpreted-debug-block (ir1-block)
  (check-type ir1-block c::cblock)
  (let ((res (gethash ir1-block *ir1-block-debug-block*)))
    (or res
	(let ((lambda (c::block-home-lambda ir1-block)))
	  (c::do-blocks (block (c::block-component ir1-block))
	    (when (eq lambda (c::block-home-lambda block))
	      (push (setf (gethash block *ir1-block-debug-block*)
			  (%make-interpreted-debug-block block))
		    res)))
	  (dolist (block res)
578
579
580
581
582
583
584
585
586
587
588
589
590
591
	    (let* ((successors nil)
		   (cblock (interpreted-debug-block-ir1-block block))
		   (succ (c::block-succ cblock))
		   (valid-succ
		    (if (and succ
			     (eq (car succ)
				 (c::component-tail
				  (c::block-component cblock))))
			()
			succ)))
	      (dolist (sblock valid-succ)
		(let ((dblock (gethash sblock *ir1-block-debug-block*)))
		  (when dblock
		    (push dblock successors))))
592
593
594
	      (setf (debug-block-successors block) (nreverse successors))))
	  (gethash ir1-block *ir1-block-debug-block*)))))

chiles's avatar
chiles committed
595
596
597
598
;;;
;;; Breakpoints.
;;;

chiles's avatar
   
chiles committed
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
;;; This is an internal structure that manages information about a breakpoint
;;; locations.  See *component-breakpoint-offsets*.
;;;
(defstruct (breakpoint-data (:print-function print-breakpoint-data)
			    (:constructor make-breakpoint-data
					  (component offset)))
  ;;
  ;; This is the component in which the breakpoint lies.
  component
  ;;
  ;; This is the byte offset into the component.
  (offset nil :type c::index)
  ;;
  ;; The original instruction replaced by the breakpoint.
  (instruction nil :type (or null (unsigned-byte 32)))
  ;;
  ;; A list of user breakpoints at this location.
616
  (breakpoints nil :type list))
chiles's avatar
   
chiles committed
617
618
619
620
621
622
623
624
625
;;;
(defun print-breakpoint-data (obj str n)
  (declare (ignore n))
  (format str "#<Breakpoint-Data ~S at ~S>"
	  (debug-function-name
	   (debug-function-from-pc (breakpoint-data-component obj)
				   (breakpoint-data-offset obj)))
	  (breakpoint-data-offset obj)))
  
chiles's avatar
chiles committed
626
(defstruct (breakpoint (:print-function print-breakpoint)
chiles's avatar
   
chiles committed
627
628
629
630
631
632
		       (:constructor %make-breakpoint
				     (hook-function what kind %info)))
  ;;
  ;; This is the function invoked when execution encounters the breakpoint.  It
  ;; takes a frame, the breakpoint, and optionally a list of values.  Values
  ;; are supplied for :function-end breakpoints as values to return for the
chiles's avatar
   
chiles committed
633
634
  ;; function containing the breakpoint.  :function-end breakpoint
  ;; hook-functions also take a cookie argument.  See cookie-fun slot.
chiles's avatar
   
chiles committed
635
636
637
638
639
  (hook-function nil :type function)
  ;;
  ;; Code-location or debug-function.
  (what nil :type (or code-location debug-function))
  ;;
640
641
642
643
644
  ;; :code-location, :function-start, or :function-end for that kind of
  ;; breakpoint.  :unknown-return-partner if this is the partner of a
  ;; :code-location breakpoint at an :unknown-return code-location.
  (kind nil :type (member :code-location :function-start :function-end
			  :unknown-return-partner))
chiles's avatar
   
chiles committed
645
646
647
648
649
650
651
  ;;
  ;; Status helps the user and the implementation.
  (status :inactive :type (member :active :inactive :deleted))
  ;;
  ;; This is a backpointer to a breakpoint-data.
  (internal-data nil :type (or null breakpoint-data))
  ;;
652
653
654
655
  ;; With code-locations whose type is :unknown-return, there are really
  ;; two breakpoints: one at the multiple-value entry point, and one at
  ;; the single-value entry point.  This slot holds the breakpoint for the
  ;; other one, or NIL if this isn't at an :unknown-return code location.
chiles's avatar
   
chiles committed
656
657
  (unknown-return-partner nil :type (or null breakpoint))
  ;;
chiles's avatar
   
chiles committed
658
659
660
661
662
663
664
665
666
667
668
669
670
671
  ;; :function-end breakpoints use a breakpoint at the :function-start to
  ;; establish the end breakpoint upon function entry.  We do this by frobbing
  ;; the LRA to jump to a special piece of code that breaks and provides the
  ;; return values for the returnee.  This slot points to the start breakpoint,
  ;; so we can activate, deactivate, and delete it.
  (start-helper nil :type (or null breakpoint))
  ;;
  ;; This is a hook users supply to get a dynamically unique cookie for
  ;; identifying :function-end breakpoint executions.  That is, if there is one
  ;; :function-end breakpoint, but there may be multiple pending calls of its
  ;; function on the stack.  This function takes the cookie, and the
  ;; hook-function takes the cookie too.
  (cookie-fun nil :type (or null function))
  ;;
chiles's avatar
   
chiles committed
672
673
674
  ;; This slot users can set with whatever information they find useful.
  %info)
;;;
chiles's avatar
chiles committed
675
676
677
678
679
680
681
682
683
684
685
(defun print-breakpoint (obj str n)
  (declare (ignore n))
  (let ((what (breakpoint-what obj)))
    (format str "#<Breakpoint ~S~:[~;~:*~S~]>"
	    (etypecase what
	      (code-location what)
	      (debug-function (debug-function-name what)))
	    (etypecase what
	      (code-location nil)
	      (debug-function (breakpoint-kind obj))))))

chiles's avatar
   
chiles committed
686
(setf (documentation 'breakpoint-hook-function 'function)
687
  _N"Returns the breakpoint's function the system calls when execution encounters
chiles's avatar
   
chiles committed
688
689
690
   the breakpoint, and it is active.  This is SETF'able.")

(setf (documentation 'breakpoint-what 'function)
691
  _N"Returns the breakpoint's what specification.")
chiles's avatar
   
chiles committed
692
693

(setf (documentation 'breakpoint-kind 'function)
694
  _N"Returns the breakpoint's kind specification.")
chiles's avatar
   
chiles committed
695

chiles's avatar
chiles committed
696
697
698
699
;;;
;;; Code-locations.
;;;

chiles's avatar
   
chiles committed
700
701
(defstruct (code-location (:print-function print-code-location)
			  (:constructor nil))
chiles's avatar
chiles committed
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
  ;;
  ;; This is the debug-function containing code-location.
  (debug-function nil :type debug-function)
  ;;
  ;; This is initially :unsure.  Upon first trying to access an :unparsed slot,
  ;; if the data is unavailable, then this becomes t, and the code-location is
  ;; unknown.  If the data is available, this becomes nil, a known location.
  ;; We can't use a separate type code-location for this since we must return
  ;; code-locations before we can tell whether they're known or unknown.  For
  ;; example, when parsing the stack, we don't want to unpack all the variables
  ;; and blocks just to make frames.
  (%unknown-p :unsure :type (member t nil :unsure))
  ;;
  ;; This is the debug-block containing code-location.
  ;; Possibly toss this out and just find it in the blocks cache in
  ;; debug-function.
  (%debug-block :unparsed :type (or debug-block (member :unparsed)))
  ;;
  ;; This is the number of forms processed by the compiler or loader before
  ;; the top-level form containing this code-location.
  (%tlf-offset :unparsed :type (or c::index (member :unparsed)))
  ;;
  ;; This is the depth-first number of the node that begins code-location
  ;; within its top-level form.
726
  (%form-number :unparsed :type (or c::index (member :unparsed))))
chiles's avatar
chiles committed
727
728
729
730
731

(defun print-code-location (obj str n)
  (declare (ignore n))
  (format str "#<~A ~S>"
	  (ecase (code-location-unknown-p obj)
732
733
734
	    ((nil) (etypecase obj
		     (compiled-code-location "Compiled-Code-Location")
		     (interpreted-code-location "Interpreted-Code-Location")))
chiles's avatar
chiles committed
735
736
737
738
	    ((t) "Unknown-Code-Location"))
	  (debug-function-name (code-location-debug-function obj))))

(setf (documentation 'code-location-debug-function 'function)
739
  _N"Returns the debug-function representing information about the function
chiles's avatar
chiles committed
740
741
   corresponding to the code-location.")

742
743
744

(defstruct (compiled-code-location
	    (:include code-location)
745
746
747
748
	    (:constructor make-known-code-location
			  (pc debug-function %tlf-offset %form-number
			      %live-set kind &aux (%unknown-p nil)))
	    (:constructor make-compiled-code-location (pc debug-function)))
749
750
751
752
753
754
755
756
757
758
  ;;
  ;; This is an index into debug-function's component slot.
  (pc nil :type c::index)
  ;;
  ;; This is a bit-vector indexed by a variable's position in
  ;; DEBUG-FUNCTION-DEBUG-VARS indicating whether the variable has a valid
  ;; value at this code-location.  (unexported).
  (%live-set :unparsed :type (or simple-bit-vector (member :unparsed)))
  ;;
  ;; (unexported)
chiles's avatar
   
chiles committed
759
760
  ;; To see c::location-kind, do "(kernel:type-expand 'c::location-kind)".
  (kind :unparsed :type (or (member :unparsed) c::location-kind)))
761
762
763
764
765
766
767
768
769
770
771

(defstruct (interpreted-code-location
	    (:include code-location
		      (%unknown-p nil))
	    (:constructor make-interpreted-code-location
			  (ir1-node debug-function)))
  ;;
  ;; This is an index into debug-function's component slot.
  (ir1-node nil :type c::node))
  

chiles's avatar
chiles committed
772
773
774
775
;;;
;;; Debug-sources
;;;

pw's avatar
pw committed
776
(declaim (inline debug-source-root-number))
chiles's avatar
chiles committed
777
778
;;;
(defun debug-source-root-number (debug-source)
779
  "Returns the number of top-level forms processed by the compiler before
chiles's avatar
chiles committed
780
781
782
783
784
785
786
   compiling this source.  If this source is uncompiled, this is zero.  This
   may be zero even if the source is compiled since the first form in the first
   file compiled in one compilation, for example, must have a root number of
   zero -- the compiler saw no other top-level forms before it."
  (c::debug-source-source-root debug-source))

(setf (documentation 'c::debug-source-from 'function)
787
  _N"Returns an indication of the type of source.  The following are the possible
chiles's avatar
chiles committed
788
789
790
791
792
793
   values:
      :file    from a file (obtained by COMPILE-FILE if compiled).
      :lisp    from Lisp (obtained by COMPILE if compiled).
      :stream  from a non-file stream.")

(setf (documentation 'c::debug-source-name 'function)
794
  _N"Returns the actual source in some sense represented by debug-source, which
chiles's avatar
chiles committed
795
796
797
798
799
800
   is related to DEBUG-SOURCE-FROM:
      :file    the pathname of the file.
      :lisp    a lambda-expression.
      :stream  some descriptive string that's otherwise useless.")

(setf (documentation 'c::debug-source-created 'function)
801
  _N"Returns the universal time someone created the source.  This may be nil if
chiles's avatar
chiles committed
802
803
804
   it is unavailable.")

(setf (documentation 'c::debug-source-compiled 'function)
805
  _N"Returns the time someone compiled the source.  This is nil if the source
chiles's avatar
chiles committed
806
807
   is uncompiled.")

808
(setf (documentation 'c::debug-source-start-positions 'function)
809
  _N"This function returns the file position of each top-level form as an array
810
811
812
   if debug-source is from a :file.  If DEBUG-SOURCE-FROM is :lisp or :stream,
   this returns nil.")

chiles's avatar
chiles committed
813
(setf (documentation 'c::debug-source-p 'function)
814
  _N"Returns whether object is a debug-source.")
chiles's avatar
chiles committed
815
816
817
818
819



;;;; Frames.

chiles's avatar
   
chiles committed
820
821
822
823
824
825
826
827
;;; This is used in FIND-ESCAPE-FRAME and with the bogus components and LRAs
;;; used for :function-end breakpoints.  When a components debug-info slot is
;;; :bogus-lra, then the real-lra-slot contains the real component to continue
;;; executing, as opposed to the bogus component which appeared in some frame's
;;; LRA location.
;;;
(defconstant real-lra-slot vm:code-constants-offset)

wlott's avatar
wlott committed
828
;;; These are magically converted by the compiler.
829
;;;
chiles's avatar
   
chiles committed
830
831
832
833
(defun kernel:current-sp () (kernel:current-sp))
(defun kernel:current-fp () (kernel:current-fp))
(defun kernel:stack-ref (s n) (kernel:stack-ref s n))
(defun kernel:%set-stack-ref (s n value) (kernel:%set-stack-ref s n value))
chiles's avatar
   
chiles committed
834
(defun kernel:function-code-header (fun) (kernel:function-code-header fun))
835
#-gengc (defun kernel:lra-code-header (lra) (kernel:lra-code-header lra))
chiles's avatar
   
chiles committed
836
837
838
(defun kernel:make-lisp-obj (value) (kernel:make-lisp-obj value))
(defun kernel:get-lisp-obj-address (thing) (kernel:get-lisp-obj-address thing))
(defun kernel:function-word-offset (fun) (kernel:function-word-offset fun))
839
;;;
chiles's avatar
   
chiles committed
840
(defsetf kernel:stack-ref kernel:%set-stack-ref)
841

842
843
844
845
846
847
848
849
850
851
;;; DESCRIPTOR-SAP -- internal
;;;
;;; Convert the descriptor into a SAP.  The bits all stay the same, we just
;;; change our notion of what we think they are.
;;; 
(declaim (inline descriptor-sap))
(defun descriptor-sap (x)
  (system:int-sap (kernel:get-lisp-obj-address x)))


852
(declaim (inline cstack-pointer-valid-p))
chiles's avatar
chiles committed
853
(defun cstack-pointer-valid-p (x)
chiles's avatar
   
chiles committed
854
  (declare (type system:system-area-pointer x))
cwang's avatar
cwang committed
855
  #-(or :x86 :amd64)
wlott's avatar
wlott committed
856
  (and (system:sap< x (kernel:current-sp))
857
858
859
860
       (system:sap<= #-gengc (alien:alien-sap
			      (alien:extern-alien "control_stack" (* t)))
		     #+gengc (kernel:mutator-control-stack-base)
		     x)
ram's avatar
ram committed
861
       (zerop (logand (system:sap-int x) #b11)))
cwang's avatar
cwang committed
862
  #+(or :x86 :amd64) ;; stack grows to low address values
ram's avatar
ram committed
863
  (and (system:sap>= x (kernel:current-sp))
864
865
866
       (system:sap> (alien:alien-sap
		     (alien:extern-alien "control_stack_end" (* t)))
		    x)
867
868
       (zerop (logand (system:sap-int x) #b11))))

cwang's avatar
cwang committed
869
#+(or gengc x86 amd64)
870
871
(alien:def-alien-routine component-ptr-from-pc (system:system-area-pointer)
  (pc system:system-area-pointer))
ram's avatar
ram committed
872

cwang's avatar
cwang committed
873
#+(or gengc x86 amd64)
874
875
876
877
878
(defun component-from-component-ptr (component-ptr)
  (declare (type system:system-area-pointer component-ptr))
  (kernel:make-lisp-obj
   (logior (system:sap-int component-ptr)
	   vm:other-pointer-type)))
ram's avatar
ram committed
879

cwang's avatar
cwang committed
880
;;;; X86 and amd64 support.
ram's avatar
ram committed
881

cwang's avatar
cwang committed
882
#+(or x86 amd64)
883
884
(progn

885
;;; Note this function should be called with garbage collect inhibited.
886
(defun compute-lra-data-from-pc (pc)
ram's avatar
ram committed
887
  (declare (type system-area-pointer pc))
888
889
890
891
892
893
894
895
896
897
  (let ((component-ptr (component-ptr-from-pc pc)))
    (unless (sap= component-ptr (int-sap #x0))
       (let* ((code (component-from-component-ptr component-ptr))
	      (code-header-len (* (kernel:get-header-data code) vm:word-bytes))
	      (pc-offset (- (sap-int pc)
			    (- (kernel:get-lisp-obj-address code)
			       vm:other-pointer-type)
			    code-header-len)))
;	 (format t "c-lra-fpc ~a ~a ~a~%" pc code pc-offset)
	 (values pc-offset code)))))
ram's avatar
ram committed
898

899
(defconstant vm::nargs-offset #.vm::ecx-offset)
ram's avatar
ram committed
900

901
902
903
904
;;; Check for a valid return address - it could be any valid C/Lisp
;;; address.
;;;
;;; XX Could be a little smarter.
905
(declaim (inline ra-pointer-valid-p))
906
907
(defun ra-pointer-valid-p (ra)
  (declare (type system:system-area-pointer ra))
908
909
910
911
912
913
914
  (and
   ;; Not the first page which is unmapped.
   (>= (sys:sap-int ra) 4096)
   ;; Not a Lisp stack pointer.
   (or (sys:sap< ra (kernel:current-sp))
       (sys:sap>= ra (alien:alien-sap
		      (alien:extern-alien "control_stack_end" (* t)))))))
915
916
917
918
919
920
921
922
923
924
925

;;; Try to find a valid previous stack. This is complex on the x86 as
;;; it can jump between C and Lisp frames. To help find a valid frame
;;; it searches backwards.
;;;
;;; XX Should probably check if it has reached the bottom of the
;;; stack.
;;;
;;; XX Should handle interrupted frames, both Lisp and C. A present it
;;; manages to find a fp trail, see linux hack below.
;;;
926
(defun x86-call-context (fp &key (depth 0))
927
928
929
930
931
932
933
934
935
  (declare (type system-area-pointer fp)
	   (fixnum depth))
;  (format t "*CC ~s ~s~%" fp depth)
  (cond
   ((not (cstack-pointer-valid-p fp))
    (format t "Debug invalid fp ~s~%" fp)
    nil)
   (t
    ;; Check the two possible frame pointers.
cwang's avatar
cwang committed
936
937
938
939
    (let ((lisp-ocfp (sap-ref-sap fp (- (* (1+ vm::ocfp-save-offset) 
					   vm:word-bytes))))
	  (lisp-ra (sap-ref-sap fp (- (* (1+ vm::return-pc-save-offset)
					 vm:word-bytes))))
940
941
942
943
944
945
946
947
948
949
	  (c-ocfp (sap-ref-sap fp (* 0 vm:word-bytes)))
	  (c-ra (sap-ref-sap fp (* 1 vm:word-bytes))))
      (cond ((and (sap> lisp-ocfp fp) (cstack-pointer-valid-p lisp-ocfp)
		  (ra-pointer-valid-p lisp-ra)
		  (sap> c-ocfp fp) (cstack-pointer-valid-p c-ocfp)
		  (ra-pointer-valid-p c-ra))
;	     (format t "*C Both valid ~s ~s ~s ~s~%"
;		     lisp-ocfp lisp-ra c-ocfp c-ra)
	     ;; Look forward another step to check their validity.
	     (let ((lisp-path-fp (x86-call-context lisp-ocfp
950
951
						   :depth (1+ depth)))
		   (c-path-fp (x86-call-context c-ocfp :depth (1+ depth))))
952
	       (cond ((and lisp-path-fp c-path-fp)
953
		      ;; Both still seem valid - choose the lisp frame.
954
		      #+nil
955
956
957
		      (when (zerop depth)
			(format t "Debug: Both still valid ~s ~s ~s ~s~%"
				lisp-ocfp lisp-ra c-ocfp c-ra))
958
		      #+(or darwin freebsd)
959
960
961
		      (if (sap> lisp-ocfp c-ocfp)
			  (values lisp-ra lisp-ocfp)
			  (values c-ra c-ocfp))
962
		      #-(or darwin freebsd)
963
		      (values lisp-ra lisp-ocfp))
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
		     (lisp-path-fp
		      ;; The lisp convention is looking good.
;		      (format t "*C lisp-ocfp ~s ~s~%" lisp-ocfp lisp-ra)
		      (values lisp-ra lisp-ocfp))
		     (c-path-fp
		      ;; The C convention is looking good.
;		      (format t "*C c-ocfp ~s ~s~%" c-ocfp c-ra)
		      (values c-ra c-ocfp))
		     (t
		      ;; Neither seems right?
;		      (format t "Debug: no valid2 fp found ~s ~s~%"
;			      lisp-ocfp c-ocfp)
		      nil))))
	    ((and (sap> lisp-ocfp fp) (cstack-pointer-valid-p lisp-ocfp)
		  (ra-pointer-valid-p lisp-ra))
	     ;; The lisp convention is looking good.
;	     (format t "*C lisp-ocfp ~s ~s~%" lisp-ocfp lisp-ra)
	     (values lisp-ra lisp-ocfp))
	    ((and (sap> c-ocfp fp) (cstack-pointer-valid-p c-ocfp)
		  #-linux (ra-pointer-valid-p c-ra))
	     ;; The C convention is looking good.
;	     (format t "*C c-ocfp ~s ~s~%" c-ocfp c-ra)
	     (values c-ra c-ocfp))
	    (t
;	     (format t "Debug: no valid fp found ~s ~s~%" lisp-ocfp c-ocfp)
	     nil))))))
ram's avatar
ram committed
990

cwang's avatar
cwang committed
991
) ; end progn x86 amd64
992

993

chiles's avatar
chiles committed
994
995
996
;;; TOP-FRAME -- Public.
;;;
(defun top-frame ()
997
  "Returns the top frame of the control stack as it was before calling this
chiles's avatar
chiles committed
998
   function."
999
  (multiple-value-bind (fp pc)
1000
      (kernel:%caller-frame-and-pc)
1001
    (possibly-an-interpreted-frame
1002
     (compute-calling-frame (descriptor-sap fp)
1003
			    #-gengc pc #+gengc (descriptor-sap pc)
1004
			    nil)
1005
1006
     nil)))

1007
1008
1009
;;; FLUSH-FRAMES-ABOVE -- public.
;;; 
(defun flush-frames-above (frame)
1010
  "Flush all of the frames above FRAME, and renumber all the frames below
1011
1012
1013
1014
1015
1016
1017
   FRAME."
  (setf (frame-up frame) nil)
  (do ((number 0 (1+ number))
       (frame frame (frame-%down frame)))
      ((not (frame-p frame)))
    (setf (frame-number frame) number)))

1018
1019
;;; FRAME-DOWN -- Public.
;;;
chiles's avatar
   
chiles committed
1020
;;; We have to access the old-fp and return-pc out of frame and pass them to
1021
1022
;;; COMPUTE-CALLING-FRAME.
;;;
chiles's avatar
chiles committed
1023
(defun frame-down (frame)
1024
  "Returns the frame immediately below frame on the stack.  When frame is
chiles's avatar
chiles committed
1025
1026
1027
   the bottom of the stack, this returns nil."
  (let ((down (frame-%down frame)))
    (if (eq down :unparsed)
1028
	(let* ((real (frame-real-frame frame))
1029
	       (debug-fun (frame-debug-function real)))
1030
	  (setf (frame-%down frame)
1031
1032
1033
1034
1035
1036
		(etypecase debug-fun
		  (compiled-debug-function
		   (let ((c-d-f (compiled-debug-function-compiler-debug-fun
				 debug-fun)))
		     (possibly-an-interpreted-frame
		      (compute-calling-frame
1037
		       (descriptor-sap
1038
1039
1040
1041
			(get-context-value
			 real vm::ocfp-save-offset
			 (c::compiled-debug-function-old-fp c-d-f)))
		       #-gengc
1042
		       (get-context-value
chiles's avatar
   
chiles committed
1043
			real vm::lra-save-offset
1044
			(c::compiled-debug-function-return-pc c-d-f))
1045
1046
1047
1048
1049
		       #+gengc
		       (descriptor-sap
			(get-context-value
			 real vm::ra-save-offset
			 (c::compiled-debug-function-return-pc c-d-f)))
1050
1051
1052
1053
		       frame)
		      frame)))
		  (bogus-debug-function
		   (let ((fp (frame-pointer real)))
1054
		     (when (cstack-pointer-valid-p fp)
cwang's avatar
cwang committed
1055
		       #+(or x86 amd64)
1056
1057
1058
1059
		       (multiple-value-bind (ra ofp)
			   (x86-call-context fp)
			 (when (and ra ofp)
			   (compute-calling-frame ofp ra frame)))
cwang's avatar
cwang committed
1060
		       #-(or x86 amd64)
1061
		       (compute-calling-frame
hallgren's avatar
hallgren committed
1062
			#-alpha
1063
1064
			(system:sap-ref-sap fp (* vm::ocfp-save-offset
						  vm:word-bytes))
hallgren's avatar
hallgren committed
1065
1066
			#+alpha
			(kernel::int-sap
1067
1068
1069
			 (system:sap-ref-32 fp (* vm::ocfp-save-offset
						  vm:word-bytes)))

1070
1071
1072
1073
1074
1075
			#-gengc
			(kernel:stack-ref fp vm::lra-save-offset)
			#+gengc
			(system:sap-ref-sap fp (* vm::ra-save-offset
						  vm:word-bytes))
			frame)))))))
chiles's avatar
chiles committed
1076
1077
	down)))

chiles's avatar
   
chiles committed
1078
1079

;;; GET-CONTEXT-VALUE  --  Internal.
wlott's avatar
wlott committed
1080
;;;
chiles's avatar
   
chiles committed
1081
1082
1083
1084
;;; Get the old FP or return PC out of frame.  Stack-slot is the standard save
;;; location offset on the stack.  Loc is the saved sc-offset describing the
;;; main location.
;;;
cwang's avatar
cwang committed
1085
#-(or x86 amd64)
chiles's avatar
   
chiles committed
1086
1087
1088
1089
1090
1091
1092
(defun get-context-value (frame stack-slot loc)
  (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
	   (type c::sc-offset loc))
  (let ((pointer (frame-pointer frame))
	(escaped (compiled-frame-escaped frame)))
    (if escaped
	(sub-access-debug-var-slot pointer loc escaped)
chiles's avatar
   
chiles committed
1093
	(kernel:stack-ref pointer stack-slot))))
cwang's avatar
cwang committed
1094
#+(or x86 amd64)
ram's avatar
ram committed
1095
1096
1097
1098
1099
1100
(defun get-context-value (frame stack-slot loc)
  (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
	   (type c::sc-offset loc))
  (let ((pointer (frame-pointer frame))
	(escaped (compiled-frame-escaped frame)))
    (if escaped
1101
	(sub-access-debug-var-slot pointer loc escaped)
ram's avatar
ram committed
1102
	(ecase stack-slot
1103
1104
1105
	  (#.vm::ocfp-save-offset
	   (kernel:stack-ref pointer stack-slot))
	  (#.vm::lra-save-offset
cwang's avatar
cwang committed
1106
	   (sap-ref-sap pointer (- (* (1+ stack-slot) vm:word-bytes))))))))
ram's avatar
ram committed
1107

chiles's avatar
   
chiles committed
1108
;;;
cwang's avatar
cwang committed
1109
#-(or x86 amd64)
chiles's avatar
   
chiles committed
1110
1111
1112
1113
1114
1115
1116
(defun (setf get-context-value) (value frame stack-slot loc)
  (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
	   (type c::sc-offset loc))
  (let ((pointer (frame-pointer frame))
	(escaped (compiled-frame-escaped frame)))
    (if escaped
	(sub-set-debug-var-slot pointer loc value escaped)
chiles's avatar
   
chiles committed
1117
	(setf (kernel:stack-ref pointer stack-slot) value))))
wlott's avatar
wlott committed
1118

cwang's avatar
cwang committed
1119
#+(or x86 amd64)
1120
1121
1122
1123
1124
1125
(defun (setf get-context-value) (value frame stack-slot loc)
  (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
	   (type c::sc-offset loc))
  (let ((pointer (frame-pointer frame))
	(escaped (compiled-frame-escaped frame)))
    (if escaped
1126
	(sub-set-debug-var-slot pointer loc value escaped)
1127
	(ecase stack-slot
1128
1129
1130
	  (#.vm::ocfp-save-offset
	   (setf (kernel:stack-ref pointer stack-slot) value))
	  (#.vm::lra-save-offset
cwang's avatar
cwang committed
1131
1132
	   (setf (sap-ref-sap pointer (- (* (1+ stack-slot) vm:word-bytes)))
		 value))))))
1133

wlott's avatar
wlott committed
1134

1135
(defvar *debugging-interpreter* nil
1136
  "When set, the debugger foregoes making interpreted-frames, so you can
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
   debug the functions that manifest the interpreter.")

;;; POSSIBLY-AN-INTERPRETED-FRAME -- Internal.
;;;
;;; This takes a newly computed frame, frame, and the frame above it on the
;;; stack, up-frame, which is possibly nil.  Frame is nil when we hit the
;;; bottom of the control stack.  When frame represents a call to
;;; EVAL::INTERNAL-APPLY-LOOP, we make an interpreted frame to replace frame.
;;; The interpreted frame points to frame.
;;;
(defun possibly-an-interpreted-frame (frame up-frame)
  (if (or (not frame)
	  (not (eq (debug-function-name (frame-debug-function frame))
		   'eval::internal-apply-loop))
	  *debugging-interpreter*
	  (compiled-frame-escaped frame))
      frame
      (flet ((get-var (name location)
	       (let ((vars (di:ambiguous-debug-variables
			    (di:frame-debug-function frame) name)))
		 (when (or (null vars) (> (length vars) 1))
1158
1159
		   (error (intl:gettext "Zero or more than one ~A variable in ~
			   EVAL::INTERNAL-APPLY-LOOP?")
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
			  (string-downcase name)))
		 (if (eq (debug-variable-validity (car vars) location)
			 :valid)
		     (car vars)))))
	(let* ((code-loc (frame-code-location frame))
	       (ptr-var (get-var "FRAME-PTR" code-loc))
	       (node-var (get-var "NODE" code-loc))
	       (closure-var (get-var "CLOSURE" code-loc)))
	  (if (and ptr-var node-var closure-var)
	      (let* ((node (debug-variable-value node-var frame))
		     (d-fun (make-interpreted-debug-function
			     (c::block-home-lambda (c::node-block node)))))
		(make-interpreted-frame
		 (debug-variable-value ptr-var frame)
		 up-frame
		 d-fun
		 (make-interpreted-code-location node d-fun)
		 (frame-number frame)
		 frame
		 (debug-variable-value closure-var frame)))
	      frame)))))

chiles's avatar
   
chiles committed
1182

1183
#+(or sparc (and x86 (or darwin solaris netbsd)) (and (or x86 amd64) linux))
1184
(defun find-foreign-function-name (address)
1185
  _"Return a string describing the foreign function near ADDRESS"
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
  (let ((addr (sys:sap-int address)))
    (alien:with-alien ((info (alien:struct dl-info
					   (filename c-call:c-string)
					   (base alien:unsigned)
					   (symbol c-call:c-string)
					   (symbol-address alien:unsigned)))
		       (dladdr (function alien:unsigned alien:unsigned
					 (* (alien:struct dl-info)))
			       :extern "dladdr"))
      (let ((err (alien:alien-funcall dladdr addr (alien:addr info))))
	(cond ((zerop err)
1197
	       _"Foreign function call land")
1198
1199
1200
1201
1202
1203
1204
1205
	      (t
	       (format nil "~A+#x~x [#x~X] ~A"
		       (alien:slot info 'symbol)
		       (- addr (alien:slot info 'symbol-address))
		       addr
		       (alien:slot info 'filename)
		       )))))))

1206
#-(or sparc (and x86 (or darwin solaris netbsd)) (and (or x86 amd64) linux))
1207
1208
(defun find-foreign-function-name (ra)
  (declare (ignore ra))
1209
  _"Foreign function call land")
1210

1211
(defun assembly-routines-p (component)
1212
  "Return t if COMPONENT contains code from assembly routines."
1213
1214
1215
1216
1217
1218
1219
1220
  (let ((start (sap-int (kernel:code-instructions component))))
    (maphash (lambda (_ addr)
	       (declare (ignore _))
	       (when (= addr start)
		 (return-from assembly-routines-p t)))
	     lisp::*assembler-routines*)))

(defun find-assembly-routine-name (component pc)
1221
  "Return the name of the assembly routine at offset PC in COMPONENT.
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
The result is a symbol or nil if the routine cannot be found."
  (let* ((start (sap-int (kernel:code-instructions component)))
	 (end (+ start (* (kernel::%code-code-size component) 
			  vm:word-bytes)))
	 (routines `((#:end . ,end))))
    ;; collect the assembly routines in the component
    (maphash (lambda (name addr)
	       (when (<= start addr end)
		 (push (cons name addr) routines)))
	     lisp::*assembler-routines*)
    ;; sort them and return the name for the routine at PC
    (let ((routines (sort routines #'< :key #'cdr))
	  (addr (+ start pc)))
      (loop for ((r1 . addr1) (r2 . addr2)) on routines
	    while r2
	    when (<= addr1 addr addr2) return r1))))

chiles's avatar
chiles committed
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
;;; COMPUTE-CALLING-FRAME -- Internal.
;;;
;;; This returns a frame for the one existing in time immediately prior to the
;;; frame referenced by current-fp.  This is current-fp's caller or the next
;;; frame down the control stack.  If there is no down frame, this returns nil
;;; for the bottom of the stack.  Up-frame is the up link for the resulting
;;; frame object, and it is nil when we call this to get the top of the stack.
;;;
;;; The current frame contains the pointer to the temporally previous frame we
;;; want, and the current frame contains the pc at which we will continue
;;; executing upon returning to that previous frame.
;;;
1251
1252
1253
;;; Note: Sometimes LRA is actually a fixnum.  This happens when lisp calls
;;; into C.  In this case, the code object is stored on the stack after the
;;; LRA, and the LRA is the word offset.
ram's avatar
ram committed
1254
;;;
cwang's avatar
cwang committed
1255
#-(or gengc x86 amd64)
Raymond Toy's avatar
Raymond Toy committed
1256
(intl:with-textdomain ("cmucl" #+sparc "cmucl-sparc-vm" #+ppc "cmucl-ppc-vm")
wlott's avatar
wlott committed
1257
(defun compute-calling-frame (caller lra up-frame)
chiles's avatar
   
chiles committed
1258
  (declare (type system:system-area-pointer caller))
wlott's avatar
wlott committed
1259
1260
1261
1262
  (when (cstack-pointer-valid-p caller)
    (multiple-value-bind
	(code pc-offset escaped)
	(if lra
1263
	    (multiple-value-bind