/
debug.lisp
2115 lines (1924 loc) · 93.8 KB
/
debug.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
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
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
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
990
991
992
993
994
995
996
997
998
999
1000
;;;; the debugger
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB-DEBUG")
;;;; variables and constants
;;; things to consider when tweaking these values:
;;; * We're afraid to just default them to NIL and NIL, in case the
;;; user inadvertently causes a hairy data structure to be printed
;;; when he inadvertently enters the debugger.
;;; * We don't want to truncate output too much. These days anyone
;;; can easily run their Lisp in a windowing system or under Emacs,
;;; so it's not the end of the world even if the worst case is a
;;; few thousand lines of output.
;;; * As condition :REPORT methods are converted to use the pretty
;;; printer, they acquire *PRINT-LEVEL* constraints, so e.g. under
;;; sbcl-0.7.1.28's old value of *DEBUG-PRINT-LEVEL*=3, an
;;; ARG-COUNT-ERROR printed as
;;; error while parsing arguments to DESTRUCTURING-BIND:
;;; invalid number of elements in
;;; #
;;; to satisfy lambda list
;;; #:
;;; exactly 2 expected, but 5 found
(defvar *debug-print-variable-alist* nil
"an association list describing new bindings for special variables
to be used within the debugger. Eg.
((*PRINT-LENGTH* . 10) (*PRINT-LEVEL* . 6) (*PRINT-PRETTY* . NIL))
The variables in the CAR positions are bound to the values in the CDR
during the execution of some debug commands. When evaluating arbitrary
expressions in the debugger, the normal values of the printer control
variables are in effect.
Initially empty, *DEBUG-PRINT-VARIABLE-ALIST* is typically used to
provide bindings for printer control variables.")
(defvar *debug-readtable*
;; KLUDGE: This can't be initialized in a cold toplevel form,
;; because the *STANDARD-READTABLE* isn't initialized until after
;; cold toplevel forms have run. So instead we initialize it
;; immediately after *STANDARD-READTABLE*. -- WHN 20000205
nil
"*READTABLE* for the debugger")
(defvar *in-the-debugger* nil
"This is T while in the debugger.")
;;; nestedness inside debugger command loops
(defvar *debug-command-level* 0)
;;; If this is bound before the debugger is invoked, it is used as the stack
;;; top by the debugger. It can either be the first interesting frame, or the
;;; name of the last uninteresting frame.
(defvar *stack-top-hint* nil)
(defvar *current-frame* nil)
(declaim (always-bound *stack-top-hint* *current-frame*))
;;; Beginner-oriented help messages are important because you end up
;;; in the debugger whenever something bad happens, or if you try to
;;; get out of the system with Ctrl-C or (EXIT) or EXIT or whatever.
;;; But after memorizing them the wasted screen space gets annoying..
(defvar *debug-beginner-help-p* t
"Should the debugger display beginner-oriented help messages?")
(defun debug-prompt (stream)
(sb-thread::get-foreground)
(format stream
"~%~W~:[~;[~W~]] "
(frame-number *current-frame*)
(> *debug-command-level* 1)
*debug-command-level*))
(define-load-time-global *debug-help-string*
"The debug prompt is square brackets, with number(s) indicating the current
control stack level and, if you've entered the debugger recursively, how
deeply recursed you are.
Any command -- including the name of a restart -- may be uniquely abbreviated.
The debugger rebinds various special variables for controlling i/o, sometimes
to defaults (much like WITH-STANDARD-IO-SYNTAX does) and sometimes to
its own special values, based on SB-EXT:*DEBUG-PRINT-VARIABLE-ALIST*.
Debug commands do not affect *, //, and similar variables, but evaluation in
the debug loop does affect these variables.
SB-DEBUG:*FLUSH-DEBUG-ERRORS* controls whether errors at the debug prompt
drop you deeper into the debugger. The default NIL allows recursive entry
to debugger.
Getting in and out of the debugger:
TOPLEVEL, TOP exits debugger and returns to top level REPL
RESTART invokes restart numbered as shown (prompt if not given).
ERROR prints the error condition and restart cases.
The number of any restart, or its name, or a unique abbreviation for its
name, is a valid command, and is the same as using RESTART to invoke
that restart.
Changing frames:
UP up frame DOWN down frame
BOTTOM bottom frame FRAME n frame n (n=0 for top frame)
Inspecting frames:
BACKTRACE [n] shows n frames going down the stack.
LIST-LOCALS, L lists locals in current frame.
PRINT, P displays function call for current frame.
SOURCE [n] displays frame's source form with n levels of enclosing forms.
Stepping:
START Selects the CONTINUE restart if one exists and starts
single-stepping. Single stepping affects only code compiled with
under high DEBUG optimization quality. See User Manual for details.
STEP Steps into the current form.
NEXT Steps over the current form.
OUT Stops stepping temporarily, but resumes it when the topmost frame that
was stepped into returns.
STOP Stops single-stepping.
Function and macro commands:
(SB-DEBUG:ARG n)
Return the n'th argument in the current frame.
(SB-DEBUG:VAR string-or-symbol [id])
Returns the value of the specified variable in the current frame.
Other commands:
RETURN expr
Return the values resulting from evaluation of expr from the
current frame, if this frame was compiled with a sufficiently high
DEBUG optimization quality.
RESTART-FRAME
Restart execution of the current frame, if this frame is for a
global function which was compiled with a sufficiently high
DEBUG optimization quality.
SLURP
Discard all pending input on *STANDARD-INPUT*. (This can be
useful when the debugger was invoked to handle an error in
deeply nested input syntax, and now the reader is confused.)")
(defmacro with-debug-io-syntax (() &body body)
(let ((thunk (gensym "THUNK")))
`(dx-flet ((,thunk ()
,@body))
(funcall-with-debug-io-syntax #',thunk))))
;;; If LOC is an unknown location, then try to find the block start
;;; location. Used by source printing to some information instead of
;;; none for the user.
(defun maybe-block-start-location (loc)
(if (code-location-unknown-p loc)
(let* ((block (code-location-debug-block loc))
(start (do-debug-block-locations (loc block)
(return loc))))
(cond ((and (not (debug-block-elsewhere-p block))
start)
start)
(t
loc)))
loc))
;;;; BACKTRACE
(declaim (unsigned-byte *backtrace-frame-count*))
(defvar *backtrace-frame-count* 1000
"Default number of frames to backtrace. Defaults to 1000.")
(declaim (boolean *backtrace-print-pc*))
(defvar *backtrace-print-pc* nil)
(declaim (unsigned-byte *default-argument-limit*))
(defvar *default-argument-limit* call-arguments-limit)
(declaim (type (member :minimal :normal :full) *method-frame-style*))
(defvar *method-frame-style* :normal
"Determines how frames corresponding to method functions are represented in
backtraces. Possible values are :MINIMAL, :NORMAL, and :FULL.
:MINIMAL represents them as
(<gf-name> ...args...)
if all arguments are available, and only a single method is applicable to
the arguments -- otherwise behaves as :NORMAL.
:NORMAL represents them as
((:method <gf-name> [<qualifier>*] (<specializer>*)) ...args...)
The frame is then followed by either [fast-method] or [slow-method],
designating the kind of method function. (See below.)
:FULL represents them using the actual funcallable method function name:
((sb-pcl:fast-method <gf-name> [<qualifier>*] (<specializer>*)) ...args...)
or
((sb-pcl:slow-method <gf-name> [<qualifier>*] (<specializer>*)) ...args...)
In the this case arguments may include values internal to SBCL's method
dispatch machinery.")
(define-deprecated-function :early "1.2.15" backtrace (print-backtrace)
(&optional (count *backtrace-frame-count*) (stream *debug-io*))
(print-backtrace :count count :stream stream))
(define-deprecated-function :early "1.2.15" backtrace-as-list (list-backtrace)
(&optional (count *backtrace-frame-count*))
(list-backtrace :count count))
(defun backtrace-start-frame (frame-designator)
(let ((here (top-frame)))
(labels ((current-frame ()
(let ((frame here))
;; Our caller's caller.
(loop repeat 2
do (setf frame (or (frame-down frame) frame)))
frame))
(interrupted-frame ()
(or (find-interrupted-frame)
(current-frame))))
(cond ((eq :current-frame frame-designator)
(current-frame))
((eq :interrupted-frame frame-designator)
(interrupted-frame))
((eq :debugger-frame frame-designator)
(if (and *in-the-debugger* *current-frame*)
*current-frame*
(interrupted-frame)))
((frame-p frame-designator)
frame-designator)
(t
(error "Invalid designator for initial backtrace frame: ~S"
frame-designator))))))
(defun map-backtrace (function &key
(start 0)
(from :debugger-frame)
(count *backtrace-frame-count*))
"Calls the designated FUNCTION with each frame on the call stack.
Returns the last value returned by FUNCTION.
COUNT is the number of frames to backtrace, defaulting to
*BACKTRACE-FRAME-COUNT*.
START is the number of the frame the backtrace should start from.
FROM specifies the frame relative to which the frames are numbered. Possible
values are an explicit SB-DI:FRAME object, and the
keywords :CURRENT-FRAME, :INTERRUPTED-FRAME, and :DEBUGGER-FRAME. Default
is :DEBUGGER-FRAME.
:CURRENT-FRAME
specifies the caller of MAP-BACKTRACE.
:INTERRUPTED-FRAME
specifies the first interrupted frame on the stack \(typically the frame
where the error occurred, as opposed to error handling frames) if any,
otherwise behaving as :CURRENT-FRAME.
:DEBUGGER-FRAME
specifies the currently debugged frame when inside the debugger, and
behaves as :INTERRUPTED-FRAME outside the debugger.
"
(declare (dynamic-extent function))
(loop with result = nil
for index upfrom 0
for frame = (backtrace-start-frame from)
then (frame-down frame)
until (null frame)
when (<= start index) do
(if (minusp (decf count))
(return result)
(setf result (funcall function frame)))
finally (return result)))
(defun print-backtrace (&key
(stream *debug-io*)
(start 0)
(from :debugger-frame)
(count *backtrace-frame-count*)
(print-thread t)
(print-pc *backtrace-print-pc*)
(argument-limit *default-argument-limit*)
(print-frame-source nil)
(method-frame-style *method-frame-style*)
(emergency-best-effort (> *debug-command-level* 1)))
"Print a listing of the call stack to STREAM, defaulting to *DEBUG-IO*.
COUNT is the number of frames to backtrace, defaulting to
*BACKTRACE-FRAME-COUNT*.
START is the number of the frame the backtrace should start from.
FROM specifies the frame relative to which the frames are numbered. Possible
values are an explicit SB-DI:FRAME object, and the
keywords :CURRENT-FRAME, :INTERRUPTED-FRAME, and :DEBUGGER-FRAME. Default
is :DEBUGGER-FRAME.
:CURRENT-FRAME
specifies the caller of PRINT-BACKTRACE.
:INTERRUPTED-FRAME
specifies the first interrupted frame on the stack \(typically the frame
where the error occured, as opposed to error handling frames) if any,
otherwise behaving as :CURRENT-FRAME.
:DEBUGGER-FRAME
specifies the currently debugged frame when inside the debugger, and
behaves as :INTERRUPTED-FRAME outside the debugger.
If PRINT-THREAD is true (default), backtrace is preceded by printing the
thread object the backtrace is from.
If PRINT-FRAME-SOURCE is true (default is false), each frame is followed by
printing the currently executing source form in the function responsible for
that frame, when available. Requires the function to have been compiled at
DEBUG 2 or higher. If PRINT-FRAME-SOURCE is :ALWAYS, it also reports \"no
source available\" for frames for which were compiled at lower debug settings.
METHOD-FRAME-STYLE (defaulting to *METHOD-FRAME-STYLE*), determines how frames
corresponding to method functions are printed. Possible values
are :MINIMAL, :NORMAL, and :FULL. See *METHOD-FRAME-STYLE* for more
information.
If EMERGENCY-BEST-EFFORT is true then try to print as much information as
possible while navigating and ignoring possible errors."
(let ((start-frame (backtrace-start-frame from)))
(with-debug-io-syntax ()
(let ((*suppress-print-errors* (if (and emergency-best-effort
(not (subtypep 'serious-condition *suppress-print-errors*)))
'serious-condition
*suppress-print-errors*))
(frame-index start))
(labels
((print-frame (frame stream)
(print-frame-call frame stream
:number frame-index
:print-pc print-pc :argument-limit argument-limit
:method-frame-style method-frame-style
:print-frame-source print-frame-source
:emergency-best-effort emergency-best-effort))
(print-frame/normal (frame)
(print-frame frame stream))
(print-frame/emergency-best-effort (frame)
(with-open-stream (buffer (make-string-output-stream))
(handler-case
(progn
(fresh-line stream)
(print-frame frame buffer)
(write-string (get-output-stream-string buffer) stream))
(serious-condition (error)
(print-unreadable-object (error stream :type t)
(format stream "while printing frame ~S. The partial output is: ~S"
frame-index (get-output-stream-string buffer))))))))
(handler-bind
((print-not-readable #'print-unreadably))
(fresh-line stream)
(when print-thread
(format stream "Backtrace for: ~S~%" sb-thread:*current-thread*))
(map-backtrace (lambda (frame)
(restart-case
(if emergency-best-effort
(print-frame/emergency-best-effort frame)
(print-frame/normal frame))
(skip-printing-frame ()
:report (lambda (stream)
(format stream "Skip printing frame ~S" frame-index))
(print-unreadable-object (frame stream :type t :identity t))))
(incf frame-index))
:from start-frame
:start start
:count count))))
(fresh-line stream)
(values))))
(defun list-backtrace (&key
(count *backtrace-frame-count*)
(argument-limit *default-argument-limit*)
(start 0)
(from :debugger-frame)
(method-frame-style *method-frame-style*))
"Returns a list describing the call stack. Each frame is represented
by a sublist:
\(<name> ...args...)
where the name describes the function responsible for the frame. The name
might not be bound to the actual function object. Unavailable arguments are
represented by dummy objects that print as #<unavailable argument>. Objects
with dynamic-extent allocation by the current thread are represented by
substitutes to avoid references to them from leaking outside their legal
extent.
COUNT is the number of frames to backtrace, defaulting to
*BACKTRACE-FRAME-COUNT*.
START is the number of the frame the backtrace should start from.
FROM specifies the frame relative to which the frames are numbered. Possible
values are an explicit SB-DI:FRAME object, and the
keywords :CURRENT-FRAME, :INTERRUPTED-FRAME, and :DEBUGGER-FRAME. Default
is :DEBUGGER-FRAME.
:CURRENT-FRAME
specifies the caller of LIST-BACKTRACE.
:INTERRUPTED-FRAME
specifies the first interrupted frame on the stack \(typically the frame
where the error occured, as opposed to error handling frames) if any,
otherwise behaving as :CURRENT-FRAME.
:DEBUGGER-FRAME
specifies the currently debugged frame when inside the debugger, and
behaves as :INTERRUPTED-FRAME outside the debugger.
METHOD-FRAME-STYLE (defaulting to *METHOD-FRAME-STYLE*), determines how frames
corresponding to method functions are printed. Possible values
are :MINIMAL, :NORMAL, and :FULL. See *METHOD-FRAME-STYLE* for more
information."
(let (rbacktrace)
(map-backtrace
(lambda (frame)
(push (frame-call-as-list frame argument-limit :method-frame-style method-frame-style)
rbacktrace))
:count count
:start start
:from (backtrace-start-frame from))
(nreverse rbacktrace)))
(defun frame-call-as-list (frame argument-limit &key (method-frame-style *method-frame-style*))
(multiple-value-bind (name args info)
(frame-call frame :method-frame-style method-frame-style
:argument-limit argument-limit
:replace-dynamic-extent-objects t)
(values (cons name args) info)))
;;; This is used in constructing arg lists for debugger printing,
;;; and when needing to print unbound slots in PCL.
(defstruct (unprintable-object
(:constructor make-unprintable-object (string))
(:print-object (lambda (x s)
(print-unreadable-object (x s)
(write-string (unprintable-object-string x) s))))
(:copier nil))
(string nil :read-only t))
(declaim (freeze-type unprintable-object))
(defun replace-dynamic-extent-object (obj)
(if (stack-allocated-p obj)
(make-unprintable-object
(handler-case
(format nil "dynamic-extent: ~S" obj)
(error ()
"error printing dynamic-extent object")))
obj))
;;; If X is stack-allocated and on the current thread's stack, then return
;;; the value of *current-thread*. Otherwise, if ALL-THREADS is T, then
;;; look for X on any stack, returning the thread that contains it.
;;; If X is not stack-allocated, or allocated on a different thread's stack
;;; when ALL-THREADS is NIL, then return NIL.
(defun stack-allocated-p (x &optional all-threads)
(let ((a (get-lisp-obj-address x)))
(and (sb-vm:is-lisp-pointer a)
(cond ((and (<= (get-lisp-obj-address sb-vm:*control-stack-start*) a)
(< a (get-lisp-obj-address sb-vm:*control-stack-end*)))
sb-thread:*current-thread*)
(all-threads
(macrolet ((in-stack-range-p ()
`(and (>= a (sb-thread::thread-control-stack-start thread))
(< a (sb-thread::thread-control-stack-end thread)))))
#+win32 ; exhaustive search
(dolist (thread (sb-thread:list-all-threads)) ; conses, but I don't care
(when (in-stack-range-p)
(return thread)))
#-win32
;; find a stack whose primitive-thread is nearest and above A.
(awhen (sb-thread::avl-find>= a sb-thread::*all-threads*)
(let ((thread (sb-thread::avlnode-data it)))
(when (in-stack-range-p)
thread)))))))))
;;;; frame printing
(eval-when (:compile-toplevel :execute)
;;; This is a convenient way to express what to do for each type of
;;; lambda-list element.
(sb-xc:defmacro lambda-list-element-dispatch (element
&key
required
optional
rest
keyword
more
deleted)
`(etypecase ,element
(debug-var
,@required)
(cons
(ecase (car ,element)
(:optional ,@optional)
(:rest ,@rest)
(:keyword ,@keyword)
(:more ,@more)))
(symbol
(aver (eq ,element :deleted))
,@deleted)))
(sb-xc:defmacro lambda-var-dispatch (variable location deleted valid other)
(let ((var (gensym)))
`(let ((,var ,variable))
(cond ((eq ,var :deleted) ,deleted)
((eq (debug-var-validity ,var ,location) :valid)
,valid)
(t ,other)))))
) ; EVAL-WHEN
;;; Extract the function argument values for a debug frame.
(defun map-frame-args (thunk frame limit)
(unless (zerop limit)
(let ((debug-fun (frame-debug-fun frame)))
(dolist (element (debug-fun-lambda-list debug-fun))
(funcall thunk element)
(when (zerop (decf limit))
(return))))))
;;; When the frame is interrupted before any of the function code is called
;;; we can recover all the arguments, include the extra ones.
;;; This includes the ARG-COUNT-ERROR and UNDEFINED-FUNCTION coming from
;;; undefined-tramp.
(defun early-frame-nth-arg (n frame)
(let* ((escaped (sb-di::compiled-frame-escaped frame))
(pointer (sb-di::frame-pointer frame))
(arg-count (sb-di::sub-access-debug-var-slot
pointer sb-c:arg-count-sc escaped)))
(if (and (>= n 0)
(< n arg-count))
(sb-di::sub-access-debug-var-slot
pointer
(sb-c:standard-arg-location-sc n)
escaped)
(error "Index ~a out of bounds for ~a supplied argument~:p." n arg-count))))
;;; Return no more than LIMIT args. Aside from the default value of "no limit",
;;; the other most useful possibility is 0, if you're just going to discard the args.
;;; Any smaller value is OK too, but "be careful what you wish for" if you're going
;;; to use the argument list to restart the frame.
(defun early-frame-args (frame limit)
(unless (zerop limit)
(let* ((escaped (sb-di::compiled-frame-escaped frame))
(pointer (sb-di::frame-pointer frame))
(arg-count (sb-di::sub-access-debug-var-slot
pointer sb-c:arg-count-sc escaped)))
(loop for i below (min arg-count limit)
collect (sb-di::sub-access-debug-var-slot
pointer
(sb-c:standard-arg-location-sc i)
escaped)))))
(defun frame-args-as-list (frame limit)
(declare (type frame frame) (type (and unsigned-byte fixnum) limit))
;;; All args are available if the function has not proceeded beyond its external
;;; entry point, so every imcoming value is in its argument-passing location.
(when (sb-di::all-args-available-p frame)
(return-from frame-args-as-list (early-frame-args frame limit)))
(handler-case
(let ((location (frame-code-location frame))
(reversed-result nil))
(block enumerating
(map-frame-args
(lambda (element)
(lambda-list-element-dispatch element
:required ((push (frame-call-arg element location frame) reversed-result))
:optional ((push (frame-call-arg (second element) location frame)
reversed-result))
:keyword ((push (second element) reversed-result)
(push (frame-call-arg (third element) location frame)
reversed-result))
:deleted ((push (frame-call-arg element location frame) reversed-result))
:rest ((lambda-var-dispatch (second element) location
nil
(let ((rest (debug-var-value (second element) frame)))
(if (listp rest)
(setf reversed-result (append (reverse rest) reversed-result))
(push (make-unprintable-object "unavailable &REST argument")
reversed-result))
(return-from enumerating))
(push (make-unprintable-object
"unavailable &REST argument")
reversed-result)))
:more ((lambda-var-dispatch (second element) location
nil
(let ((context (debug-var-value (second element) frame))
(count (debug-var-value (third element) frame)))
(setf reversed-result
(append (reverse
(multiple-value-list
(sb-c:%more-arg-values context 0 count)))
reversed-result))
(return-from enumerating))
(push (make-unprintable-object "unavailable &MORE argument")
reversed-result)))))
frame limit))
(nreverse reversed-result))
(lambda-list-unavailable ()
(make-unprintable-object "unavailable lambda list"))))
(defun clean-xep (frame name args info)
(values name
(if (and (consp args)
;; EARLY-FRAME-ARGS doesn't include arg-count
(not (sb-di::all-args-available-p frame)))
(rest args)
args)
info))
(defun clean-&more-processor (name args info)
(values name
(if (consp args)
(let* ((more (last args 2))
(context (first more))
(count (second more)))
(append
(butlast args 2)
(if (fixnump count)
(multiple-value-list
(sb-c:%more-arg-values context 0 count))
(list
(make-unprintable-object "more unavailable arguments")))))
args)
info))
(defun clean-fast-method (name args style info)
(declare (type (member :minimal :normal :full) style))
(multiple-value-bind (cname cargs)
;; Make no attempt to simplify the display if ARGS could not be found
;; due to low (OPTIMIZE (DEBUG)) quality in the method.
(if (or (eq style :full) (not (listp args)))
(values name args)
(let ((gf-name (second name))
(real-args (the list (cddr args)))) ; strip .PV. and .N-M-CALL.
(if (and (eq style :minimal)
(fboundp gf-name)
(notany #'unprintable-object-p real-args)
(singleton-p (compute-applicable-methods
(fdefinition gf-name) real-args)))
(values gf-name real-args)
(values (cons :method (cdr name)) real-args))))
(values cname cargs (cons :fast-method info))))
(defun clean-frame-call (frame argument-limit name method-frame-style info)
(let ((args (frame-args-as-list frame argument-limit)))
(when (typep name '(cons (eql sb-pcl::gf-dispatch)))
(setf name (cadr name)))
(cond ((typep name '(cons (eql sb-pcl::fast-method)))
(clean-fast-method name args method-frame-style info))
((memq :external info)
(clean-xep frame name args info))
((memq :more info)
(clean-&more-processor name args info))
(t
(values name args info)))))
;;; This is an *internal* symbol of SB-DI. Tell me people don't use it directly???
;;; Otherwise why have such a verbose docstring. And why take &KEY args?
;;; We should pass in the parameters positionally. But I fear people must be using it.
(defun frame-call (frame &key (method-frame-style *method-frame-style*)
(argument-limit call-arguments-limit)
replace-dynamic-extent-objects)
"Returns as multiple values a descriptive name for the function responsible
for FRAME, arguments that that function, and a list providing additional
information about the frame.
Unavailable arguments are represented using dummy-objects printing as
#<unavailable argument>.
METHOD-FRAME-STYLE (defaulting to *METHOD-FRAME-STYLE*), determines how frames
corresponding to method functions are printed. Possible values
are :MINIMAL, :NORMAL, and :FULL. See *METHOD-FRAME-STYLE* for more
information.
If REPLACE-DYNAMIC-EXTENT-OBJECTS is true, objects allocated on the stack of
the current thread are replaced with dummy objects which can safely escape."
(let* ((debug-fun (frame-debug-fun frame))
(kind (debug-fun-kind debug-fun)))
(multiple-value-bind (name args info)
(clean-frame-call frame
argument-limit
(or (debug-fun-closure-name debug-fun frame)
(debug-fun-name debug-fun))
method-frame-style
(when kind (list kind)))
(let ((args (if (and (consp args) replace-dynamic-extent-objects)
(mapcar #'replace-dynamic-extent-object args)
args)))
(values name args info)))))
(defun ensure-printable-object (object)
(handler-case
(with-open-stream (out sb-impl::*null-broadcast-stream*)
(prin1 object out)
object)
(error (cond)
(declare (ignore cond))
(multiple-value-bind (type address)
(ignore-errors (values (type-of object)
(get-lisp-obj-address object)))
(make-unprintable-object
(if type
(format nil "error printing ~a {~x}" type address)
"error printing object"))))))
(defun frame-call-arg (var location frame)
(lambda-var-dispatch var location
(make-unprintable-object "unused argument")
(debug-var-value var frame)
(make-unprintable-object "unavailable argument")))
;;; Prints a representation of the function call causing FRAME to
;;; exist. VERBOSITY indicates the level of information to output;
;;; zero indicates just printing the DEBUG-FUN's name, and one
;;; indicates displaying call-like, one-liner format with argument
;;; values.
(defun print-frame-call (frame stream
&key print-frame-source
number
(print-pc *backtrace-print-pc*)
(argument-limit *default-argument-limit*)
(method-frame-style *method-frame-style*)
(emergency-best-effort (> *debug-command-level* 1)))
(when number
(format stream "~&~S: " (if (integerp number)
number
(frame-number frame))))
(when print-pc
(let ((debug-fun (frame-debug-fun frame)))
(when (typep debug-fun 'sb-di::compiled-debug-fun)
(format stream "#x~x "
(sap-int (sap+ (code-instructions
(sb-di::compiled-debug-fun-component debug-fun))
(sb-di::compiled-code-location-pc
(frame-code-location frame))))))))
(multiple-value-bind (name args info)
(frame-call frame :argument-limit argument-limit
:method-frame-style method-frame-style)
(pprint-logical-block (stream nil :prefix "(" :suffix ")")
(let ((*print-pretty* nil)
(*print-circle* t))
;; Since we go to some trouble to make nice informative
;; function names like (PRINT-OBJECT :AROUND (CLOWN T)), let's
;; make sure that they aren't truncated by *PRINT-LENGTH* and
;; *PRINT-LEVEL*.
(let ((*print-length* nil)
(*print-level* nil)
(name (if emergency-best-effort
(ensure-printable-object name)
name)))
(write name :stream stream :escape t :pretty (equal '(lambda ()) name)))
;; For the function arguments, we can just print normally. If
;; we hit a &REST arg, then print as many of the values as
;; possible, punting the loop over lambda-list variables since
;; any other arguments will be in the &REST arg's list of
;; values.
(let ((args (cond ((not emergency-best-effort)
args)
((consp args)
(mapcar #'ensure-printable-object args))
(t
(ensure-printable-object args)))))
(cond ((not (listp args))
(format stream " ~S" args))
(t
(dolist (arg args)
(write-char #\space stream)
(pprint-newline :linear stream)
(write arg :stream stream :escape t)))))))
(when info
(format stream " [~{~(~A~)~^,~}]" info)))
(when print-frame-source
(let* ((loc (frame-code-location frame))
(path (and (sb-di::compiled-debug-fun-p
(code-location-debug-fun loc))
(handler-case (code-location-debug-source loc)
(no-debug-blocks ())
(:no-error (source)
(debug-source-namestring source))))))
(when (or (eq print-frame-source :always)
;; Avoid showing sources for internals,
;; it will either fail anyway due to the
;; reader conditionals or show something nobody has
;; any iterest in.
(not (eql (search "SYS:SRC;" path) 0)))
(handler-case
(let ((source (handler-case
(code-location-source-form loc 0)
(error (c)
(format stream "~& error finding frame source: ~A" c)))))
(format stream "~% source: ~S" source))
(debug-condition ()
;; This is mostly noise.
(when (eq :always print-frame-source)
(format stream "~& no source available for frame")))
(error (c)
(format stream "~& error printing frame source: ~A" c)))))))
;;;; INVOKE-DEBUGGER
(defvar *debugger-hook* nil
"This is either NIL or a function of two arguments, a condition and the value
of *DEBUGGER-HOOK*. This function can either handle the condition or return
which causes the standard debugger to execute. The system passes the value
of this variable to the function because it binds *DEBUGGER-HOOK* to NIL
around the invocation.")
;;; These are bound on each invocation of INVOKE-DEBUGGER.
(defvar *debug-restarts*)
(defvar *debug-condition*)
(defvar *nested-debug-condition*)
;;; Oh, what a tangled web we weave when we preserve backwards
;;; compatibility with 1968-style use of global variables to control
;;; per-stream i/o properties; there's really no way to get this
;;; quite right, but we do what we can.
(defun funcall-with-debug-io-syntax (fun &rest rest)
(declare (type function fun))
;; Try to force the other special variables into a useful state.
(let (;; Protect from WITH-STANDARD-IO-SYNTAX some variables where
;; any default we might use is less useful than just reusing
;; the global values.
(original-package *package*)
(original-print-pretty *print-pretty*))
(with-standard-io-syntax
(with-sane-io-syntax
(let (;; We want the printer and reader to be in a useful
;; state, regardless of where the debugger was invoked
;; in the program. WITH-STANDARD-IO-SYNTAX and
;; WITH-SANE-IO-SYNTAX do much of what we want, but
;; * It doesn't affect our internal special variables
;; like *CURRENT-LEVEL-IN-PRINT*.
;; * It isn't customizable.
;; * It sets *PACKAGE* to COMMON-LISP-USER, which is not
;; helpful behavior for a debugger.
;; * There's no particularly good debugger default for
;; *PRINT-PRETTY*, since T is usually what you want
;; -- except absolutely not what you want when you're
;; debugging failures in PRINT-OBJECT logic.
;; We try to address all these issues with explicit
;; rebindings here.
(*current-level-in-print* 0)
(*package* original-package)
(*print-pretty* original-print-pretty)
;; Clear the circularity machinery to try to to reduce the
;; pain from sharing the circularity table across all
;; streams; if these are not rebound here, then setting
;; *PRINT-CIRCLE* within the debugger when debugging in a
;; state where something circular was being printed (e.g.,
;; because the debugger was entered on an error in a
;; PRINT-OBJECT method) makes a hopeless mess. Binding them
;; here does seem somewhat ugly because it makes it more
;; difficult to debug the printing-of-circularities code
;; itself; however, as far as I (WHN, 2004-05-29) can see,
;; that's almost entirely academic as long as there's one
;; shared *C-H-T* for all streams (i.e., it's already
;; unreasonably difficult to debug print-circle machinery
;; given the buggy crosstalk between the debugger streams
;; and the stream you're trying to watch), and any fix for
;; that buggy arrangement will likely let this hack go away
;; naturally.
(sb-impl::*circularity-hash-table* . nil)
(sb-impl::*circularity-counter* . nil)
(*readtable* *debug-readtable*))
(progv
;; (Why NREVERSE? PROGV makes the later entries have
;; precedence over the earlier entries.
;; *DEBUG-PRINT-VARIABLE-ALIST* is called an alist, so it's
;; expected that its earlier entries have precedence. And
;; the earlier-has-precedence behavior is mostly more
;; convenient, so that programmers can use PUSH or LIST* to
;; customize *DEBUG-PRINT-VARIABLE-ALIST*.)
(nreverse (mapcar #'car *debug-print-variable-alist*))
(nreverse (mapcar #'cdr *debug-print-variable-alist*))
(apply fun rest)))))))
;;; This function is not inlined so it shows up in the backtrace; that
;;; can be rather handy when one has to debug the interplay between
;;; *INVOKE-DEBUGGER-HOOK* and *DEBUGGER-HOOK*.
(declaim (notinline run-hook))
(defun run-hook (variable condition)
(let ((old-hook (symbol-value variable)))
(when old-hook
(progv (list variable) (list nil)
(funcall old-hook condition old-hook)))))
;;; We can bind *stack-top-hint* to a symbol, in which case this function will
;;; resolve that hint lazily before we enter the debugger.
(defun resolve-stack-top-hint ()
(let ((hint *stack-top-hint*)
(*stack-top-hint* nil))
(cond
;; No hint, just keep the debugger guts out.
((not hint)
(find-caller-frame))
;; Interrupted. Look for the interrupted frame -- if we don't find one
;; this falls back to the next case.
((and (eq hint 'invoke-interruption)
(find-interrupted-frame)))
;; Name of the first uninteresting frame.
((symbolp hint)
(find-caller-of-named-frame hint))
;; We already have a resolved hint.
(t
hint))))
(defun invoke-debugger (condition)
"Enter the debugger."
(let ((*stack-top-hint* (resolve-stack-top-hint))
(sb-impl::*deadline* nil))
;; call *INVOKE-DEBUGGER-HOOK* first, so that *DEBUGGER-HOOK* is not
;; called when the debugger is disabled
(run-hook '*invoke-debugger-hook* condition)
(run-hook '*debugger-hook* condition)
;; We definitely want *PACKAGE* to be of valid type.
;;
;; Elsewhere in the system, we use the SANE-PACKAGE function for
;; this, but here causing an exception just as we're trying to handle
;; an exception would be confusing, so instead we use a special hack.
(unless (package-name *package*)
(setf *package* (find-package :cl-user))
(format *error-output*
"The value of ~S was not an undeleted PACKAGE. It has been ~
reset to ~S."
'*package* *package*))
;; Before we start our own output, finish any pending output.
;; Otherwise, if the user tried to track the progress of his program
;; using PRINT statements, he'd tend to lose the last line of output
;; or so, which'd be confusing.
(flush-standard-output-streams)
(funcall-with-debug-io-syntax #'%invoke-debugger condition)))
(defun %print-debugger-invocation-reason (condition stream)
(format stream "~2&")
;; Note: Ordinarily it's only a matter of taste whether to use
;; FORMAT "~<...~:>" or to use PPRINT-LOGICAL-BLOCK directly, but
;; until bug 403 is fixed, PPRINT-LOGICAL-BLOCK (STREAM NIL) is
;; definitely preferred, because the FORMAT alternative was acting odd.
(pprint-logical-block (stream nil)
#-sb-thread
(format stream "debugger invoked on a ~S: ~2I~_~A" (type-of condition) condition)
#+sb-thread
(format stream
"debugger invoked on a ~S~@[ @~x~] in thread ~_~A: ~2I~_~A"
(type-of condition)
(when (boundp '*current-internal-error-context*)
(if (system-area-pointer-p *current-internal-error-context*)
(sb-alien:with-alien ((context (* os-context-t)
sb-kernel:*current-internal-error-context*))
(sap-int (sb-vm:context-pc context)))
(sap-int (sb-vm:context-pc *current-internal-error-context*))))
sb-thread:*current-thread*
condition))
(terpri stream))
(defun %invoke-debugger (condition)
(let ((*debug-condition* condition)
(*debug-restarts* (compute-restarts condition))
(*nested-debug-condition* nil))
(handler-case
;; (The initial output here goes to *ERROR-OUTPUT*, because the
;; initial output is not interactive, just an error message, and
;; when people redirect *ERROR-OUTPUT*, they could reasonably
;; expect to see error messages logged there, regardless of what
;; the debugger does afterwards.)
(unless (typep condition 'step-condition)
(%print-debugger-invocation-reason condition *error-output*))
(error (condition)
(setf *nested-debug-condition* condition)
(let ((ndc-type (type-of *nested-debug-condition*)))
(format *error-output*
"~&~@<(A ~S was caught when trying to print ~S when ~
entering the debugger. Printing was aborted and the ~
~S was stored in ~S.)~@:>~%"
ndc-type
'*debug-condition*
ndc-type
'*nested-debug-condition*))
(when (typep *nested-debug-condition* 'cell-error)
;; what we really want to know when it's e.g. an UNBOUND-VARIABLE:
(format *error-output*