source: branches/shrink-tcr/lib/x86-backtrace.lisp @ 14607

Last change on this file since 14607 was 14607, checked in by rme, 9 years ago

More tweaks; a cross-compiled Windows x86 lisp now bootstraps on Windows x64.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 17.1 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2006-2009 Clozure Associates and contributors
4;;;   This file is part of Clozure CL. 
5;;;
6;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with Clozure CL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   Clozure CL 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
18(in-package "CCL")
19
20
21;;; Returns two values:
22;;;  [nil, nil] if it can be reliably determined that function uses no registers at PC
23;;;  [mask, saved-location]  if it can be reliably determined that the registers specified by "mask"
24;;;      were saved at "saved-location" in the function's stack frame
25;;;  [mask, nil] if registers in "mask" MAY have been saved, but we don't know how to restore them
26;;;      (perhaps because the "at-pc" argument wasn't specified.
27
28
29(defun registers-used-by (function &optional at-pc)
30  (multiple-value-bind (mask stack-location rpc)
31      (%function-register-usage function)
32    (if (or (null mask)
33            (and at-pc rpc (<= at-pc rpc)))
34      (values nil nil)
35      (values (canonicalize-register-mask mask) (if (and at-pc rpc) stack-location)))))
36
37(defun canonicalize-register-mask (mask)
38  (dpb (ldb (byte 2 14) mask) (byte 2 2) (ldb (byte 2 11) mask)))
39
40(defun xcf-p (p)
41  (eql 0 (%fixnum-ref p target::lisp-frame.return-address)))
42
43(defun %current-xcf ()
44  (do* ((q (%get-frame-ptr) (%%frame-backlink q)))
45       ((zerop q))
46    (declare (fixnum q))
47    (when (xcf-p q) (return q))))
48
49;;; Try to determine the program counter value, relative to an xcf's nominal function.
50(defun pc-from-xcf (xcf)
51  (let* ((nominal-function (%fixnum-ref xcf target::xcf.nominal-function))
52         (containing-object (%fixnum-ref xcf target::xcf.containing-object)))
53    (when (typep nominal-function 'function)
54      (if (eq containing-object (function-to-function-vector nominal-function))
55        (- (%fixnum-ref xcf target::xcf.relative-pc)
56           #+x8632-target x8632::fulltag-misc
57           #+x8664-target x8664::tag-function)
58        (let* ((tra (%fixnum-ref xcf target::xcf.ra0)))
59          (if (and #+x8664-target (= (lisptag tra) x8664::tag-tra)
60                   #+x8632-target (= (fulltag tra) x8632::fulltag-tra)
61                   (eq nominal-function (%return-address-function tra)))
62            (%return-address-offset tra)))))))
63           
64(defun cfp-lfun (p)
65  (if (xcf-p p)
66    (values
67     (%fixnum-ref p target::xcf.nominal-function)
68     (pc-from-xcf p))
69    (%cfp-lfun p)))
70
71;;; On PPC, some frames on the control stack are associated with catch
72;;; frames rather than with function calls.  The whole concept doesn't
73;;; really apply here (e.g., nothing we encounter while walking frame
74;;; pointer links belongs to a catch frame.)
75(defun catch-csp-p (p context)
76  (declare (ignore p context)))
77
78(defun %raw-frame-ref (frame context idx bad)
79  (declare (fixnum frame idx))
80  (let* ((base (parent-frame frame context))
81         (raw-size (- base frame)))
82    (declare (fixnum base raw-size))
83    (if (and (>= idx 0)
84             (< idx raw-size))
85      (let* ((addr (- (the fixnum (1- base))
86                      idx)))
87        (multiple-value-bind (db-count first-db last-db)
88            (count-db-links-in-frame frame base context)
89          (let* ((is-db-link
90                  (unless (zerop db-count)
91                    (do* ((last last-db (previous-db-link last first-db)))
92                         ((null last))
93                      (when (= addr last)
94                        (return t))))))
95            (if is-db-link
96              (oldest-binding-frame-value context addr)
97              (%fixnum-ref addr)))))
98      bad)))
99
100(defun %raw-frame-set (frame context idx new)
101  (declare (fixnum frame idx))
102  (let* ((base (parent-frame frame context))
103         (raw-size (- base frame)))
104    (declare (fixnum base raw-size))
105    (if (and (>= idx 0)
106             (< idx raw-size))
107      (let* ((addr (- (the fixnum (1- base))
108                      idx)))
109        (multiple-value-bind (db-count first-db last-db)
110            (count-db-links-in-frame frame base context)
111          (let* ((is-db-link
112                  (unless (zerop db-count)
113                    (do* ((last last-db (previous-db-link last first-db)))
114                         ((null last))
115                      (when (= addr last)
116                        (return t))))))
117            (if is-db-link
118              (setf (oldest-binding-frame-value context addr) new)
119              (setf (%fixnum-ref addr) new))))))))
120
121(defun %stack< (index1 index2 &optional context)
122  (let* ((tcr (if context (bt.tcr context) (%current-tcr)))
123         (vs-area (%fixnum-ref tcr (- target::tcr.vs-area
124                                      target::tcr-bias))))
125    (and (%ptr-in-area-p index1 vs-area)
126         (%ptr-in-area-p index2 vs-area)
127         (< (the fixnum index1) (the fixnum index2)))))
128
129
130
131
132(defun register-number->saved-register-index (regnum)
133  (ecase regnum
134    (#.x8664::save3 0)
135    (#.x8664::save2 1)
136    (#.x8664::save1 2)
137    (#.x8664::save0 3)))
138
139
140(defun get-register-value (address last-catch index)
141  (if address
142    (%fixnum-ref address)
143    (uvref last-catch (+ index 
144                         #+x8632-target
145                         x8632::catch-frame.db-link-cell
146                         #+x8664-target
147                         x8664::catch-frame.save-save3-cell))))
148
149;;; Inverse of get-register-value
150
151(defun set-register-value (value address last-catch index)
152  (if address
153    (%fixnum-set address value)
154    (setf (uvref last-catch (+ index
155                               #+x8632-target
156                               x8632::catch-frame.db-link-cell
157                               #+x8664-target
158                               x8664::catch-frame.save-save3-cell))
159          value)))
160
161(defun %find-register-argument-value (context cfp regval bad)
162  (let* ((last-catch (last-catch-since cfp context))
163         (index (register-number->saved-register-index regval)))
164    (do* ((frame cfp (child-frame frame context))
165          (first t))
166         ((null frame))
167      (if (xcf-p frame)
168        (with-macptrs (xp)
169          (%setf-macptr-to-object xp (%fixnum-ref frame x8664::xcf.xp))
170          (return-from %find-register-argument-value
171            (encoded-gpr-lisp xp regval)))
172        (progn
173          (unless first
174            (multiple-value-bind (lfun pc)
175                (cfp-lfun frame)
176              (when lfun
177                (multiple-value-bind (mask where)
178                    (registers-used-by lfun pc)
179                  (when (if mask (logbitp index mask))
180                    (return-from %find-register-argument-value
181                      (if where
182                        (let ((offset (logcount (logandc2 mask (1- (ash 1 (1+ index)))))))
183                          (raw-frame-ref frame context (+ where offset) bad))
184                        bad)))))))
185          (setq first nil))))
186    (get-register-value nil last-catch index)))
187
188(defun %set-register-argument-value (context cfp regval new)
189  (let* ((last-catch (last-catch-since cfp context))
190         (index (register-number->saved-register-index regval)))
191    (do* ((frame cfp (child-frame frame context))
192          (first t))
193         ((null frame))
194      (if (xcf-p frame)
195        (with-macptrs (xp)
196          (%setf-macptr-to-object xp (%fixnum-ref frame x8664::xcf.xp))
197          (return-from %set-register-argument-value
198            (setf (encoded-gpr-lisp xp regval) new)))
199        (progn
200          (unless first
201            (multiple-value-bind (lfun pc)
202                (cfp-lfun frame)
203              (when lfun
204                (multiple-value-bind (mask where)
205                    (registers-used-by lfun pc)
206                  (when (if mask (logbitp index mask))
207                    (incf where (logcount (logandc2 mask (1- (ash 1 (1+ index))))))
208
209                    (return-from %set-register-argument-value
210                      (raw-frame-set frame context where new)))))))
211          (setq first nil))))
212    (set-register-value new nil last-catch index)))
213
214;;; Used for printing only.
215(defun index->address (p)
216  (ldb (byte #+32-bit-target 32 #+64-bit-target 64 0)  (ash p target::fixnumshift)))
217
218(defun exception-frame-p (x)
219  (and x (xcf-p x)))
220
221;;; Function has failed a number-of-arguments check; return a list
222;;; of the actual arguments.
223;;; On x86-64, the kernel has finished the frame and pushed everything
224;;; for us, so all that we need to do is to hide any inherited arguments.
225(defun arg-check-call-arguments (fp function)
226  (when (xcf-p fp)
227    (with-macptrs (xp)
228      (%setf-macptr-to-object xp (%fixnum-ref fp target::xcf.xp))
229      (let* ((numinh (ldb $lfbits-numinh (lfun-bits function)))
230             (nargs (- (xp-argument-count xp) numinh))
231             (p (- (%fixnum-ref fp target::xcf.backptr)
232                   (* target::node-size numinh))))
233        (declare (fixnum numinh nargs p))
234        (collect ((args))
235          (dotimes (i nargs (args))
236            (args (%fixnum-ref p (- target::node-size)))
237            (decf p)))))))
238
239(defun vsp-limits (frame context)
240  (let* ((parent (parent-frame frame context)))
241    (if (xcf-p frame)
242      (values (+ frame (ash target::xcf.size (- target::word-shift)))
243              parent)
244      (let* ((tra (%fixnum-ref frame target::lisp-frame.return-address)))
245        (values (+ frame 2 (if (eq tra (%get-kernel-global ret1valaddr)) 1 0))
246                parent)))))
247
248(defun last-catch-since (fp context)
249  (let* ((tcr (if context (bt.tcr context) (%current-tcr)))
250         (catch (%catch-top tcr))
251         (last-catch nil))
252    (loop
253      (unless catch (return last-catch))
254      (let ((catch-fp (uvref catch
255                             #+x8632-target
256                             x8632::catch-frame.ebp-cell
257                             #+x8664-target
258                             x8664::catch-frame.rbp-cell)))
259        (when (%stack< fp catch-fp context) (return last-catch))
260        (setq last-catch catch
261              catch (next-catch catch))))))
262
263(defun last-xcf-since (target-fp start-fp context)
264  (do* ((last-xcf nil)
265        (fp start-fp (parent-frame fp context)))
266       ((or (eql fp target-fp)
267            (null fp)
268            (%stack< target-fp fp)) last-xcf)
269    (if (xcf-p fp) (setq last-xcf fp))))
270
271(defun match-local-name (cellno info pc)
272  (when info
273    (let* ((syms (%car info))
274           (ptrs (%cdr info)))
275      (dotimes (i (length syms))
276        (let ((j (%i+ i (%i+ i i ))))
277          (and (eq (uvref ptrs j) (%ilogior (%ilsl (+ 6 target::word-shift) cellno) #o77))
278               (%i>= pc (uvref ptrs (%i+ j 1)))
279               (%i< pc (uvref ptrs (%i+ j 2)))
280               (return (aref syms i))))))))
281
282(defun apply-in-frame (frame function arglist &optional context)
283  (setq function (coerce-to-function function))
284  (let* ((parent (parent-frame frame context)))
285    (when parent
286      (if (xcf-p parent)
287        (error "Can't unwind to exception frame ~s" frame)
288        (setq frame parent))
289      (if (or (null context)
290              (eq (bt.tcr context) (%current-tcr)))
291        (%apply-in-frame frame function arglist)
292        (let* ((process (tcr->process (bt.tcr context))))
293          (if process
294            (process-interrupt process #'%apply-in-frame frame function arglist)
295            (error "Can't find process for backtrace context ~s" context)))))))
296
297(defun return-from-frame (frame &rest values)
298  (apply-in-frame frame #'values values nil))
299   
300
301(defun last-tsp-before (target)
302  (declare (fixnum target))
303  (do* ((tsp (%fixnum-ref (%current-tcr) (- target::tcr.save-tsp
304                                            target::tcr-bias))
305             (%fixnum-ref tsp target::tsp-frame.backptr)))
306       ((zerop tsp) nil)
307    (declare (fixnum tsp))
308    (when (> (the fixnum (%fixnum-ref tsp #+x8632-target x8632::tsp-frame.ebp
309                                          #+x8664-target x8664::tsp-frame.rbp))
310             target)
311      (return tsp))))
312
313   
314
315
316;;; We can't determine this reliably (yet).
317(defun last-foreign-sp-before (target)
318  (declare (fixnum target))
319  (do* ((cfp (%fixnum-ref (%current-tcr) (- target::tcr.foreign-sp
320                                            target::tcr-bias))
321             (%fixnum-ref cfp target::csp-frame.backptr)))
322       ((zerop cfp))
323    (declare (fixnum cfp))
324    (let* ((rbp (%fixnum-ref cfp #+x8632-target x8632::csp-frame.ebp
325                                 #+x8664-target x8664::csp-frame.rbp)))
326      (declare (fixnum rbp))
327      (if (> rbp target)
328        (return cfp)
329        (if (zerop rbp)
330          (return nil))))))
331
332
333(defun %tsp-frame-containing-progv-binding (db)
334  (declare (fixnum db))
335  (do* ((tsp (%fixnum-ref (%current-tcr) (- target::tcr.save-tsp
336                                            target::tcr-bias)) next)
337        (next (%fixnum-ref tsp target::tsp-frame.backptr)
338              (%fixnum-ref tsp target::tsp-frame.backptr)))
339       ()
340    (declare (fixnum tsp next))
341    (let* ((rbp (%fixnum-ref tsp #+x8632-target x8632::tsp-frame.ebp
342                                 #+x8664-target x8664::tsp-frame.rbp)))
343      (declare (fixnum rbp))
344      (if (zerop rbp)
345        (return (values nil nil))
346        (if (and (> db tsp)
347                 (< db next))
348          (return (values tsp rbp)))))))
349
350       
351
352
353
354
355(defun last-binding-before (frame)
356  (declare (fixnum frame))
357  (do* ((db (%current-db-link) (%fixnum-ref db 0))
358        (tcr (%current-tcr))
359        (vs-area (%fixnum-ref tcr (- target::tcr.vs-area
360                                     target::tcr-bias)))
361        (vs-low (%fixnum-ref vs-area target::area.low))
362        (vs-high (%fixnum-ref vs-area target::area.high)))
363       ((eql db 0) nil)
364    (declare (fixnum db vs-low vs-high))
365    (if (and (> db vs-low)
366             (< db vs-high))
367      (if (> db frame)
368        (return db))
369      ;; db link points elsewhere; PROGV uses the temp stack
370      ;; to store an indefinite number of bindings.
371      (multiple-value-bind (tsp rbp)
372          (%tsp-frame-containing-progv-binding db)
373        (if tsp
374          (if (> rbp frame)
375            (return db)
376            ;; If the tsp frame is too young, we can skip
377            ;; all of the bindings it contains.  The tsp
378            ;; frame contains two words of overhead, followed
379            ;; by a count of binding records in the frame,
380            ;; followed by the youngest of "count" binding
381            ;; records (which happens to be the value of
382            ;; "db".)  Skip "count" binding records.
383            (dotimes (i (the fixnum (%fixnum-ref tsp target::dnode-size)))
384              (setq db (%fixnum-ref db 0))))
385          ;; If the binding record wasn't on the temp stack and wasn't
386          ;; on the value stack, that probably means that things are
387          ;; seriously screwed up.  This error will be almost
388          ;; meaningless to the user.
389          (error "binding record (#x~16,'0x/#x~16,'0x) not on temp or value stack" (index->address db) db))))))
390         
391
392
393(defun find-x8664-saved-nvrs (frame start-fp context)
394  (let* ((locations (make-array 16 :initial-element nil))
395         (need (logior (ash 1 x8664::save0)
396                       (ash 1 x8664::save1)
397                       (ash 1 x8664::save2)
398                       (ash 1 x8664::save3))))
399    (declare (fixnum need)
400             (dynamic-extent locations))
401    (do* ((parent frame child)
402          (child (child-frame parent context) (child-frame child context)))
403         ((or (= need 0) (eq child start-fp))
404          (values (%svref locations x8664::save0)
405                  (%svref locations x8664::save1)
406                  (%svref locations x8664::save2)
407                  (%svref locations x8664::save3)))
408      (multiple-value-bind (lfun pc) (cfp-lfun child)
409        (when (and lfun pc)
410          (multiple-value-bind (used where) (registers-used-by lfun pc)
411            (when (and used where (logtest used need))
412              (locally (declare (fixnum used))
413                (do* ((i x8664::save3 (1+ i)))
414                     ((or (= i 16) (= used 0)))
415                  (declare (type (mod 16) i))
416                  (when (logbitp i used)
417                    (when (logbitp i need)
418                      (setq need (logandc2 need (ash 1 i)))
419                      (setf (%svref locations i)
420                            (- (the fixnum (1- parent))
421                               (+ where (logcount (logandc2 used (1+ (ash 1 (1+ i)))))))))
422                    (setq used (logandc2 used (ash 1 i)))))))))))))
423                                         
424             
425         
426(defun %apply-in-frame (frame function arglist)
427  (target-arch-case
428   (:x8632 (error "%apply-in-frame doesn't work for x8632 yet"))
429   (:x8664
430    (let* ((target-catch (last-catch-since frame nil))
431           (start-fp (if target-catch
432                       (uvref target-catch x8664::catch-frame.rbp-cell)
433                       (%get-frame-ptr)))
434           (target-xcf (last-xcf-since frame start-fp nil))
435           (target-db-link (last-binding-before frame))
436           (target-tsp (last-tsp-before frame))
437           (target-foreign-sp (last-foreign-sp-before frame)))
438      (multiple-value-bind (save0-loc save1-loc save2-loc save3-loc)
439          (find-x8664-saved-nvrs frame start-fp nil)
440        (let* ((thunk (%clone-x86-function #'%%apply-in-frame-proto
441                                           frame
442                                           target-catch
443                                           target-db-link
444                                           target-xcf
445                                           target-tsp
446                                           target-foreign-sp
447                                           (if save0-loc
448                                             (- save0-loc frame)
449                                             0)
450                                           (if save1-loc
451                                             (- save1-loc frame)
452                                             0)
453                                           (if save2-loc
454                                             (- save2-loc frame)
455                                             0)
456                                           (if save3-loc
457                                             (- save3-loc frame)
458                                             0)
459                                           (coerce-to-function function)
460                                           arglist
461                                           0)))
462          (funcall thunk)))))))
463
464           
465   
Note: See TracBrowser for help on using the repository browser.