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

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

Some changes in support of Slime:

Implement CCL:COMPUTE-APPLICABLE-METHODS-USING-CLASSES

Add a :stream-args argument to CCL:ACCEPT-CONNECTION, for one-time initargs for the stream being created. E.g. (accept-connection listener :stream-args `(:external-format ,external-format-for-this-connection-only))

Add CCL:TEMP-PATHNAME

Bind new var CCL:*TOP-ERROR-FRAME* to the error frame in break loops, to make it available to debugger/break hooks.

Add CCL:*SELECT-INTERACTIVE-PROCESS-HOOK* and call it to select the process to use for handling SIGINT.

Add CCL:*MERGE-COMPILER-WARNINGS* to control whether warnings with the same format string and args but different source locations should be merged.

Export CCL:COMPILER-WARNING, CCL:STYLE-WARNING, CCL:COMPILER-WARNING-FUNCTION-NAME and CCL:COMPILER-WARNING-SOURCE-NOTE.

Create a CCL:COMPILER-WARNING-SOURCE-NOTE even if not otherwise saving source locations, just using the fasl file and toplevel stream position, but taking into account compile-file-original-truename and compiler-file-original-buffer-offset. Get rid of stream-position and file-name slots in compiler warnings.

Export CCL:REPORT-COMPILER-WARNING, and make it accept a :SHORT keyword arg to skip the textual representation of the warning location.

Export CCL:NAME-OF, and make it return the fully qualified name for methods, return object for eql-specializer

Make CCL:FIND-DEFINITION-SOURCES handle xref-entries.

Export CCL:SETF-FUNCTION-SPEC-NAME, make it explicitly ignore the long-form setf method case.

Export the basic inspector API from the inspector package.

Export EQL-SPECIALIZER and SLOT-DEFINITION-DOCUMENTATION from OPENMCL-MOP

Refactor things a bit in backtrace code, define and export an API for examining backtraces:

CCL:MAP-CALL-FRAMES
CCL:FRAME-FUNCTION
CCL:FRAME-SUPPLIED-ARGUMENTS
CCL:FRAME-NAMED-VARIABLES

other misc new exports:

CCL:DEFINITION-TYPE
CCL;CALLER-FUNCTIONS
CCL:SLOT-DEFINITION-DOCUMENTATION
CCL:*SAVE-ARGLIST-INFO*
CCL:NATIVE-TRANSLATED-NAMESTRING
CCL:NATIVE-TO-PATHNAME
CCL:HASH-TABLE-WEAK-P
CCL;PROCESS-SERIAL-NUMBER
CCL:PROCESS-EXHAUSTED-P
CCL:APPLY-IN-FRAME

Other misc tweaks:

Make cbreak-loop use the break message when given a uselessly empty condition.

Use setf-function-name-p more consistently

Make find-applicable-methods handle eql specializers better.

Try to more consistently recognize lists of the form (:method ...) as method names.

Add xref-entry-full-name (which wasn't needed in the end)

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