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 | ;;; This PRINTS the call history on *DEBUG-IO*. It's more dangerous |
---|
31 | ;;; (because of stack consing) to actually return it. |
---|
32 | |
---|
33 | (defun print-call-history (&key context |
---|
34 | (origin (%get-frame-ptr)) |
---|
35 | (detailed-p t) |
---|
36 | (count most-positive-fixnum) |
---|
37 | (start-frame-number 0)) |
---|
38 | (let* ((tcr (if context (bt.tcr context) (%current-tcr)))) |
---|
39 | (if (eq tcr (%current-tcr)) |
---|
40 | (%print-call-history-internal context origin detailed-p (or count most-positive-fixnum) start-frame-number) |
---|
41 | (unwind-protect |
---|
42 | (progn |
---|
43 | (%suspend-tcr tcr ) |
---|
44 | (%print-call-history-internal context origin detailed-p |
---|
45 | count start-frame-number)) |
---|
46 | (%resume-tcr tcr))) |
---|
47 | (values))) |
---|
48 | |
---|
49 | (defun map-call-frames (fn &key context |
---|
50 | (origin (%get-frame-ptr)) |
---|
51 | (start-frame-number 0) |
---|
52 | (include-internal nil)) |
---|
53 | (let* ((tcr (if context (bt.tcr context) (%current-tcr)))) |
---|
54 | (if (eq tcr (%current-tcr)) |
---|
55 | (%map-call-frames-internal fn context origin include-internal start-frame-number) |
---|
56 | (unwind-protect |
---|
57 | (progn |
---|
58 | (%suspend-tcr tcr) |
---|
59 | (%map-call-frames-internal fn context origin include-internal start-frame-number)) |
---|
60 | (%resume-tcr tcr)))) |
---|
61 | nil) |
---|
62 | |
---|
63 | (defun %show-stack-frame (p context lfun pc) |
---|
64 | (handler-case |
---|
65 | (multiple-value-bind (count vsp parent-vsp) (count-values-in-frame p context) |
---|
66 | (declare (fixnum count)) |
---|
67 | (dotimes (i count) |
---|
68 | (multiple-value-bind (var type name) |
---|
69 | (nth-value-in-frame p i context lfun pc vsp parent-vsp) |
---|
70 | (format t "~& ~D " i) |
---|
71 | (when name (format t "~s" name)) |
---|
72 | (let* ((*print-length* *backtrace-print-length*) |
---|
73 | (*print-level* *backtrace-print-level*)) |
---|
74 | (format t ": ~s" var)) |
---|
75 | (when type (format t " (~S)" type))))) |
---|
76 | (error () (format t "#<error printing frame>"))) |
---|
77 | (terpri) |
---|
78 | (terpri)) |
---|
79 | |
---|
80 | (defun %show-args-and-locals (p context lfun pc) |
---|
81 | (handler-case |
---|
82 | (let* ((unavailable (cons nil nil))) |
---|
83 | (multiple-value-bind (args locals) (arguments-and-locals context p lfun pc unavailable) |
---|
84 | (format t "~& ~s" (arglist-from-map lfun)) |
---|
85 | (let* ((*print-length* *backtrace-print-length*) |
---|
86 | (*print-level* *backtrace-print-level*)) |
---|
87 | (flet ((show-pair (pair prefix) |
---|
88 | (destructuring-bind (name . val) pair |
---|
89 | (format t "~&~a~s: " prefix name) |
---|
90 | (if (eq val unavailable) |
---|
91 | (format t "#<Unavailable>") |
---|
92 | (format t "~s" val))))) |
---|
93 | (dolist (arg args) |
---|
94 | (show-pair arg " ")) |
---|
95 | (terpri) |
---|
96 | (terpri) |
---|
97 | (dolist (loc locals) |
---|
98 | (show-pair loc " ")))))) |
---|
99 | (error () (format t "#<error printing args and locals>"))) |
---|
100 | (terpri) |
---|
101 | (terpri)) |
---|
102 | |
---|
103 | |
---|
104 | (defun backtrace-call-arguments (context cfp lfun pc) |
---|
105 | (collect ((call)) |
---|
106 | (let* ((name (function-name lfun))) |
---|
107 | (if (function-is-current-definition? lfun) |
---|
108 | (call name) |
---|
109 | (progn |
---|
110 | (call 'funcall) |
---|
111 | (call `(function ,(concatenate 'string "#<" (%lfun-name-string lfun) ">"))))) |
---|
112 | (if (and pc (<= pc target::arg-check-trap-pc-limit)) |
---|
113 | (append (call) (arg-check-call-arguments cfp lfun)) |
---|
114 | (multiple-value-bind (req opt restp keys) |
---|
115 | (function-args lfun) |
---|
116 | (when (or (not (eql 0 req)) (not (eql 0 opt)) restp keys) |
---|
117 | (let* ((arglist (arglist-from-map lfun))) |
---|
118 | (if (or (null arglist) (null pc)) |
---|
119 | (call "???") |
---|
120 | (progn |
---|
121 | (dotimes (i req) |
---|
122 | (let* ((val (argument-value context cfp lfun pc (pop arglist)))) |
---|
123 | (if (eq val (%unbound-marker)) |
---|
124 | (call "?") |
---|
125 | (call (let* ((*print-length* *backtrace-print-length*) |
---|
126 | (*print-level* *backtrace-print-level*)) |
---|
127 | (format nil "~s" val)))))) |
---|
128 | (if (or restp keys (not (eql opt 0))) |
---|
129 | (call "[...]")))))) |
---|
130 | (call)))))) |
---|
131 | |
---|
132 | |
---|
133 | ;;; Return a list of "interesting" frame addresses in context, most |
---|
134 | ;;; recent first. |
---|
135 | (defun %stack-frames-in-context (context &optional (include-internal *backtrace-show-internal-frames*)) |
---|
136 | (collect ((frames)) |
---|
137 | (do* ((p (bt.youngest context) (parent-frame p context)) |
---|
138 | (q (bt.oldest context))) |
---|
139 | ((eql p q) (frames)) |
---|
140 | (when (or (not (catch-csp-p p context)) include-internal) |
---|
141 | (when (or (cfp-lfun p) include-internal) |
---|
142 | (frames p)))))) |
---|
143 | |
---|
144 | (defun %map-call-frames-internal (fn context origin include-internal skip-initial) |
---|
145 | (let ((*standard-output* *debug-io*) |
---|
146 | (*print-circle* nil) |
---|
147 | (p origin) |
---|
148 | (q (last-frame-ptr context))) |
---|
149 | (dotimes (i skip-initial) |
---|
150 | (setq p (parent-frame p context)) |
---|
151 | (when (or (null p) (eq p q) (%stack< q p context)) |
---|
152 | (return (setq p nil)))) |
---|
153 | (do* ((p p (parent-frame p context))) |
---|
154 | ((or (null p) (eq p q) (%stack< q p context)) nil) |
---|
155 | (when (or include-internal |
---|
156 | (and (not (catch-csp-p p context)) (cfp-lfun p))) |
---|
157 | (funcall fn p))))) |
---|
158 | |
---|
159 | (defun %print-call-history-internal (context origin detailed-p |
---|
160 | &optional (count most-positive-fixnum) (skip-initial 0)) |
---|
161 | (let ((*standard-output* *debug-io*) |
---|
162 | (*print-circle* nil) |
---|
163 | (p origin) |
---|
164 | (q (last-frame-ptr context))) |
---|
165 | (dotimes (i skip-initial) |
---|
166 | (setq p (parent-frame p context)) |
---|
167 | (when (or (null p) (eq p q) (%stack< q p context)) |
---|
168 | (return (setq p nil)))) |
---|
169 | (do* ((frame-number (or skip-initial 0) (1+ frame-number)) |
---|
170 | (i 0 (1+ i)) |
---|
171 | (p p (parent-frame p context))) |
---|
172 | ((or (null p) (eq p q) (%stack< q p context) |
---|
173 | (>= i count)) |
---|
174 | (values)) |
---|
175 | (declare (fixnum frame-number i)) |
---|
176 | (when (or (not (catch-csp-p p context)) |
---|
177 | *backtrace-show-internal-frames*) |
---|
178 | (multiple-value-bind (lfun pc) (cfp-lfun p) |
---|
179 | (when (or lfun *backtrace-show-internal-frames*) |
---|
180 | (unless (and (typep detailed-p 'fixnum) |
---|
181 | (not (= (the fixnum detailed-p) frame-number))) |
---|
182 | (format t "~&~c(~x) : ~D ~a ~d" |
---|
183 | (if (exception-frame-p p) #\* #\space) |
---|
184 | (index->address p) frame-number |
---|
185 | (if lfun (backtrace-call-arguments context p lfun pc)) |
---|
186 | pc) |
---|
187 | (when detailed-p |
---|
188 | (if (eq detailed-p :raw) |
---|
189 | (%show-stack-frame p context lfun pc) |
---|
190 | (%show-args-and-locals p context lfun pc)))))))))) |
---|
191 | |
---|
192 | |
---|
193 | (defun %access-lisp-data (vstack-index) |
---|
194 | (%fixnum-ref vstack-index)) |
---|
195 | |
---|
196 | (defun %store-lisp-data (vstack-index value) |
---|
197 | (setf (%fixnum-ref vstack-index) value)) |
---|
198 | |
---|
199 | (defun closed-over-value (data) |
---|
200 | (if (closed-over-value-p data) |
---|
201 | (uvref data 0) |
---|
202 | data)) |
---|
203 | |
---|
204 | (defun set-closed-over-value (value-cell value) |
---|
205 | (setf (uvref value-cell 0) value)) |
---|
206 | |
---|
207 | |
---|
208 | |
---|
209 | ;;; Act as if VSTACK-INDEX points at some lisp data & return that data. |
---|
210 | (defun access-lisp-data (vstack-index) |
---|
211 | (closed-over-value (%access-lisp-data vstack-index))) |
---|
212 | |
---|
213 | (defun find-local-name (cellno lfun pc) |
---|
214 | (let* ((n cellno)) |
---|
215 | (when lfun |
---|
216 | (multiple-value-bind (mask where) (registers-used-by lfun pc) |
---|
217 | (if (and where (< (1- where) n (+ where (logcount mask)))) |
---|
218 | (let ((j *saved-register-count*)) |
---|
219 | (decf n where) |
---|
220 | (loop (loop (if (logbitp (decf j) mask) (return))) |
---|
221 | (if (< (decf n) 0) (return))) |
---|
222 | (values (format nil "saved ~a" (aref *saved-register-names* j)) |
---|
223 | nil)) |
---|
224 | (multiple-value-bind (nreq nopt restp nkeys junk optinitp junk ncells nclosed) |
---|
225 | (if lfun (function-args lfun)) |
---|
226 | (declare (ignore junk optinitp)) |
---|
227 | (if nkeys (setq nkeys (+ nkeys nkeys))) |
---|
228 | (values |
---|
229 | (if (and ncells (< n ncells)) |
---|
230 | (if (< n nclosed) |
---|
231 | :inherited |
---|
232 | (if (< (setq n (- n nclosed)) nreq) |
---|
233 | "required" |
---|
234 | (if (< (setq n (- n nreq)) nopt) |
---|
235 | "optional" |
---|
236 | (progn |
---|
237 | (setq n (- n nopt)) |
---|
238 | (progn |
---|
239 | (if (and nkeys (< n nkeys)) |
---|
240 | (if (not (logbitp 0 n)) ; a keyword |
---|
241 | "keyword" |
---|
242 | "key-supplied-p") |
---|
243 | (progn |
---|
244 | (if nkeys (setq n (- n nkeys))) |
---|
245 | (if (and restp (zerop n)) |
---|
246 | "rest" |
---|
247 | "opt-supplied-p"))))))))) |
---|
248 | (match-local-name cellno (function-symbol-map lfun) pc)))))))) |
---|
249 | |
---|
250 | (defun map-entry-value (context cfp lfun pc idx unavailable) |
---|
251 | (declare (fixnum pc idx)) |
---|
252 | (let* ((info (function-symbol-map lfun))) |
---|
253 | (if (null info) |
---|
254 | unavailable |
---|
255 | (let* ((addrs (cdr info)) |
---|
256 | (i (* 3 idx)) |
---|
257 | (addr (svref addrs i)) |
---|
258 | (startpc (svref addrs (the fixnum (+ i 1)))) |
---|
259 | (endpc (svref addrs (the fixnum (+ i 2))))) |
---|
260 | (declare (fixnum i addr startpc endpc)) |
---|
261 | (if (or (< pc startpc) |
---|
262 | (>= pc endpc)) |
---|
263 | unavailable |
---|
264 | (let* ((value (if (= #o77 (ldb (byte 6 0) addr)) |
---|
265 | (raw-frame-ref cfp context (ash addr (- (+ target::word-shift 6))) |
---|
266 | unavailable) |
---|
267 | (find-register-argument-value context cfp addr unavailable)))) |
---|
268 | (if (typep value 'value-cell) |
---|
269 | (uvref value 0) |
---|
270 | value))))))) |
---|
271 | |
---|
272 | ;;; Returns non-nil on success (not newval) |
---|
273 | (defun set-map-entry-value (context cfp lfun pc idx newval) |
---|
274 | (declare (fixnum pc idx)) |
---|
275 | (let* ((unavailable (cons nil nil)) |
---|
276 | (value (map-entry-value context cfp lfun pc idx unavailable))) |
---|
277 | (if (eq value unavailable) |
---|
278 | nil |
---|
279 | (if (typep value 'value-cell) |
---|
280 | (progn (setf (uvref value 0) newval) t) |
---|
281 | |
---|
282 | (let* ((addrs (cdr (function-symbol-map lfun))) |
---|
283 | (addr (svref addrs (the fixnum (* 3 idx))))) |
---|
284 | (declare (fixnum addr)) |
---|
285 | (if (= #o77 (ldb (byte 6 0) addr)) |
---|
286 | (raw-frame-set cfp context (ash addr (- (+ target::word-shift 6))) newval) |
---|
287 | (set-register-argument-value context cfp addr newval)) |
---|
288 | t))))) |
---|
289 | |
---|
290 | |
---|
291 | (defun argument-value (context cfp lfun pc name &optional (quote t)) |
---|
292 | (declare (fixnum pc)) |
---|
293 | (let* ((info (function-symbol-map lfun)) |
---|
294 | (unavailable (%unbound-marker))) |
---|
295 | (if (null info) |
---|
296 | unavailable |
---|
297 | (let* ((names (car info)) |
---|
298 | (addrs (cdr info))) |
---|
299 | (do* ((nname (1- (length names)) (1- nname)) |
---|
300 | (naddr (- (length addrs) 3) (- naddr 3))) |
---|
301 | ((or (< nname 0) (< naddr 0)) unavailable) |
---|
302 | (declare (fixnum nname naddr)) |
---|
303 | (when (eq (svref names nname) name) |
---|
304 | (let* ((value |
---|
305 | (let* ((addr (svref addrs naddr)) |
---|
306 | (startpc (svref addrs (the fixnum (1+ naddr)))) |
---|
307 | (endpc (svref addrs (the fixnum (+ naddr 2))))) |
---|
308 | (declare (fixnum addr startpc endpc)) |
---|
309 | (if (or (< pc startpc) |
---|
310 | (>= pc endpc)) |
---|
311 | unavailable |
---|
312 | (if (= #o77 (ldb (byte 6 0) addr)) |
---|
313 | (raw-frame-ref cfp context (ash addr (- (+ target::word-shift 6))) |
---|
314 | unavailable) |
---|
315 | (find-register-argument-value context cfp addr unavailable)))))) |
---|
316 | (if (typep value 'value-cell) |
---|
317 | (setq value (uvref value 0))) |
---|
318 | (if (or (not quote) (self-evaluating-p value)) |
---|
319 | (return value) |
---|
320 | (return (list 'quote value)))))))))) |
---|
321 | |
---|
322 | |
---|
323 | |
---|
324 | (defun raw-frame-ref (cfp context index bad) |
---|
325 | (%raw-frame-ref cfp context index bad)) |
---|
326 | |
---|
327 | (defun raw-frame-set (cfp context index new) |
---|
328 | (%raw-frame-set cfp context index new)) |
---|
329 | |
---|
330 | (defun find-register-argument-value (context cfp regval bad) |
---|
331 | (%find-register-argument-value context cfp regval bad)) |
---|
332 | |
---|
333 | (defun set-register-argument-value (context cfp regval newval) |
---|
334 | (%set-register-argument-value context cfp regval newval)) |
---|
335 | |
---|
336 | |
---|
337 | |
---|
338 | (defun dbg-form (frame-number) |
---|
339 | (when *break-frame* |
---|
340 | (let* ((cfp (nth-raw-frame frame-number *break-frame* nil))) |
---|
341 | (if (and cfp (not (catch-csp-p cfp nil))) |
---|
342 | (multiple-value-bind (function pc) |
---|
343 | (cfp-lfun cfp) |
---|
344 | (if (and function |
---|
345 | (function-is-current-definition? function)) |
---|
346 | (block %cfp-form |
---|
347 | (collect ((form)) |
---|
348 | (multiple-value-bind (nreq nopt restp keys allow-other-keys |
---|
349 | optinit lexprp ncells nclosed) |
---|
350 | (function-args function) |
---|
351 | (declare (ignore ncells)) |
---|
352 | (unless (or lexprp restp (> 0 nclosed) (> 0 nopt) keys allow-other-keys |
---|
353 | optinit) |
---|
354 | (let* ((name (function-name function))) |
---|
355 | (multiple-value-bind (arglist win) |
---|
356 | (arglist-from-map function) |
---|
357 | (when (and win name (symbolp name)) |
---|
358 | (form name) |
---|
359 | (dotimes (i nreq) |
---|
360 | (let* ((val (argument-value nil cfp function pc (pop arglist)))) |
---|
361 | (if (closed-over-value-p val) |
---|
362 | (setq val (%svref val target::value-cell.value-cell))) |
---|
363 | (if (eq val (%unbound-marker)) |
---|
364 | (return-from %cfp-form nil)) |
---|
365 | (form val)))))))) |
---|
366 | (form))))))))) |
---|
367 | |
---|
368 | (defun function-args (lfun) |
---|
369 | "Returns 9 values, as follows: |
---|
370 | req = number of required arguments |
---|
371 | opt = number of optional arguments |
---|
372 | restp = t if rest arg |
---|
373 | keys = number of keyword arguments or NIL if &key not mentioned |
---|
374 | allow-other-keys = t if &allow-other-keys present |
---|
375 | optinit = t if any optional arg has non-nil default value or supplied-p |
---|
376 | variable |
---|
377 | lexprp = t if function is a lexpr, in which case all other values are |
---|
378 | undefined. |
---|
379 | ncells = number of stack frame cells used by all arguments. |
---|
380 | nclosed = number of inherited values (now counted distinctly from required) |
---|
381 | All numeric values (but ncells) are mod 64." |
---|
382 | (let* ((bits (lfun-bits lfun)) |
---|
383 | (req (ldb $lfbits-numreq bits)) |
---|
384 | (opt (ldb $lfbits-numopt bits)) |
---|
385 | (restp (logbitp $lfbits-rest-bit bits)) |
---|
386 | (keyvect (lfun-keyvect lfun)) |
---|
387 | (keys (and keyvect (length keyvect))) |
---|
388 | (allow-other-keys (logbitp $lfbits-aok-bit bits)) |
---|
389 | (optinit (logbitp $lfbits-optinit-bit bits)) |
---|
390 | (lexprp (logbitp $lfbits-restv-bit bits)) |
---|
391 | (nclosed (ldb $lfbits-numinh bits))) |
---|
392 | (values req opt restp keys allow-other-keys optinit lexprp |
---|
393 | (unless (or lexprp) |
---|
394 | (+ req opt (if restp 1 0) (if keys (+ keys keys) 0) |
---|
395 | (if optinit opt 0) nclosed)) |
---|
396 | nclosed))) |
---|
397 | |
---|
398 | ;;; If we can tell reliably, return the function's minimum number of |
---|
399 | ;;; non-inherited arguments, the maximum number of such arguments (or NIL), |
---|
400 | ;;; and the actual number of such arguments. We "can't tell" if either |
---|
401 | ;;; of the arguments to this function are null, and we can't tell reliably |
---|
402 | ;;; if any of the lfbits fields are full. |
---|
403 | (defun min-max-actual-args (fn nargs) |
---|
404 | (let* ((lfbits (if (and fn nargs) |
---|
405 | (lfun-bits fn) |
---|
406 | -1)) |
---|
407 | (raw-req (ldb $lfbits-numreq lfbits)) |
---|
408 | (raw-opt (ldb $lfbits-numopt lfbits)) |
---|
409 | (raw-inh (ldb $lfbits-numinh lfbits))) |
---|
410 | (declare (fixnum raw-req raw-opt raw-inh)) |
---|
411 | (if (or (eql raw-req (1- (ash 1 (byte-size $lfbits-numreq)))) |
---|
412 | (eql raw-opt (1- (ash 1 (byte-size $lfbits-numopt)))) |
---|
413 | (eql raw-inh (1- (ash 1 (byte-size $lfbits-numinh))))) |
---|
414 | (values nil nil nil) |
---|
415 | (values raw-req |
---|
416 | (unless (or (lfun-keyvect fn) |
---|
417 | (logbitp $lfbits-rest-bit lfbits) |
---|
418 | (logbitp $lfbits-restv-bit lfbits)) |
---|
419 | (+ raw-req raw-opt)) |
---|
420 | (- nargs raw-inh))))) |
---|
421 | |
---|
422 | |
---|
423 | |
---|
424 | (defun closed-over-value-p (value) |
---|
425 | (eql target::subtag-value-cell (typecode value))) |
---|
426 | |
---|
427 | |
---|
428 | (defun variables-in-scope (lfun pc) |
---|
429 | ;; Return a list of all symbol names "in scope" in the function lfun |
---|
430 | ;; at relative program counter PC, using the function's symbol map. |
---|
431 | ;; The list will be ordered so that least-recent bindings appear first. |
---|
432 | ;; Return a list of the matching symbol map entries as a second value |
---|
433 | (when pc |
---|
434 | (locally (declare (fixnum pc)) |
---|
435 | (let* ((map (function-symbol-map lfun)) |
---|
436 | (names (car map)) |
---|
437 | (info (cdr map))) |
---|
438 | (when map |
---|
439 | (let* ((vars ()) |
---|
440 | (indices ())) |
---|
441 | (dotimes (i (length names) (values vars indices)) |
---|
442 | (let* ((start-pc (aref info (1+ (* 3 i)))) |
---|
443 | (end-pc (aref info (+ 2 (* 3 i))))) |
---|
444 | (declare (fixnum start-pc end-pc)) |
---|
445 | (when (and (>= pc start-pc) |
---|
446 | (< pc end-pc)) |
---|
447 | (push i indices) |
---|
448 | (push (svref names i) vars)))))))))) |
---|
449 | |
---|
450 | |
---|
451 | (defun arg-value (context cfp lfun pc unavailable name) |
---|
452 | (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc) |
---|
453 | (multiple-value-bind (valid req opt rest keys) |
---|
454 | (arg-names-from-map lfun pc) |
---|
455 | (if valid |
---|
456 | (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys))) |
---|
457 | (pos (position name vars))) |
---|
458 | (if (and pos (< pos nargs)) |
---|
459 | (map-entry-value context cfp lfun pc (nth pos map-indices) unavailable) |
---|
460 | unavailable)) |
---|
461 | unavailable)))) |
---|
462 | |
---|
463 | (defun local-value (context cfp lfun pc unavailable name) |
---|
464 | (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc) |
---|
465 | (multiple-value-bind (valid req opt rest keys) |
---|
466 | (arg-names-from-map lfun pc) |
---|
467 | (if valid |
---|
468 | (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys))) |
---|
469 | (names (nthcdr nargs vars)) |
---|
470 | (indices (nthcdr nargs map-indices)) |
---|
471 | (pos (if (typep name 'unsigned-byte) |
---|
472 | name |
---|
473 | (position name names :from-end t)))) |
---|
474 | (if (and pos (< pos nargs)) |
---|
475 | (map-entry-value context cfp lfun pc (nth pos indices) unavailable) |
---|
476 | unavailable)) |
---|
477 | unavailable)))) |
---|
478 | |
---|
479 | (defun set-arg-value (context cfp lfun pc name new) |
---|
480 | (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc) |
---|
481 | (multiple-value-bind (valid req opt rest keys) |
---|
482 | (arg-names-from-map lfun pc) |
---|
483 | (if valid |
---|
484 | (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys))) |
---|
485 | (pos (position name vars))) |
---|
486 | (when (and pos (< pos nargs)) |
---|
487 | (set-map-entry-value context cfp lfun pc (nth pos map-indices) new))))))) |
---|
488 | |
---|
489 | (defun set-local-value (context cfp lfun pc name new) |
---|
490 | (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc) |
---|
491 | (multiple-value-bind (valid req opt rest keys) |
---|
492 | (arg-names-from-map lfun pc) |
---|
493 | (if valid |
---|
494 | (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys))) |
---|
495 | (names (nthcdr nargs vars)) |
---|
496 | (indices (nthcdr nargs map-indices)) |
---|
497 | (pos (if (typep name 'unsigned-byte) |
---|
498 | name |
---|
499 | (position name names :from-end t)))) |
---|
500 | (if (and pos (< pos nargs)) |
---|
501 | (set-map-entry-value context cfp lfun pc (nth pos indices) new))))))) |
---|
502 | |
---|
503 | |
---|
504 | (defun arguments-and-locals (context cfp lfun pc &optional unavailable) |
---|
505 | (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc) |
---|
506 | (collect ((args) |
---|
507 | (locals)) |
---|
508 | (multiple-value-bind (valid req opt rest keys) |
---|
509 | (arg-names-from-map lfun pc) |
---|
510 | (when valid |
---|
511 | (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys))) |
---|
512 | (nlocals (- (length vars) nargs)) |
---|
513 | (local-vars (nthcdr nargs vars)) |
---|
514 | (local-indices (nthcdr nargs map-indices)) |
---|
515 | (arg-vars (nbutlast vars nlocals)) |
---|
516 | (arg-indices (nbutlast map-indices nlocals))) |
---|
517 | (flet ((get-arg-value (name) |
---|
518 | (let* ((pos (position name arg-vars :test #'eq))) |
---|
519 | (when pos |
---|
520 | (args (cons name (map-entry-value context cfp lfun pc (nth pos arg-indices) unavailable)))))) |
---|
521 | (get-local-value (name) |
---|
522 | (when name |
---|
523 | (locals (cons name (map-entry-value context cfp lfun pc (pop local-indices) unavailable)))))) |
---|
524 | (dolist (name req) |
---|
525 | (get-arg-value name)) |
---|
526 | (dolist (name opt) |
---|
527 | (get-arg-value name)) |
---|
528 | (when rest |
---|
529 | (get-arg-value rest)) |
---|
530 | (dolist (name keys) |
---|
531 | (get-arg-value name)) |
---|
532 | #+no |
---|
533 | (setq local-vars (nreverse local-vars) |
---|
534 | local-indices (nreverse local-indices)) |
---|
535 | (dolist (name local-vars) |
---|
536 | (get-local-value name))))) |
---|
537 | (values (args) (locals)))))) |
---|
538 | |
---|
539 | |
---|
540 | |
---|
541 | (defun safe-cell-value (val) |
---|
542 | val) |
---|
543 | |
---|
544 | (defun closure-closed-over-values (closure) |
---|
545 | (when (typep closure 'compiled-lexical-closure) |
---|
546 | (let* ((inner (closure-function closure)) |
---|
547 | (nclosed (nth-value 8 (function-args inner))) |
---|
548 | (names (car (function-symbol-map inner)))) |
---|
549 | (when nclosed |
---|
550 | (collect ((cells)) |
---|
551 | (do* ((i (1- (length names)) (1- i)) |
---|
552 | (k 0 (1+ k)) |
---|
553 | (idx 2 (1+ idx))) |
---|
554 | ((= k nclosed) (reverse (cells))) |
---|
555 | (let* ((name (svref names i)) |
---|
556 | (imm (nth-immediate closure idx))) |
---|
557 | (cells (list name (if (closed-over-value-p imm) |
---|
558 | (closed-over-value imm) |
---|
559 | imm)))))))))) |
---|
560 | |
---|
561 | |
---|
562 | ;;; Find the oldest binding frame that binds the same symbol as |
---|
563 | ;;; FRAME in context. If found, return the saved value of that |
---|
564 | ;;; binding, else the value of the symbol in the context's thread. |
---|
565 | (defun oldest-binding-frame-value (context frame) |
---|
566 | (let* ((oldest nil) |
---|
567 | (binding-index (%fixnum-ref frame (ash 1 target::fixnum-shift)))) |
---|
568 | (do* ((db (db-link context) (%fixnum-ref db 0))) |
---|
569 | ((eq frame db) |
---|
570 | (if oldest |
---|
571 | (%fixnum-ref oldest (ash 2 target::fixnum-shift)) |
---|
572 | (let* ((symbol (binding-index-symbol binding-index))) |
---|
573 | (if context |
---|
574 | (symbol-value-in-tcr symbol (bt.tcr context)) |
---|
575 | (%sym-value symbol))))) |
---|
576 | (if (eq (%fixnum-ref db (ash 1 target::fixnum-shift)) binding-index) |
---|
577 | (setq oldest db))))) |
---|
578 | |
---|
579 | (defun (setf oldest-binding-frame-value) (new context frame) |
---|
580 | (let* ((oldest nil) |
---|
581 | (binding-index (%fixnum-ref frame (ash 1 target::fixnum-shift)))) |
---|
582 | (do* ((db (db-link context) (%fixnum-ref db 0))) |
---|
583 | ((eq frame db) |
---|
584 | (if oldest |
---|
585 | (setf (%fixnum-ref oldest (ash 2 target::fixnum-shift)) new) |
---|
586 | (let* ((symbol (binding-index-symbol binding-index))) |
---|
587 | (if context |
---|
588 | (setf (symbol-value-in-tcr symbol (bt.tcr context)) new) |
---|
589 | (%set-sym-value symbol new))))) |
---|
590 | (if (eq (%fixnum-ref db (ash 1 target::fixnum-shift)) binding-index) |
---|
591 | (setq oldest db))))) |
---|
592 | |
---|
593 | |
---|
594 | |
---|
595 | ;;; End of backtrace.lisp |
---|