source: branches/qres/ccl/lib/backtrace.lisp @ 13565

Last change on this file since 13565 was 13565, checked in by gz, 10 years ago

replace ccl-0711 feature with ccl-qres

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