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

Last change on this file since 11134 was 11134, checked in by gz, 12 years ago

From working-0711 branch: show all supplied args in backtrace.

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