source: branches/working-0710/ccl/lib/backtrace.lisp @ 7409

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

Implement setting frame values.

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