source: trunk/source/lib/backtrace.lisp @ 11659

Last change on this file since 11659 was 11659, checked in by gz, 11 years ago

Make print-call-history and backtrace-as-list support a :process argument to get the backtrace of that process without interrupting it.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 30.9 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(defparameter *backtrace-format* #+ccl-0711 :direct #-ccl-0711 :traditional
31  "If :TRADITIONAL, shows calls to non-toplevel functions using FUNCALL, and shows frame address values.
32   If :DIRECT, uses a more streamlined format.")
33
34(defun context-for-suspended-tcr (tcr)
35  (let ((frame-ptr (%tcr-frame-ptr tcr)))
36    (new-backtrace-info nil
37                        frame-ptr ;; youngest - not used
38                        frame-ptr ;; oldest - not used
39                        tcr
40                        nil       ;; condition - not used
41                        frame-ptr ;; current
42                        #+ppc-target *fake-stack-frames*
43                        #+x86-target frame-ptr
44                        (%fixnum-ref tcr target::tcr.db-link)
45                        0         ;; break level - not used
46                        )))
47 
48
49(defun backtrace-as-list (&key
50                          context
51                          process
52                          origin
53                          (count target::target-most-positive-fixnum)
54                          (start-frame-number 0)
55                          (stream *debug-io*)
56                          (print-level *backtrace-print-level*)
57                          (print-length *backtrace-print-length*)
58                          (show-internal-frames *backtrace-show-internal-frames*))
59  "Returns a list representing the backtrace.
60Each element in the list is a list that describes the call in one stack frame:
61   (function arg1 arg2 ...)
62The arguments are represented by strings, the function is a symbol or a function
63object."
64  (when (null count) (setq count target::target-most-positive-fixnum))
65  (when (and context process (neq (bt.tcr context) (process-tcr process)))
66    (error "Context ~s doesn't correspond to the process ~s" context process))
67  (let* ((tcr (cond (context (bt.tcr context))
68                    (process (process-tcr process))
69                    (t (%current-tcr))))
70         (*debug-io* stream)
71         (*backtrace-print-level* print-level)
72         (*backtrace-print-length* print-length)
73         (*backtrace-show-internal-frames* show-internal-frames)
74         (*backtrace-format* :list))
75    (if (eq tcr (%current-tcr))
76      (%backtrace-as-list-internal context (or origin (%get-frame-ptr)) count start-frame-number)
77      (unwind-protect
78           (progn
79             (%suspend-tcr tcr)
80             (unless context
81               (setq context (context-for-suspended-tcr tcr)))
82             (%backtrace-as-list-internal context (or origin (bt.current context)) count start-frame-number))
83        (%resume-tcr tcr)))))
84
85
86;;; This PRINTS the call history on *DEBUG-IO*.  It's more dangerous
87;;; (because of stack consing) to actually return it.
88                               
89(defun print-call-history (&key context
90                                process
91                                origin
92                                (detailed-p t)
93                                (count target::target-most-positive-fixnum)
94                                (start-frame-number 0)
95                                (stream *debug-io*)
96                                (print-level *backtrace-print-level*)
97                                (print-length *backtrace-print-length*)
98                                (show-internal-frames *backtrace-show-internal-frames*)
99                                (format *backtrace-format*))
100  (when (null count) (setq count target::target-most-positive-fixnum))
101  (when (and context process (neq (bt.tcr context) (process-tcr process)))
102    (error "Context ~s doesn't correspond to the process ~s" context process))
103  (let* ((tcr (cond (context (bt.tcr context))
104                    (process (process-tcr process))
105                    (t (%current-tcr))))
106         (*debug-io* stream)
107         (*backtrace-print-level* print-level)
108         (*backtrace-print-length* print-length)
109         (*backtrace-show-internal-frames* show-internal-frames)
110         (*backtrace-format* format))
111    (if (eq tcr (%current-tcr))
112      (%print-call-history-internal context (or origin (%get-frame-ptr)) detailed-p count start-frame-number)
113      (unwind-protect
114           (progn
115             (%suspend-tcr tcr)
116             (unless context
117               (setq context (context-for-suspended-tcr tcr)))
118             (%print-call-history-internal context (or origin (bt.current context)) detailed-p count start-frame-number))
119        (%resume-tcr tcr)))
120    (values)))
121
122(defun map-call-frames (fn &key context
123                           (origin (%get-frame-ptr))
124                           (start-frame-number 0)
125                           (include-internal nil))
126  (let* ((tcr (if context (bt.tcr context) (%current-tcr))))
127    (if (eq tcr (%current-tcr))
128      (%map-call-frames-internal fn context origin include-internal start-frame-number)
129      (unwind-protect
130           (progn
131             (%suspend-tcr tcr)
132             (%map-call-frames-internal fn context origin include-internal start-frame-number))
133        (%resume-tcr tcr))))
134  nil)
135
136(defun %show-stack-frame (p context lfun pc)
137  (handler-case
138      (multiple-value-bind (count vsp parent-vsp) (count-values-in-frame p context)
139        (declare (fixnum count))
140        (dotimes (i count)
141          (multiple-value-bind (var type name) 
142                               (nth-value-in-frame p i context lfun pc vsp parent-vsp)
143            (format t "~&  ~D " i)
144            (when name (format t "~s" name))
145            (let* ((*print-length* *backtrace-print-length*)
146                   (*print-level* *backtrace-print-level*))
147              (format t ": ~s" var))
148            (when type (format t " (~S)" type)))))
149    (error () (format t "#<error printing frame>")))
150  (terpri)
151  (terpri))
152
153(defun %show-args-and-locals (p context lfun pc)
154  (handler-case
155      (let* ((unavailable (cons nil nil)))
156        (multiple-value-bind (args locals) (arguments-and-locals context p lfun pc unavailable)
157          (case *backtrace-format*
158            (:direct
159               (format t "~&     Arguments: ~:s" (arglist-from-map lfun)))
160            (t (format t "~&  ~s" (arglist-from-map lfun))))
161          (let* ((*print-length* *backtrace-print-length*)
162                 (*print-level* *backtrace-print-level*))
163            (flet ((show-pair (pair prefix)
164                     (destructuring-bind (name . val) pair
165                       (format t "~&~a~s: " prefix name)
166                       (if (eq val unavailable)
167                         (format t "#<Unavailable>")
168                         (format t "~s" val)))))
169              (case *backtrace-format*
170                (:direct
171                   (when args
172                     (dolist (arg args)
173                       (show-pair arg "       ")))
174                   (when locals
175                     ;; This shows all bindings (including specials), but help on debugger
176                     ;; commands refers to "locals", so say both words...
177                     (format t "~&     Local bindings:")
178                     (dolist (loc locals)
179                       (show-pair loc "       "))))
180                (t
181                   (dolist (arg args)
182                     (show-pair arg "   "))
183                   (terpri)
184                   (terpri)
185                   (dolist (loc locals)
186                     (show-pair loc "  "))))))))
187    (error () (format t "#<error printing args and locals>")))
188  (terpri)
189  (terpri))
190
191
192(defun backtrace-call-arguments (context cfp lfun pc)
193  (nconc (let* ((name (function-name lfun)))
194           (if (function-is-current-definition? lfun)
195             (list name)
196             (case *backtrace-format*
197               (:direct
198                  (list (format nil "~s" (or name lfun))))
199               (:list
200                  (list 'funcall (format nil "~s" (or name lfun))))
201               (t (list 'funcall `(function ,(concatenate 'string "#<" (%lfun-name-string lfun) ">")))))))
202         (backtrace-supplied-args context cfp lfun pc)))
203
204(defun backtrace-supplied-args (context frame lfun pc)
205  (if (and pc (<= pc target::arg-check-trap-pc-limit))
206    (arg-check-call-arguments frame lfun)
207    (multiple-value-bind (params valid) (arglist-from-map lfun)
208      (if (not valid)
209        '("???")
210        (let ((args (arguments-and-locals context frame lfun pc)) ;overkill, but will do.
211              (state :required)
212              (strings ()))
213          (flet ((collect (arg)
214                   (let* ((*print-length* *backtrace-print-length*)
215                          (*print-level* *backtrace-print-level*))
216                     (push (format nil "~s" arg) strings))))
217            (dolist (param params)
218              (if (or (member param lambda-list-keywords) (eq param '&lexpr))
219                (setq state param)
220                (let* ((pair (pop args))
221                       (value (cdr pair)))
222                  (case state
223                    (&lexpr
224                       (with-list-from-lexpr (rest value)
225                         (dolist (r rest) (collect r)))
226                       (return))
227                    (&rest
228                       (dolist (r value) (collect r))
229                       (return))
230                    (&key (collect param)))
231                  (if (eq value (%unbound-marker))
232                    (push "?" strings)
233                    (collect value))))))
234          (nreverse strings))))))
235
236;;; Return a list of "interesting" frame addresses in context, most
237;;; recent first.
238(defun %stack-frames-in-context (context &optional (include-internal *backtrace-show-internal-frames*))
239  (collect ((frames))
240    (do* ((p (bt.youngest context) (parent-frame p context))
241          (q (bt.oldest context)))
242         ((eql p q) (frames))
243      (when (or (not (catch-csp-p p context)) include-internal)
244        (when (or (cfp-lfun p) include-internal)
245          (frames p))))))
246   
247(defun %map-call-frames-internal (fn context origin include-internal skip-initial)
248  (let ((*standard-output* *debug-io*)
249        (*print-circle* nil)
250        (p origin)
251        (q (last-frame-ptr context)))
252    (dotimes (i skip-initial)
253      (setq p (parent-frame p context))
254      (when (or (null p) (eq p q) (%stack< q p context))
255        (return (setq p nil))))
256    (do* ((p p (parent-frame p context)))
257         ((or (null p) (eq p q) (%stack< q p context)) nil)
258      (when (or include-internal
259                (and (not (catch-csp-p p context)) (cfp-lfun p)))
260        (funcall fn p)))))
261
262(defun %backtrace-as-list-internal (context origin count skip-initial)
263  (unless (eq (last-frame-ptr context origin) (last-frame-ptr context))
264    (error "Origin ~s is not in the stack of ~s" origin context))
265  (let ((*print-catch-errors* t)
266        (p origin)
267        (q (last-frame-ptr context)))
268    (dotimes (i skip-initial)
269      (setq p (parent-frame p context))
270      (when (or (null p) (eq p q) (%stack< q p context))
271        (return (setq p nil))))
272    (do* ((frame-number (or skip-initial 0) (1+ frame-number))
273          (i 0 (1+ i))
274          (p p (parent-frame p context))
275          (r '()))
276        ((or (null p) (eq p q) (%stack< q p context)
277             (>= i count))
278         (nreverse r))
279      (declare (fixnum frame-number i))
280      (when (or (not (catch-csp-p p context))
281                *backtrace-show-internal-frames*)
282        (multiple-value-bind (lfun pc) (cfp-lfun p)
283          (when (or lfun *backtrace-show-internal-frames*)
284            (push
285             (if lfun
286               (backtrace-call-arguments context p lfun pc)
287               "?????")
288             r)))))))
289
290 
291(defun %print-call-history-internal (context origin detailed-p
292                                             &optional (count target::target-most-positive-fixnum) (skip-initial 0))
293  (unless (eq (last-frame-ptr context origin) (last-frame-ptr context))
294    (error "Origin ~s is not in the stack of ~s" origin context))
295  (let ((*standard-output* *debug-io*)
296        (*print-circle* nil)
297        (*print-catch-errors* t)
298        (p origin)
299        (q (last-frame-ptr context)))
300    (dotimes (i skip-initial)
301      (setq p (parent-frame p context))
302      (when (or (null p) (eq p q) (%stack< q p context))
303        (return (setq p nil))))
304    (do* ((frame-number (or skip-initial 0) (1+ frame-number))
305          (i 0 (1+ i))
306          (p p (parent-frame p context)))
307         ((or (null p) (eq p q) (%stack< q p context)
308              (>= i count))
309          (values))
310      (declare (fixnum frame-number i))
311      (when (or (not (catch-csp-p p context))
312                *backtrace-show-internal-frames*)
313        (multiple-value-bind (lfun pc) (cfp-lfun p)
314          (when (or lfun *backtrace-show-internal-frames*)
315            (unless (and (typep detailed-p 'fixnum)
316                         (not (= (the fixnum detailed-p) frame-number)))
317              (%show-stack-frame-label frame-number p context lfun pc detailed-p)
318              (when detailed-p
319                (if (eq detailed-p :raw)
320                  (%show-stack-frame p context lfun pc)
321                  (%show-args-and-locals p context lfun pc))))))))))
322
323(defun %show-stack-frame-label (frame-number p context lfun pc detailed-p)
324  (case *backtrace-format*
325    (:direct
326       (let ((call (backtrace-call-arguments context p lfun pc)))
327         (format t "~&~3D: ~a ~a~@d~:[~; [Exception]~]"
328                 frame-number
329                 (if lfun
330                   (if detailed-p (car call) call)
331                   "<non-function frame>")
332                 "at pc "
333                 pc
334                 (exception-frame-p p))))
335    (t (format t "~&~c(~x) : ~D ~a ~d"
336                      (if (exception-frame-p p)  #\* #\space)
337                      (index->address p) frame-number
338                      (if lfun (backtrace-call-arguments context p lfun pc))
339                      pc))))
340
341
342(defun %access-lisp-data (vstack-index)
343  (%fixnum-ref vstack-index))
344
345(defun %store-lisp-data (vstack-index value)
346  (setf (%fixnum-ref vstack-index) value))
347
348(defun closed-over-value (data)
349  (if (closed-over-value-p data)
350    (uvref data 0)
351    data))
352
353(defun set-closed-over-value (value-cell value)
354  (setf (uvref value-cell 0) value))
355
356
357
358;;; Act as if VSTACK-INDEX points at some lisp data & return that data.
359(defun access-lisp-data (vstack-index)
360  (closed-over-value (%access-lisp-data vstack-index)))
361
362(defun find-local-name (cellno lfun pc)
363  (let* ((n cellno))
364    (when lfun
365      (multiple-value-bind (mask where) (registers-used-by lfun pc)
366        (if (and where (< (1- where) n (+ where (logcount mask))))
367          (let ((j *saved-register-count*))
368            (decf n where)
369            (loop (loop (if (logbitp (decf j) mask) (return)))
370                  (if (< (decf n) 0) (return)))
371            (values (format nil "saved ~a" (aref *saved-register-names* j))
372                    nil))
373          (multiple-value-bind (nreq nopt restp nkeys junk optinitp junk ncells nclosed)
374                               (if lfun (function-args lfun))
375            (declare (ignore junk optinitp))
376            (if nkeys (setq nkeys (+ nkeys nkeys)))
377            (values
378             (if (and ncells (< n ncells))
379               (if (< n nclosed)
380                 :inherited
381                 (if (< (setq n (- n nclosed)) nreq)
382                   "required"
383                   (if (< (setq n (- n nreq)) nopt)
384                     "optional"
385                     (progn
386                       (setq n (- n nopt))
387                       (progn
388                         (if (and nkeys (< n nkeys))
389                           (if (not (logbitp 0 n)) ; a keyword
390                             "keyword"
391                             "key-supplied-p")
392                           (progn
393                             (if nkeys (setq n (- n nkeys)))
394                             (if (and restp (zerop n))
395                               "rest"
396                               "opt-supplied-p")))))))))
397             (match-local-name cellno (function-symbol-map lfun) pc))))))))
398
399(defun map-entry-value (context cfp lfun pc idx unavailable)
400  (declare (fixnum pc idx))
401  (let* ((info (function-symbol-map lfun)))
402    (if (null info)
403      unavailable
404      (let* ((addrs (cdr info))
405             (i (* 3 idx))
406             (addr (svref addrs i))
407             (startpc (svref addrs (the fixnum (+ i 1))))
408             (endpc (svref addrs (the fixnum (+ i 2)))))
409        (declare (fixnum i addr startpc endpc))
410        (if (or (< pc startpc)
411                (>= pc endpc))
412          unavailable
413          (let* ((value (if (= #o77 (ldb (byte 6 0) addr))
414                          (raw-frame-ref cfp context (ash addr (- (+ target::word-shift 6)))
415                                         unavailable)
416                          (find-register-argument-value context cfp addr unavailable))))
417            (if (typep value 'value-cell)
418              (uvref value 0)
419              value)))))))
420
421;;; Returns non-nil on success (not newval)
422(defun set-map-entry-value (context cfp lfun pc idx newval)
423  (declare (fixnum pc idx))
424  (let* ((unavailable (cons nil nil))
425         (value (map-entry-value context cfp lfun pc idx unavailable)))
426    (if (eq value unavailable)
427      nil
428      (if (typep value 'value-cell)
429        (progn (setf (uvref value 0) newval) t)
430
431        (let* ((addrs (cdr (function-symbol-map lfun)))
432               (addr (svref addrs (the fixnum (* 3 idx)))))
433          (declare (fixnum  addr))
434          (if (= #o77 (ldb (byte 6 0) addr))
435            (raw-frame-set cfp context (ash addr (- (+ target::word-shift 6))) newval)
436            (set-register-argument-value context cfp addr newval))
437          t)))))
438
439         
440(defun argument-value (context cfp lfun pc name &optional (quote t))
441  (declare (fixnum pc))
442  (let* ((info (function-symbol-map lfun))
443         (unavailable (%unbound-marker)))
444    (if (null info)
445      unavailable
446      (let* ((names (car info))
447             (addrs (cdr info)))
448        (do* ((nname (1- (length names)) (1- nname))
449              (naddr (- (length addrs) 3) (- naddr 3)))
450             ((or (< nname 0) (< naddr 0)) unavailable)
451          (declare (fixnum nname naddr))
452          (when (eq (svref names nname) name)
453            (let* ((value
454                    (let* ((addr (svref addrs naddr))
455                           (startpc (svref addrs (the fixnum (1+ naddr))))
456                           (endpc (svref addrs (the fixnum (+ naddr 2)))))
457                      (declare (fixnum addr startpc endpc))
458                      (if (or (< pc startpc)
459                              (>= pc endpc))
460                        unavailable
461                        (if (= #o77 (ldb (byte 6 0) addr))
462                          (raw-frame-ref cfp context (ash addr (- (+ target::word-shift 6)))
463                                         unavailable)
464                          (find-register-argument-value context cfp addr unavailable))))))
465              (if (typep value 'value-cell)
466                (setq value (uvref value 0)))
467              (if (or (not quote) (self-evaluating-p value))
468                (return value)
469                (return (list 'quote value))))))))))
470
471
472
473(defun raw-frame-ref (cfp context index bad)
474  (%raw-frame-ref cfp context index bad))
475
476(defun raw-frame-set (cfp context index new)
477  (%raw-frame-set cfp context index new))
478 
479(defun find-register-argument-value (context cfp regval bad)
480  (%find-register-argument-value context cfp regval bad))
481
482(defun set-register-argument-value (context cfp regval newval)
483  (%set-register-argument-value context cfp regval newval))
484
485   
486
487(defun dbg-form (frame-number)
488  (when *break-frame*
489    (let* ((cfp (nth-raw-frame frame-number *break-frame* nil)))
490      (if (and cfp (not (catch-csp-p cfp nil)))
491        (multiple-value-bind (function pc)
492            (cfp-lfun cfp)
493          (if (and function
494                   (function-is-current-definition? function))
495            (block %cfp-form
496              (collect ((form))
497                (multiple-value-bind (nreq nopt restp keys allow-other-keys
498                                           optinit lexprp ncells nclosed)
499                    (function-args function)
500                  (declare (ignore ncells))
501                  (unless (or lexprp restp (> 0 nclosed) (> 0 nopt) keys allow-other-keys
502                              optinit)
503                    (let* ((name (function-name function)))
504                      (multiple-value-bind (arglist win)
505                          (arglist-from-map function)
506                      (when (and win name (symbolp name))
507                        (form name)
508                        (dotimes (i nreq)
509                          (let* ((val (argument-value nil cfp function pc (pop arglist))))
510                            (if (closed-over-value-p val)
511                              (setq val (%svref val target::value-cell.value-cell)))
512                            (if (eq val (%unbound-marker))
513                              (return-from %cfp-form nil))
514                            (form val))))))))
515                (form)))))))))
516
517(defun function-args (lfun)
518  "Returns 9 values, as follows:
519     req = number of required arguments
520     opt = number of optional arguments
521     restp = t if rest arg
522     keys = number of keyword arguments or NIL if &key not mentioned
523     allow-other-keys = t if &allow-other-keys present
524     optinit = t if any optional arg has non-nil default value or supplied-p
525               variable
526     lexprp = t if function is a lexpr, in which case all other values are
527              undefined.
528     ncells = number of stack frame cells used by all arguments.
529     nclosed = number of inherited values (now counted distinctly from required)
530     All numeric values (but ncells) are mod 64."
531  (let* ((bits (lfun-bits lfun))
532         (req (ldb $lfbits-numreq bits))
533         (opt (ldb $lfbits-numopt bits))
534         (restp (logbitp $lfbits-rest-bit bits))
535         (keyvect (lfun-keyvect lfun))
536         (keys (and keyvect (length keyvect)))
537         (allow-other-keys (logbitp $lfbits-aok-bit bits))
538         (optinit (logbitp $lfbits-optinit-bit bits))
539         (lexprp (logbitp $lfbits-restv-bit bits))
540         (nclosed (ldb $lfbits-numinh bits)))
541    (values req opt restp keys allow-other-keys optinit lexprp
542            (unless (or lexprp)
543              (+ req opt (if restp 1 0) (if keys (+ keys keys) 0)
544                 (if optinit opt 0) nclosed))
545            nclosed)))
546
547;;; If we can tell reliably, return the function's minimum number of
548;;; non-inherited arguments, the maximum number of such arguments (or NIL),
549;;; and the actual number of such arguments.  We "can't tell" if either
550;;; of the arguments to this function are null, and we can't tell reliably
551;;; if any of the lfbits fields are full.
552(defun min-max-actual-args (fn nargs)
553  (let* ((lfbits (if (and fn nargs)
554                   (lfun-bits fn)
555                   -1))
556         (raw-req (ldb $lfbits-numreq lfbits))
557         (raw-opt (ldb $lfbits-numopt lfbits))
558         (raw-inh (ldb $lfbits-numinh lfbits)))
559    (declare (fixnum raw-req raw-opt raw-inh))
560    (if (or (eql raw-req (1- (ash 1 (byte-size $lfbits-numreq))))
561            (eql raw-opt (1- (ash 1 (byte-size $lfbits-numopt))))
562            (eql raw-inh (1- (ash 1 (byte-size $lfbits-numinh)))))
563      (values nil nil nil)
564      (values raw-req
565              (unless (or (lfun-keyvect fn)
566                          (logbitp $lfbits-rest-bit lfbits)
567                          (logbitp $lfbits-restv-bit lfbits))
568                (+ raw-req raw-opt))
569              (- nargs raw-inh)))))
570
571
572
573(defun closed-over-value-p (value)
574  (eql target::subtag-value-cell (typecode value)))
575
576
577(defun variables-in-scope (lfun pc)
578  ;; Return a list of all symbol names "in scope" in the function lfun
579  ;; at relative program counter PC, using the function's symbol map.
580  ;; The list will be ordered so that least-recent bindings appear first.
581  ;; Return a list of the matching symbol map entries as a second value
582  (when pc
583    (locally (declare (fixnum pc))
584      (let* ((map (function-symbol-map lfun))
585             (names (car map))
586             (info (cdr map)))
587        (when map
588          (let* ((vars ())
589                 (indices ()))
590            (dotimes (i (length names) (values vars indices))
591              (let* ((start-pc (aref info (1+ (* 3 i))))
592                     (end-pc (aref info (+ 2 (* 3 i)))))
593                (declare (fixnum start-pc end-pc))
594                (when (and (>= pc start-pc)
595                           (< pc end-pc))
596                  (push i indices)
597                  (push (svref names i) vars))))))))))
598
599
600(defun arg-value (context cfp lfun pc unavailable name)
601  (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc)
602    (multiple-value-bind (valid req opt rest keys)
603        (arg-names-from-map lfun pc)
604      (if valid
605        (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys)))
606               (pos (position name vars)))
607          (if (and pos (< pos nargs))
608            (map-entry-value context cfp lfun pc (nth pos map-indices) unavailable)
609            unavailable))
610        unavailable))))
611
612(defun local-value (context cfp lfun pc unavailable name)
613  (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc)
614    (multiple-value-bind (valid req opt rest keys)
615        (arg-names-from-map lfun pc)
616      (if valid
617        (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys)))
618               (names (nthcdr nargs vars))
619               (indices (nthcdr nargs map-indices))
620               (pos (if (typep name 'unsigned-byte)
621                      name
622                      (position name names :from-end t))))
623          (if pos
624            (map-entry-value context cfp lfun pc (nth pos indices) unavailable)
625            unavailable))
626        unavailable))))
627
628(defun set-arg-value (context cfp lfun pc name new)
629  (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc)
630    (multiple-value-bind (valid req opt rest keys)
631        (arg-names-from-map lfun pc)
632      (if valid
633        (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys)))
634               (pos (position name vars)))
635          (when (and pos (< pos nargs))
636            (set-map-entry-value context cfp lfun pc (nth pos map-indices) new)))))))
637
638(defun set-local-value (context cfp lfun pc name new)
639  (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc)
640    (multiple-value-bind (valid req opt rest keys)
641        (arg-names-from-map lfun pc)
642      (if valid
643        (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys)))
644               (names (nthcdr nargs vars))
645               (indices (nthcdr nargs map-indices))
646               (pos (if (typep name 'unsigned-byte)
647                      name
648                      (position name names :from-end t))))
649          (if (and pos (< pos nargs))
650            (set-map-entry-value context cfp lfun pc (nth pos indices) new)))))))
651
652
653(defun arguments-and-locals (context cfp lfun pc &optional unavailable)
654  (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc)
655    (collect ((args)
656              (inherited-indices)
657              (inherited-vars)
658              (locals))
659      (multiple-value-bind (valid req opt rest keys)
660          (arg-names-from-map lfun pc)
661        (when valid
662          (let* ((numinh (ldb $lfbits-numinh (lfun-bits lfun))))
663            (dotimes (i numinh)
664              (inherited-indices (pop map-indices))
665              (inherited-vars (pop vars))))
666          (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys)))
667                 (nlocals (- (length vars) nargs))
668                 (local-vars (append (nthcdr nargs vars) (inherited-vars)))
669                 (local-indices (append (nthcdr nargs map-indices) (inherited-indices)))
670                 (arg-vars (if (<= nlocals 0) vars (nbutlast vars nlocals)))
671                 (arg-indices (if (<= nlocals 0) map-indices (nbutlast map-indices nlocals))))
672            (flet ((get-arg-value (name)
673                     (let* ((pos (position name arg-vars :test #'eq)))
674                       (when pos
675                         (args (cons name (map-entry-value context cfp lfun pc (nth pos arg-indices) unavailable))))))
676                   (get-local-value (name)
677                     (when name
678                       (locals (cons name (map-entry-value context cfp lfun pc (pop local-indices) unavailable))))))
679              (dolist (name req)
680                (get-arg-value name))
681              (dolist (name opt)
682                (get-arg-value name))
683              (when rest
684                (get-arg-value rest))
685              (dolist (name keys)
686                (get-arg-value name))
687              (dolist (name local-vars)
688                (get-local-value name)))))
689        (values (args) (locals))))))
690                   
691           
692
693(defun safe-cell-value (val)
694  val)
695
696(defun closure-closed-over-values (closure)
697  (when (typep closure 'compiled-lexical-closure)
698    (let* ((inner (closure-function closure))
699           (nclosed (nth-value 8 (function-args inner)))
700           (names (car (function-symbol-map inner))))
701      (when nclosed
702        (collect ((cells))
703          (do* ((i (1- (length names)) (1- i))
704                (k 0 (1+ k))
705                (idx 2 (1+ idx)))
706               ((= k nclosed) (reverse (cells)))
707            (let* ((name (svref names i))
708                   (imm (nth-immediate closure idx)))
709              (cells (list name (if (closed-over-value-p imm)
710                                  (closed-over-value imm)
711                                  imm))))))))))
712
713     
714;;; Find the oldest binding frame that binds the same symbol as
715;;; FRAME in context.  If found, return the saved value of that
716;;; binding, else the value of the symbol in the context's thread.
717(defun oldest-binding-frame-value (context frame)
718  (let* ((oldest nil)
719         (binding-index (%fixnum-ref frame (ash 1 target::fixnum-shift))))
720    (do* ((db (db-link context) (%fixnum-ref db 0)))
721         ((eq frame db)
722          (if oldest
723            (%fixnum-ref oldest (ash 2 target::fixnum-shift))
724            (let* ((symbol (binding-index-symbol binding-index)))
725              (if context
726                (symbol-value-in-tcr symbol (bt.tcr context))
727                (%sym-value symbol)))))
728      (if (eq (%fixnum-ref db (ash 1 target::fixnum-shift)) binding-index)
729        (setq oldest db)))))
730
731(defun (setf oldest-binding-frame-value) (new context frame)
732  (let* ((oldest nil)
733         (binding-index (%fixnum-ref frame (ash 1 target::fixnum-shift))))
734    (do* ((db (db-link context) (%fixnum-ref db 0)))
735         ((eq frame db)
736          (if oldest
737            (setf (%fixnum-ref oldest (ash 2 target::fixnum-shift)) new)
738            (let* ((symbol (binding-index-symbol binding-index)))
739              (if context
740                (setf (symbol-value-in-tcr symbol (bt.tcr context)) new)
741                (%set-sym-value symbol new)))))
742      (if (eq (%fixnum-ref db (ash 1 target::fixnum-shift)) binding-index)
743        (setq oldest db)))))
744   
745
746
747;;; End of backtrace.lisp
Note: See TracBrowser for help on using the repository browser.