source: trunk/source/lib/backtrace.lisp

Last change on this file was 16802, checked in by svspire, 3 years ago

Add *print-string-length* control for tracing, backtracing, and errors.
Fixes ticket:1390 in trunk.

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