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

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

Propagate r9234 to trunk

  • 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 (if (<= nlocals 0) vars (nbutlast vars nlocals)))
633                 (arg-indices (if (<= nlocals 0) map-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.