source: branches/working-0711/ccl/lib/backtrace.lisp @ 8025

Last change on this file since 8025 was 8025, checked in by gb, 13 years ago

BACKTRACE-CALL-ARGUMENTS: try to show real arguments if before #args
trap.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 23.0 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17;;; backtrace.lisp
18;;; low-level support for stack-backtrace printing
19
20(in-package "CCL")
21
22#+ppc-target (require "PPC-BACKTRACE")
23#+x86-target (require "X86-BACKTRACE")
24
25
26(defparameter *backtrace-show-internal-frames* nil)
27(defparameter *backtrace-print-level* 2)
28(defparameter *backtrace-print-length* 5)
29
30;;; This PRINTS the call history on *DEBUG-IO*.  It's more dangerous
31;;; (because of stack consing) to actually return it.
32                               
33(defun print-call-history (&key context
34                                (origin (%get-frame-ptr))
35                                (detailed-p t)
36                                (count most-positive-fixnum)
37                                (start-frame-number 0))
38  (let* ((tcr (if context (bt.tcr context) (%current-tcr))))         
39    (if (eq tcr (%current-tcr))
40      (%print-call-history-internal context origin detailed-p (or count most-positive-fixnum) start-frame-number)
41      (unwind-protect
42           (progn
43             (%suspend-tcr tcr )
44             (%print-call-history-internal context origin  detailed-p
45                                           count start-frame-number))
46        (%resume-tcr tcr)))
47    (values)))
48
49(defun %show-stack-frame (p context lfun pc)
50  (handler-case
51      (multiple-value-bind (count vsp parent-vsp) (count-values-in-frame p context)
52        (declare (fixnum count))
53        (dotimes (i count)
54          (multiple-value-bind (var type name) 
55                               (nth-value-in-frame p i context lfun pc vsp parent-vsp)
56            (format t "~&  ~D " i)
57            (when name (format t "~s" name))
58            (let* ((*print-length* *backtrace-print-length*)
59                   (*print-level* *backtrace-print-level*))
60              (format t ": ~s" var))
61            (when type (format t " (~S)" type)))))
62    (error () (format t "#<error printing frame>")))
63  (terpri)
64  (terpri))
65
66(defun %show-args-and-locals (p context lfun pc)
67  (handler-case
68      (let* ((unavailable (cons nil nil)))
69        (multiple-value-bind (args locals) (arguments-and-locals context p lfun pc unavailable)
70          (format t "~&  ~s" (arglist-from-map lfun))
71          (let* ((*print-length* *backtrace-print-length*)
72                 (*print-level* *backtrace-print-level*))
73            (flet ((show-pair (pair prefix)
74                     (destructuring-bind (name . val) pair
75                       (format t "~&~a~s: " prefix name)
76                       (if (eq val unavailable)
77                         (format t "#<Unavailable>")
78                         (format t "~s" val)))))
79              (dolist (arg args)
80                (show-pair arg "   "))
81              (terpri)
82              (terpri)
83              (dolist (loc locals)
84                (show-pair loc "  "))))))
85    (error () (format t "#<error printing args and locals>")))
86  (terpri)
87  (terpri))
88
89
90(defun backtrace-call-arguments (context cfp lfun pc)
91  (collect ((call))
92    (let* ((name (function-name lfun)))
93      (if (function-is-current-definition? lfun)
94        (call name)
95        (progn
96          (call 'funcall)
97          (call `(function ,(concatenate 'string "#<" (%lfun-name-string lfun) ">")))))
98      (if (<= pc target::arg-check-trap-pc-limit)
99        (append (call) (arg-check-call-arguments cfp lfun))
100        (multiple-value-bind (req opt restp keys)
101            (function-args lfun)
102          (when (or (not (eql 0 req)) (not (eql 0 opt)) restp keys)
103            (let* ((arglist (arglist-from-map lfun)))
104              (if (null arglist)
105                (call "???")
106                (progn
107                  (dotimes (i req)
108                    (let* ((val (argument-value context cfp lfun pc (pop arglist))))
109                      (if (eq val (%unbound-marker))
110                        (call "?")
111                        (call (let* ((*print-length* *backtrace-print-length*)
112                                     (*print-level* *backtrace-print-level*))
113                                (format nil "~s" val))))))
114                  (if (or restp keys (not (eql opt 0)))
115                    (call "[...]"))))))
116          (call))))))
117
118
119;;; Return a list of "interesting" frame addresses in context, most
120;;; recent first.
121(defun %stack-frames-in-context (context &optional (include-internal *backtrace-show-internal-frames*))
122  (collect ((frames))
123    (do* ((p (bt.youngest context) (parent-frame p context))
124          (q (bt.oldest context)))
125         ((eql p q) (frames))
126      (when (or (not (catch-csp-p p context)) include-internal)
127        (when (or (cfp-lfun p) include-internal)
128          (frames p))))))
129   
130(defun %print-call-history-internal (context origin detailed-p
131                                             &optional (count most-positive-fixnum) (skip-initial 0))
132  (let ((*standard-output* *debug-io*)
133        (*print-circle* nil)
134        (p origin)
135        (q (last-frame-ptr context)))
136    (dotimes (i skip-initial)
137      (setq p (parent-frame p context))
138      (when (or (null p) (eq p q) (%stack< q p context))
139        (return (setq p nil))))
140    (do* ((frame-number (or skip-initial 0) (1+ frame-number))
141          (i 0 (1+ i))
142          (p p (parent-frame p context)))
143         ((or (null p) (eq p q) (%stack< q p context)
144              (>= i count))
145          (values))
146      (declare (fixnum frame-number i))
147      (when (or (not (catch-csp-p p context))
148                *backtrace-show-internal-frames*)
149        (multiple-value-bind (lfun pc) (cfp-lfun p)
150          (when (or lfun *backtrace-show-internal-frames*)
151            (unless (and (typep detailed-p 'fixnum)
152                         (not (= (the fixnum detailed-p) frame-number)))
153              (format t "~&~c(~x) : ~D ~a ~d"
154                      (let* ((q (parent-frame p context)))
155                        (if (and q (exception-frame-p q)) #\- #\space))
156                      (index->address p) frame-number
157                      (if lfun (backtrace-call-arguments context p lfun pc))
158                      pc)
159              (when detailed-p
160                (if (eq detailed-p :raw)
161                  (%show-stack-frame p context lfun pc)
162                  (%show-args-and-locals p context lfun pc))))))))))
163
164
165(defun %access-lisp-data (vstack-index)
166  (%fixnum-ref vstack-index))
167
168(defun %store-lisp-data (vstack-index value)
169  (setf (%fixnum-ref vstack-index) value))
170
171(defun closed-over-value (data)
172  (if (closed-over-value-p data)
173    (uvref data 0)
174    data))
175
176(defun set-closed-over-value (value-cell value)
177  (setf (uvref value-cell 0) value))
178
179
180
181;;; Act as if VSTACK-INDEX points at some lisp data & return that data.
182(defun access-lisp-data (vstack-index)
183  (closed-over-value (%access-lisp-data vstack-index)))
184
185(defun find-local-name (cellno lfun pc)
186  (let* ((n cellno))
187    (when lfun
188      (multiple-value-bind (mask where) (registers-used-by lfun pc)
189        (if (and where (< (1- where) n (+ where (logcount mask))))
190          (let ((j *saved-register-count*))
191            (decf n where)
192            (loop (loop (if (logbitp (decf j) mask) (return)))
193                  (if (< (decf n) 0) (return)))
194            (values (format nil "saved ~a" (aref *saved-register-names* j))
195                    nil))
196          (multiple-value-bind (nreq nopt restp nkeys junk optinitp junk ncells nclosed)
197                               (if lfun (function-args lfun))
198            (declare (ignore junk optinitp))
199            (if nkeys (setq nkeys (+ nkeys nkeys)))
200            (values
201             (if (and ncells (< n ncells))
202               (if (< n nclosed)
203                 :inherited
204                 (if (< (setq n (- n nclosed)) nreq)
205                   "required"
206                   (if (< (setq n (- n nreq)) nopt)
207                     "optional"
208                     (progn
209                       (setq n (- n nopt))
210                       (progn
211                         (if (and nkeys (< n nkeys))
212                           (if (not (logbitp 0 n)) ; a keyword
213                             "keyword"
214                             "key-supplied-p")
215                           (progn
216                             (if nkeys (setq n (- n nkeys)))
217                             (if (and restp (zerop n))
218                               "rest"
219                               "opt-supplied-p")))))))))
220             (match-local-name cellno (function-symbol-map lfun) pc))))))))
221
222(defun map-entry-value (context cfp lfun pc idx unavailable)
223  (declare (fixnum pc idx))
224  (let* ((info (function-symbol-map lfun)))
225    (if (null info)
226      unavailable
227      (let* ((addrs (cdr info))
228             (i (* 3 idx))
229             (addr (svref addrs i))
230             (startpc (svref addrs (the fixnum (+ i 1))))
231             (endpc (svref addrs (the fixnum (+ i 2)))))
232        (declare (fixnum i addr startpc endpc))
233        (if (or (< pc startpc)
234                (>= pc endpc))
235          unavailable
236          (let* ((value (if (= #o77 (ldb (byte 6 0) addr))
237                          (raw-frame-ref cfp context (ash addr (- (+ target::word-shift 6)))
238                                         unavailable)
239                          (find-register-argument-value context cfp addr unavailable))))
240            (if (typep value 'value-cell)
241              (uvref value 0)
242              value)))))))
243
244;;; Returns non-nil on success (not newval)
245(defun set-map-entry-value (context cfp lfun pc idx newval)
246  (declare (fixnum pc idx))
247  (let* ((unavailable (cons nil nil))
248         (value (map-entry-value context cfp lfun pc idx unavailable)))
249    (if (eq value unavailable)
250      nil
251      (if (typep value 'value-cell)
252        (progn (setf (uvref value 0) newval) t)
253
254        (let* ((addrs (cdr (function-symbol-map lfun)))
255               (addr (svref addrs (the fixnum (* 3 idx)))))
256          (declare (fixnum  addr))
257          (if (= #o77 (ldb (byte 6 0) addr))
258            (raw-frame-set cfp context (ash addr (- (+ target::word-shift 6))) newval)
259            (set-register-argument-value context cfp addr newval))
260          t)))))
261
262         
263(defun argument-value (context cfp lfun pc name &optional (quote t))
264  (declare (fixnum pc))
265  (let* ((info (function-symbol-map lfun))
266         (unavailable (%unbound-marker)))
267    (if (null info)
268      unavailable
269      (let* ((names (car info))
270             (addrs (cdr info)))
271        (do* ((nname (1- (length names)) (1- nname))
272              (naddr (- (length addrs) 3) (- naddr 3)))
273             ((or (< nname 0) (< naddr 0)) unavailable)
274          (declare (fixnum nname naddr))
275          (when (eq (svref names nname) name)
276            (let* ((value
277                    (let* ((addr (svref addrs naddr))
278                           (startpc (svref addrs (the fixnum (1+ naddr))))
279                           (endpc (svref addrs (the fixnum (+ naddr 2)))))
280                      (declare (fixnum addr startpc endpc))
281                      (if (or (< pc startpc)
282                              (>= pc endpc))
283                        unavailable
284                        (if (= #o77 (ldb (byte 6 0) addr))
285                          (raw-frame-ref cfp context (ash addr (- (+ target::word-shift 6)))
286                                         unavailable)
287                          (find-register-argument-value context cfp addr unavailable))))))
288              (if (typep value 'value-cell)
289                (setq value (uvref value 0)))
290              (if (or (not quote) (self-evaluating-p value))
291                (return value)
292                (return (list 'quote value))))))))))
293
294
295
296(defun raw-frame-ref (cfp context index bad)
297  (%raw-frame-ref cfp context index bad))
298
299(defun raw-frame-set (cfp context index new)
300  (%raw-frame-set cfp context index new))
301 
302(defun find-register-argument-value (context cfp regval bad)
303  (%find-register-argument-value context cfp regval bad))
304
305(defun set-register-argument-value (context cfp regval newval)
306  (%set-register-argument-value context cfp regval newval))
307
308   
309
310(defun dbg-form (frame-number)
311  (when *break-frame*
312    (let* ((cfp (nth-raw-frame frame-number *break-frame* nil)))
313      (if (and cfp (not (catch-csp-p cfp nil)))
314        (multiple-value-bind (function pc)
315            (cfp-lfun cfp)
316          (if (and function
317                   (function-is-current-definition? function))
318            (block %cfp-form
319              (collect ((form))
320                (multiple-value-bind (nreq nopt restp keys allow-other-keys
321                                           optinit lexprp ncells nclosed)
322                    (function-args function)
323                  (declare (ignore ncells))
324                  (unless (or lexprp restp (> 0 nclosed) (> 0 nopt) keys allow-other-keys
325                              optinit)
326                    (let* ((name (function-name function)))
327                      (multiple-value-bind (arglist win)
328                          (arglist-from-map function)
329                      (when (and win name (symbolp name))
330                        (form name)
331                        (dotimes (i nreq)
332                          (let* ((val (argument-value nil cfp function pc (pop arglist))))
333                            (if (closed-over-value-p val)
334                              (setq val (%svref val target::value-cell.value-cell)))
335                            (if (eq val (%unbound-marker))
336                              (return-from %cfp-form nil))
337                            (form val))))))))
338                (form)))))))))
339
340(defun function-args (lfun)
341  "Returns 9 values, as follows:
342     req = number of required arguments
343     opt = number of optional arguments
344     restp = t if rest arg
345     keys = number of keyword arguments or NIL if &key not mentioned
346     allow-other-keys = t if &allow-other-keys present
347     optinit = t if any optional arg has non-nil default value or supplied-p
348               variable
349     lexprp = t if function is a lexpr, in which case all other values are
350              undefined.
351     ncells = number of stack frame cells used by all arguments.
352     nclosed = number of inherited values (now counted distinctly from required)
353     All numeric values (but ncells) are mod 64."
354  (let* ((bits (lfun-bits lfun))
355         (req (ldb $lfbits-numreq bits))
356         (opt (ldb $lfbits-numopt bits))
357         (restp (logbitp $lfbits-rest-bit bits))
358         (keyvect (lfun-keyvect lfun))
359         (keys (and keyvect (length keyvect)))
360         (allow-other-keys (logbitp $lfbits-aok-bit bits))
361         (optinit (logbitp $lfbits-optinit-bit bits))
362         (lexprp (logbitp $lfbits-restv-bit bits))
363         (nclosed (ldb $lfbits-numinh bits)))
364    (values req opt restp keys allow-other-keys optinit lexprp
365            (unless (or lexprp)
366              (+ req opt (if restp 1 0) (if keys (+ keys keys) 0)
367                 (if optinit opt 0) nclosed))
368            nclosed)))
369
370;;; If we can tell reliably, return the function's minimum number of
371;;; non-inherited arguments, the maximum number of such arguments (or NIL),
372;;; and the actual number of such arguments.  We "can't tell" if either
373;;; of the arguments to this function are null, and we can't tell reliably
374;;; if any of the lfbits fields are full.
375(defun min-max-actual-args (fn nargs)
376  (let* ((lfbits (if (and fn nargs)
377                   (lfun-bits fn)
378                   -1))
379         (raw-req (ldb $lfbits-numreq lfbits))
380         (raw-opt (ldb $lfbits-numopt lfbits))
381         (raw-inh (ldb $lfbits-numinh lfbits)))
382    (declare (fixnum raw-req raw-opt raw-inh))
383    (if (or (eql raw-req (1- (ash 1 (byte-size $lfbits-numreq))))
384            (eql raw-opt (1- (ash 1 (byte-size $lfbits-numopt))))
385            (eql raw-inh (1- (ash 1 (byte-size $lfbits-numinh)))))
386      (values nil nil nil)
387      (values raw-req
388              (unless (or (lfun-keyvect fn)
389                          (logbitp $lfbits-rest-bit lfbits)
390                          (logbitp $lfbits-restv-bit lfbits))
391                (+ raw-req raw-opt))
392              (- nargs raw-inh)))))
393
394
395
396(defun closed-over-value-p (value)
397  (eql target::subtag-value-cell (typecode value)))
398
399
400(defun variables-in-scope (lfun pc)
401  ;; Return a list of all symbol names "in scope" in the function lfun
402  ;; at relative program counter PC, using the function's symbol map.
403  ;; The list will be ordered so that least-recent bindings appear first.
404  ;; Return a list of the matching symbol map entries as a second value
405  (when pc
406    (locally (declare (fixnum pc))
407      (let* ((map (function-symbol-map lfun))
408             (names (car map))
409             (info (cdr map)))
410        (when map
411          (let* ((vars ())
412                 (indices ()))
413            (dotimes (i (length names) (values vars indices))
414              (let* ((start-pc (aref info (1+ (* 3 i))))
415                     (end-pc (aref info (+ 2 (* 3 i)))))
416                (declare (fixnum start-pc end-pc))
417                (when (and (>= pc start-pc)
418                           (< pc end-pc))
419                  (push i indices)
420                  (push (svref names i) vars))))))))))
421
422
423(defun arg-value (context cfp lfun pc unavailable name)
424  (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc)
425    (multiple-value-bind (valid req opt rest keys)
426        (arg-names-from-map lfun pc)
427      (if valid
428        (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys)))
429               (pos (position name vars)))
430          (if (and pos (< pos nargs))
431            (map-entry-value context cfp lfun pc (nth pos map-indices) unavailable)
432            unavailable))
433        unavailable))))
434
435(defun local-value (context cfp lfun pc unavailable name)
436  (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc)
437    (multiple-value-bind (valid req opt rest keys)
438        (arg-names-from-map lfun pc)
439      (if valid
440        (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys)))
441               (names (nthcdr nargs vars))
442               (indices (nthcdr nargs map-indices))
443               (pos (if (typep name 'unsigned-byte)
444                      name
445                      (position name names :from-end t))))
446          (if (and pos (< pos nargs))
447            (map-entry-value context cfp lfun pc (nth pos indices) unavailable)
448            unavailable))
449        unavailable))))
450
451(defun set-arg-value (context cfp lfun pc name new)
452  (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc)
453    (multiple-value-bind (valid req opt rest keys)
454        (arg-names-from-map lfun pc)
455      (if valid
456        (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys)))
457               (pos (position name vars)))
458          (when (and pos (< pos nargs))
459            (set-map-entry-value context cfp lfun pc (nth pos map-indices) new)))))))
460
461(defun set-local-value (context cfp lfun pc name new)
462  (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc)
463    (multiple-value-bind (valid req opt rest keys)
464        (arg-names-from-map lfun pc)
465      (if valid
466        (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys)))
467               (names (nthcdr nargs vars))
468               (indices (nthcdr nargs map-indices))
469               (pos (if (typep name 'unsigned-byte)
470                      name
471                      (position name names :from-end t))))
472          (if (and pos (< pos nargs))
473            (set-map-entry-value context cfp lfun pc (nth pos indices) new)))))))
474
475
476(defun arguments-and-locals (context cfp lfun pc &optional unavailable)
477  (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc)
478    (collect ((args)
479              (locals))
480      (multiple-value-bind (valid req opt rest keys)
481          (arg-names-from-map lfun pc)
482        (when valid
483          (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys)))
484                 (nlocals (- (length vars) nargs))
485                 (local-vars (nthcdr nargs vars))
486                 (local-indices (nthcdr nargs map-indices))
487                 (arg-vars (nbutlast vars nlocals))
488                 (arg-indices (nbutlast map-indices nlocals)))
489            (flet ((get-arg-value (name)
490                     (let* ((pos (position name arg-vars :test #'eq)))
491                       (when pos
492                         (args (cons name (map-entry-value context cfp lfun pc (nth pos arg-indices) unavailable))))))
493                   (get-local-value (name)
494                     (when name
495                       (locals (cons name (map-entry-value context cfp lfun pc (pop local-indices) unavailable))))))
496              (dolist (name req)
497                (get-arg-value name))
498              (dolist (name opt)
499                (get-arg-value name))
500              (when rest
501                (get-arg-value rest))
502              (dolist (name keys)
503                (get-arg-value name))
504              #+no
505              (setq local-vars (nreverse local-vars)
506                    local-indices (nreverse local-indices))
507              (dolist (name local-vars)
508                (get-local-value name)))))
509        (values (args) (locals))))))
510                   
511           
512
513(defun safe-cell-value (val)
514  val)
515
516(defun closure-closed-over-values (closure)
517  (when (typep closure 'compiled-lexical-closure)
518    (let* ((inner (closure-function closure))
519           (nclosed (nth-value 8 (function-args inner)))
520           (names (car (function-symbol-map inner))))
521      (when nclosed
522        (collect ((cells))
523          (do* ((i (1- (length names)) (1- i))
524                (k 0 (1+ k))
525                (idx 2 (1+ idx)))
526               ((= k nclosed) (reverse (cells)))
527            (let* ((name (svref names i))
528                   (imm (nth-immediate closure idx)))
529              (cells (list name (if (closed-over-value-p imm)
530                                  (closed-over-value imm)
531                                  imm))))))))))
532
533     
534;;; Find the oldest binding frame that binds the same symbol as
535;;; FRAME in context.  If found, return the saved value of that
536;;; binding, else the value of the symbol in the context's thread.
537(defun oldest-binding-frame-value (context frame)
538  (let* ((oldest nil)
539         (binding-index (%fixnum-ref frame (ash 1 target::fixnum-shift))))
540    (do* ((db (db-link context) (%fixnum-ref db 0)))
541         ((eq frame db)
542          (if oldest
543            (%fixnum-ref oldest (ash 2 target::fixnum-shift))
544            (let* ((symbol (binding-index-symbol binding-index)))
545              (if context
546                (symbol-value-in-tcr symbol (bt.tcr context))
547                (%sym-value symbol)))))
548      (if (eq (%fixnum-ref db (ash 1 target::fixnum-shift)) binding-index)
549        (setq oldest db)))))
550
551(defun (setf oldest-binding-frame-value) (new context frame)
552  (let* ((oldest nil)
553         (binding-index (%fixnum-ref frame (ash 1 target::fixnum-shift))))
554    (do* ((db (db-link context) (%fixnum-ref db 0)))
555         ((eq frame db)
556          (if oldest
557            (setf (%fixnum-ref oldest (ash 2 target::fixnum-shift)) new)
558            (let* ((symbol (binding-index-symbol binding-index)))
559              (if context
560                (setf (symbol-value-in-tcr symbol (bt.tcr context)) new)
561                (%set-sym-value symbol new)))))
562      (if (eq (%fixnum-ref db (ash 1 target::fixnum-shift)) binding-index)
563        (setq oldest db)))))
564   
565
566
567;;; End of backtrace.lisp
Note: See TracBrowser for help on using the repository browser.