source: trunk/ccl/lib/backtrace.lisp @ 6928

Last change on this file since 6928 was 6928, checked in by gb, 14 years ago

%show-args-and-locals, %stack-frames-in-context: changes for new
backtrace presentation.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 17.1 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  (multiple-value-bind (count vsp parent-vsp) (count-values-in-frame p context)
51    (declare (fixnum count))
52    (dotimes (i count)
53      (multiple-value-bind (var type name) 
54          (nth-value-in-frame p i context lfun pc vsp parent-vsp)
55        (format t "~&  ~D " i)
56        (when name (format t "~s" name))
57        (let* ((*print-length* *backtrace-print-length*)
58               (*print-level* *backtrace-print-level*))
59          (format t ": ~s" var))
60        (when type (format t " (~S)" type)))))
61  (terpri)
62  (terpri))
63
64(defun %show-args-and-locals (p context lfun pc)
65  (multiple-value-bind (args locals) (arguments-and-locals context p lfun pc)
66    (format t "~&  ~s" (arglist-from-map lfun))
67    (let* ((*print-length* *backtrace-print-length*)
68           (*print-level* *backtrace-print-level*))
69      (flet ((show-pair (pair prefix)
70               (destructuring-bind (name . val) pair
71                 (format t "~&~a~s: " prefix name)
72                 (if (eq val (%unbound-marker))
73                   (format t "#<Unavailable>")
74                   (format t "~s" val)))))
75        (dolist (arg args)
76          (show-pair arg "   "))
77        (terpri)
78        (terpri)
79        (dolist (loc locals)
80          (show-pair loc "  "))
81        (terpri)
82        (terpri)))))
83
84
85(defun backtrace-call-arguments (context cfp lfun pc)
86  (collect ((call))
87    (let* ((name (function-name lfun)))
88      (if (function-is-current-definition? lfun)
89        (call name)
90        (progn
91          (call 'funcall)
92          (call `(function ,(concatenate 'string "#<" (%lfun-name-string lfun) ">")))))
93      (multiple-value-bind (req opt restp keys)
94          (function-args lfun)
95        (when (or (not (eql 0 req)) (not (eql 0 opt)) restp keys)
96          (let* ((arglist (arglist-from-map lfun)))
97            (if (null arglist)
98              (call "???")
99              (progn
100                (dotimes (i req)
101                  (let* ((val (argument-value context cfp lfun pc (pop arglist))))
102                    (if (eq val (%unbound-marker))
103                      (call "?")
104                      (call (let* ((*print-length* *backtrace-print-length*)
105                                   (*print-level* *backtrace-print-level*))
106                              (format nil "~s" val))))))
107                (if (or restp keys (not (eql opt 0)))
108                  (call "[...]"))
109                ))))))
110    (call)))
111
112
113;;; Return a list of "interesting" frame addresses in context, most
114;;; recent first.
115(defun %stack-frames-in-context (context &optional (include-internal *backtrace-show-internal-frames*))
116  (collect ((frames))
117    (do* ((p (bt.youngest context) (parent-frame p context))
118          (q (bt.oldest context)))
119         ((eql p q) (frames))
120      (when (or (not (catch-csp-p p context)) include-internal)
121        (when (or (cfp-lfun p) include-internal)
122          (frames p))))))
123   
124(defun %print-call-history-internal (context origin detailed-p
125                                             &optional (count most-positive-fixnum) (skip-initial 0))
126  (let ((*standard-output* *debug-io*)
127        (*print-circle* nil)
128        (p origin)
129        (q (last-frame-ptr context)))
130    (dotimes (i skip-initial)
131      (setq p (parent-frame p context))
132      (when (or (null p) (eq p q) (%stack< q p context))
133        (return (setq p nil))))
134    (do* ((frame-number (or skip-initial 0) (1+ frame-number))
135          (i 0 (1+ i))
136          (p p (parent-frame p context)))
137         ((or (null p) (eq p q) (%stack< q p context)
138              (>= i count))
139          (values))
140      (declare (fixnum frame-number i))
141      (when (or (not (catch-csp-p p context))
142                *backtrace-show-internal-frames*)
143        (multiple-value-bind (lfun pc) (cfp-lfun p)
144          (when (or lfun *backtrace-show-internal-frames*)
145            (unless (and (typep detailed-p 'fixnum)
146                         (not (= (the fixnum detailed-p) frame-number)))
147              (format t "~&(~x) : ~D ~a ~d"
148                      (index->address p) frame-number
149                      (if lfun (backtrace-call-arguments context p lfun pc))
150                      pc)
151              (when detailed-p
152                (if (eq detailed-p :raw)
153                  (%show-stack-frame p context lfun pc)
154                  (%show-args-and-locals p context lfun pc))))))))))
155
156
157(defun %access-lisp-data (vstack-index)
158  (%fixnum-ref vstack-index))
159
160(defun %store-lisp-data (vstack-index value)
161  (setf (%fixnum-ref vstack-index) value))
162
163(defun closed-over-value (data)
164  (if (closed-over-value-p data)
165    (uvref data 0)
166    data))
167
168(defun set-closed-over-value (value-cell value)
169  (setf (uvref value-cell 0) value))
170
171
172
173;;; Act as if VSTACK-INDEX points at some lisp data & return that data.
174(defun access-lisp-data (vstack-index)
175  (closed-over-value (%access-lisp-data vstack-index)))
176
177(defun find-local-name (cellno lfun pc)
178  (let* ((n cellno))
179    (when lfun
180      (multiple-value-bind (mask where) (registers-used-by lfun pc)
181        (if (and where (< (1- where) n (+ where (logcount mask))))
182          (let ((j *saved-register-count*))
183            (decf n where)
184            (loop (loop (if (logbitp (decf j) mask) (return)))
185                  (if (< (decf n) 0) (return)))
186            (values (format nil "saved ~a" (aref *saved-register-names* j))
187                    nil))
188          (multiple-value-bind (nreq nopt restp nkeys junk optinitp junk ncells nclosed)
189                               (if lfun (function-args lfun))
190            (declare (ignore junk optinitp))
191            (if nkeys (setq nkeys (+ nkeys nkeys)))
192            (values
193             (if (and ncells (< n ncells))
194               (if (< n nclosed)
195                 :inherited
196                 (if (< (setq n (- n nclosed)) nreq)
197                   "required"
198                   (if (< (setq n (- n nreq)) nopt)
199                     "optional"
200                     (progn
201                       (setq n (- n nopt))
202                       (progn
203                         (if (and nkeys (< n nkeys))
204                           (if (not (logbitp 0 n)) ; a keyword
205                             "keyword"
206                             "key-supplied-p")
207                           (progn
208                             (if nkeys (setq n (- n nkeys)))
209                             (if (and restp (zerop n))
210                               "rest"
211                               "opt-supplied-p")))))))))
212             (match-local-name cellno (function-symbol-map lfun) pc))))))))
213
214(defun argument-value (context cfp lfun pc name &optional (quote t))
215  (declare (fixnum pc))
216  (let* ((info (function-symbol-map lfun))
217         (unavailable (%unbound-marker)))
218    (if (null info)
219      unavailable
220      (let* ((names (car info))
221             (addrs (cdr info)))
222        (do* ((nname (1- (length names)) (1- nname))
223              (naddr (- (length addrs) 3) (- naddr 3)))
224             ((or (< nname 0) (< naddr 0)) unavailable)
225          (declare (fixnum nname naddr))
226          (when (eq (svref names nname) name)
227            (let* ((value
228                    (let* ((addr (svref addrs naddr))
229                           (startpc (svref addrs (the fixnum (1+ naddr))))
230                           (endpc (svref addrs (the fixnum (+ naddr 2)))))
231                      (declare (fixnum addr startpc endpc))
232                      (if (or (< pc startpc)
233                              (>= pc endpc))
234                        unavailable
235                        (if (= #o77 (ldb (byte 6 0) addr))
236                          (raw-frame-ref cfp context (ash addr (- (+ target::word-shift 6)))
237                                         unavailable)
238                          (find-register-argument-value context cfp addr unavailable))))))
239              (if (typep value 'value-cell)
240                (setq value (uvref value 0)))
241              (if (or (not quote) (self-evaluating-p value))
242                (return value)
243                (return (list 'quote value))))))))))
244
245
246
247(defun raw-frame-ref (cfp context index bad)
248  (%raw-frame-ref cfp context index bad))
249 
250(defun find-register-argument-value (context cfp regval bad)
251  (%find-register-argument-value context cfp regval bad))
252   
253
254(defun dbg-form (frame-number)
255  (when *break-frame*
256    (let* ((cfp (nth-raw-frame frame-number *break-frame* nil)))
257      (if (and cfp (not (catch-csp-p cfp nil)))
258        (multiple-value-bind (function pc)
259            (cfp-lfun cfp)
260          (if (and function
261                   (function-is-current-definition? function))
262            (block %cfp-form
263              (collect ((form))
264                (multiple-value-bind (nreq nopt restp keys allow-other-keys
265                                           optinit lexprp ncells nclosed)
266                    (function-args function)
267                  (declare (ignore ncells))
268                  (unless (or lexprp restp (> 0 nclosed) (> 0 nopt) keys allow-other-keys
269                              optinit)
270                    (let* ((name (function-name function)))
271                      (multiple-value-bind (arglist win)
272                          (arglist-from-map function)
273                      (when (and win name (symbolp name))
274                        (form name)
275                        (dotimes (i nreq)
276                          (let* ((val (argument-value nil cfp function pc (pop arglist))))
277                            (if (closed-over-value-p val)
278                              (setq val (%svref val target::value-cell.value-cell)))
279                            (if (eq val (%unbound-marker))
280                              (return-from %cfp-form nil))
281                            (form val))))))))
282                (form)))))))))
283
284(defun function-args (lfun)
285  "Returns 9 values, as follows:
286     req = number of required arguments
287     opt = number of optional arguments
288     restp = t if rest arg
289     keys = number of keyword arguments or NIL if &key not mentioned
290     allow-other-keys = t if &allow-other-keys present
291     optinit = t if any optional arg has non-nil default value or supplied-p
292               variable
293     lexprp = t if function is a lexpr, in which case all other values are
294              undefined.
295     ncells = number of stack frame cells used by all arguments.
296     nclosed = number of inherited values (now counted distinctly from required)
297     All numeric values (but ncells) are mod 64."
298  (let* ((bits (lfun-bits lfun))
299         (req (ldb $lfbits-numreq bits))
300         (opt (ldb $lfbits-numopt bits))
301         (restp (logbitp $lfbits-rest-bit bits))
302         (keyvect (lfun-keyvect lfun))
303         (keys (and keyvect (length keyvect)))
304         (allow-other-keys (logbitp $lfbits-aok-bit bits))
305         (optinit (logbitp $lfbits-optinit-bit bits))
306         (lexprp (logbitp $lfbits-restv-bit bits))
307         (nclosed (ldb $lfbits-numinh bits)))
308    (values req opt restp keys allow-other-keys optinit lexprp
309            (unless (or lexprp)
310              (+ req opt (if restp 1 0) (if keys (+ keys keys) 0)
311                 (if optinit opt 0) nclosed))
312            nclosed)))
313
314;;; If we can tell reliably, return the function's minimum number of
315;;; non-inherited arguments, the maximum number of such arguments (or NIL),
316;;; and the actual number of such arguments.  We "can't tell" if either
317;;; of the arguments to this function are null, and we can't tell reliably
318;;; if any of the lfbits fields are full.
319(defun min-max-actual-args (fn nargs)
320  (let* ((lfbits (if (and fn nargs)
321                   (lfun-bits fn)
322                   -1))
323         (raw-req (ldb $lfbits-numreq lfbits))
324         (raw-opt (ldb $lfbits-numopt lfbits))
325         (raw-inh (ldb $lfbits-numinh lfbits)))
326    (declare (fixnum raw-req raw-opt raw-inh))
327    (if (or (eql raw-req (1- (ash 1 (byte-size $lfbits-numreq))))
328            (eql raw-opt (1- (ash 1 (byte-size $lfbits-numopt))))
329            (eql raw-inh (1- (ash 1 (byte-size $lfbits-numinh)))))
330      (values nil nil nil)
331      (values raw-req
332              (unless (or (lfun-keyvect fn)
333                          (logbitp $lfbits-rest-bit lfbits)
334                          (logbitp $lfbits-restv-bit lfbits))
335                (+ raw-req raw-opt))
336              (- nargs raw-inh)))))
337
338
339
340(defun closed-over-value-p (value)
341  (eql target::subtag-value-cell (typecode value)))
342
343
344(defun variables-in-scope (lfun pc)
345  ;; Return a list of all symbol names "in scope" in the function lfun
346  ;; at relative program counter PC, using the function's symbol map.
347  ;; The list will be ordered so that least-recent bindings appear first.
348  (when pc
349    (locally (declare (fixnum pc))
350      (let* ((map (function-symbol-map lfun))
351             (names (car map))
352             (info (cdr map)))
353        (when map
354          (let* ((vars ()))
355            (dotimes (i (length names) vars)
356              (let* ((start-pc (aref info (1+ (* 3 i))))
357                     (end-pc (aref info (+ 2 (* 3 i)))))
358                (declare (fixnum start-pc end-pc))
359                (when (and (>= pc start-pc)
360                           (< pc end-pc))
361                  (push (svref names i) vars))))))))))
362
363(defun arguments-and-locals (context cfp lfun pc)
364  (let* ((vars (variables-in-scope lfun pc)))
365    (collect ((args)
366              (locals))
367    (multiple-value-bind (valid req opt rest keys)
368        (arg-names-from-map lfun pc)
369      (when valid
370        (flet ((get-arg-value (name)
371                 (let* ((avail (member name vars :test #'eq)))
372                   (if avail
373                     (setf (car (member name vars :test #'eq)) nil))
374                   (args (cons name (argument-value context cfp lfun pc name nil)))))
375               (get-local-value (name)
376                 (when name
377                   (locals (cons name (argument-value context cfp lfun pc name nil))))))
378          (dolist (name req)
379            (get-arg-value name))
380          (dolist (name opt)
381            (get-arg-value name))
382          (when rest
383            (get-arg-value rest))
384          (dolist (name keys)
385            (get-arg-value name))
386          (dolist (name vars)
387            (get-local-value name))))
388      (values (args) (locals))))))
389                   
390           
391
392(defun safe-cell-value (val)
393  val)
394
395(defun closure-closed-over-values (closure)
396  (when (typep closure 'compiled-lexical-closure)
397    (let* ((inner (closure-function closure))
398           (nclosed (nth-value 8 (function-args inner)))
399           (names (car (function-symbol-map inner))))
400      (when nclosed
401        (collect ((cells))
402          (do* ((i (1- (length names)) (1- i))
403                (k 0 (1+ k))
404                (idx 2 (1+ idx)))
405               ((= k nclosed) (reverse (cells)))
406            (let* ((name (svref names i))
407                   (imm (nth-immediate closure idx)))
408              (cells (list name (if (closed-over-value-p imm)
409                                  (closed-over-value imm)
410                                  imm))))))))))
411
412     
413;;; Find the oldest binding frame that binds the same symbol as
414;;; FRAME in context.  If found, return the saved value of that
415;;; binding, else the value of the symbol in the context's thread.
416(defun oldest-binding-frame-value (context frame)
417  (let* ((oldest nil)
418         (binding-index (%fixnum-ref frame (ash 1 target::fixnum-shift))))
419    (do* ((db (db-link context) (%fixnum-ref db 0)))
420         ((eq frame db)
421          (if oldest
422            (%fixnum-ref oldest (ash 2 target::fixnum-shift))
423            (let* ((symbol (binding-index-symbol binding-index)))
424              (if context
425                (symbol-value-in-tcr symbol (bt.tcr context))
426                (%sym-value symbol)))))
427      (if (eq (%fixnum-ref db (ash 1 target::fixnum-shift)) binding-index)
428        (setq oldest db)))))
429   
430
431
432;;; End of backtrace.lisp
Note: See TracBrowser for help on using the repository browser.