source: trunk/source/lib/x86-backtrace.lisp @ 10118

Last change on this file since 10118 was 10118, checked in by rme, 11 years ago

Add x8632 support.

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