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

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

Add support for a different backtrace formats with new variable
*BACKTRACE-FORMAT*, which can be :DIRECT or :TRADITIONAL.
:TRADITIONAL is the default. If *BACKTRACE-FORMAT* is :DIRECT,
backtrace shows non-toplevel functions being called directly (not
using FUNCALL), and also has assorted other tweaks, including not
showing frame address values, and explicitly labelling the arg and
locals sections and the pc offset.

Extend ccl:print-call-history with new keyword arguments:

:stream - default *debug-io*
:show-internal-frames - default *backtrace-show-internal-frames*
:print-level - default *backtrace-print-level*
:print-length - default *backtrace-print-length*
:format - default *backtrace-format*

Add CCL::BACKTRACE-AS-LIST, so can at least keep an eye on it. Make
it return the actual lfun when that's not a closure.

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