source: branches/working-0711/ccl/lib/x86-backtrace.lisp @ 11101

Last change on this file since 11101 was 11101, checked in by gz, 13 years ago

Another round of changes from the trunk, mostly just mods in internal mechanisms in support of various recent ports.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 17.5 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 
142                         #+x8632-target
143                         x8632::catch-frame.db-link-cell
144                         #+x8664-target
145                         x8664::catch-frame.save-save3-cell))))
146
147;;; Inverse of get-register-value
148
149(defun set-register-value (value address last-catch index)
150  (if address
151    (%fixnum-set address value)
152    (setf (uvref last-catch (+ index
153                               #+x8632-target
154                               x8632::catch-frame.db-link-cell
155                               #+x8664-target
156                               x8664::catch-frame.save-save3-cell))
157          value)))
158
159(defun %find-register-argument-value (context cfp regval bad)
160  (let* ((last-catch (last-catch-since cfp context))
161         (index (register-number->saved-register-index regval)))
162    (do* ((frame cfp (child-frame frame context))
163          (first t))
164         ((null frame))
165      (if (xcf-p frame)
166        (with-macptrs (xp)
167          (%setf-macptr-to-object xp (%fixnum-ref frame x8664::xcf.xp))
168          (return-from %find-register-argument-value
169            (encoded-gpr-lisp xp regval)))
170        (progn
171          (unless first
172            (multiple-value-bind (lfun pc)
173                (cfp-lfun frame)
174              (when lfun
175                (multiple-value-bind (mask where)
176                    (registers-used-by lfun pc)
177                  (when (if mask (logbitp index mask))
178                    (incf where (logcount (logandc2 mask (1- (ash 1 (1+ index))))))
179
180
181                    (return-from %find-register-argument-value
182                      (raw-frame-ref frame context where bad)))))))
183          (setq first nil))))
184    (get-register-value nil last-catch index)))
185
186(defun %set-register-argument-value (context cfp regval new)
187  (let* ((last-catch (last-catch-since cfp context))
188         (index (register-number->saved-register-index regval)))
189    (do* ((frame cfp (child-frame frame context))
190          (first t))
191         ((null frame))
192      (if (xcf-p frame)
193        (with-macptrs (xp)
194          (%setf-macptr-to-object xp (%fixnum-ref frame x8664::xcf.xp))
195          (return-from %set-register-argument-value
196            (setf (encoded-gpr-lisp xp regval) new)))
197        (progn
198          (unless first
199            (multiple-value-bind (lfun pc)
200                (cfp-lfun frame)
201              (when lfun
202                (multiple-value-bind (mask where)
203                    (registers-used-by lfun pc)
204                  (when (if mask (logbitp index mask))
205                    (incf where (logcount (logandc2 mask (1- (ash 1 (1+ index))))))
206
207                    (return-from %set-register-argument-value
208                      (raw-frame-set frame context where new)))))))
209          (setq first nil))))
210    (set-register-value new nil last-catch index)))
211
212;;; Used for printing only.
213(defun index->address (p)
214  (ldb (byte #+32-bit-target 32 #+64-bit-target 64 0)  (ash p target::fixnumshift)))
215
216(defun exception-frame-p (x)
217  (and x (xcf-p x)))
218
219;;; Function has failed a number-of-arguments check; return a list
220;;; of the actual arguments.
221;;; On x86-64, the kernel has finished the frame and pushed everything
222;;; for us, so all that we need to do is to hide any inherited arguments.
223(defun arg-check-call-arguments (fp function)
224  (when (xcf-p fp)
225    (with-macptrs (xp)
226      (%setf-macptr-to-object xp (%fixnum-ref fp target::xcf.xp))
227      (let* ((numinh (ldb $lfbits-numinh (lfun-bits function)))
228             (nargs (- (xp-argument-count xp) numinh))
229             (p (- (%fixnum-ref fp target::xcf.backptr)
230                   (* target::node-size numinh))))
231        (declare (fixnum numinh nargs p))
232        (collect ((args))
233          (dotimes (i nargs (args))
234            (args (%fixnum-ref p (- target::node-size)))
235            (decf p)))))))
236
237(defun vsp-limits (frame context)
238  (let* ((parent (parent-frame frame context)))
239    (if (xcf-p frame)
240      (values (+ frame (ash target::xcf.size (- target::word-shift)))
241              parent)
242      (let* ((tra (%fixnum-ref frame target::lisp-frame.return-address)))
243        (values (+ frame 2 (if (eq tra (%get-kernel-global ret1valaddr)) 1 0))
244                parent)))))
245
246(defun last-catch-since (fp context)
247  (let* ((tcr (if context (bt.tcr context) (%current-tcr)))
248         (catch (%catch-top tcr))
249         (last-catch nil))
250    (loop
251      (unless catch (return last-catch))
252      (let ((catch-fp (uvref catch
253                             #+x8632-target
254                             x8632::catch-frame.ebp-cell
255                             #+x8664-target
256                             x8664::catch-frame.rbp-cell)))
257        (when (%stack< fp catch-fp context) (return last-catch))
258        (setq last-catch catch
259              catch (next-catch catch))))))
260
261(defun last-xcf-since (target-fp start-fp context)
262  (do* ((last-xcf nil)
263        (fp start-fp (parent-frame fp context)))
264       ((or (eql fp target-fp)
265            (null fp)
266            (%stack< target-fp fp)) last-xcf)
267    (if (xcf-p fp) (setq last-xcf fp))))
268
269(defun match-local-name (cellno info pc)
270  (when info
271    (let* ((syms (%car info))
272           (ptrs (%cdr info)))
273      (dotimes (i (length syms))
274        (let ((j (%i+ i (%i+ i i ))))
275          (and (eq (uvref ptrs j) (%ilogior (%ilsl (+ 6 target::word-shift) cellno) #o77))
276               (%i>= pc (uvref ptrs (%i+ j 1)))
277               (%i< pc (uvref ptrs (%i+ j 2)))
278               (return (aref syms i))))))))
279
280(defun apply-in-frame (frame function arglist &optional context)
281  (setq function (coerce-to-function function))
282  (let* ((parent (parent-frame frame context)))
283    (when parent
284      (if (xcf-p parent)
285        (error "Can't unwind to exception frame ~s" frame)
286        (setq frame parent))
287      (if (or (null context)
288              (eq (bt.tcr context) (%current-tcr)))
289        (%apply-in-frame frame function arglist)
290        (let* ((process (tcr->process (bt.tcr context))))
291          (if process
292            (process-interrupt process #'%apply-in-frame frame function arglist)
293            (error "Can't find process for backtrace context ~s" context)))))))
294
295(defun return-from-frame (frame &rest values)
296  (apply-in-frame frame #'values values nil))
297   
298
299(defun last-tsp-before (target)
300  (declare (fixnum target))
301  (do* ((tsp (%fixnum-ref (%current-tcr) target::tcr.save-tsp)
302             (%fixnum-ref tsp target::tsp-frame.backptr)))
303       ((zerop tsp) nil)
304    (declare (fixnum tsp))
305    (when (> (the fixnum (%fixnum-ref tsp #+x8632-target x8632::tsp-frame.ebp
306                                          #+x8664-target x8664::tsp-frame.rbp))
307             target)
308      (return tsp))))
309
310   
311
312
313;;; We can't determine this reliably (yet).
314(defun last-foreign-sp-before (target)
315  (declare (fixnum target))
316  (do* ((cfp (%fixnum-ref (%current-tcr) target::tcr.foreign-sp)
317             (%fixnum-ref cfp target::csp-frame.backptr)))
318       ((zerop cfp))
319    (declare (fixnum cfp))
320    (let* ((rbp (%fixnum-ref cfp #+x8632-target x8632::csp-frame.ebp
321                                 #+x8664-target x8664::csp-frame.rbp)))
322      (declare (fixnum rbp))
323      (if (> rbp target)
324        (return cfp)
325        (if (zerop rbp)
326          (return nil))))))
327
328
329(defun %tsp-frame-containing-progv-binding (db)
330  (declare (fixnum db))
331  (do* ((tsp (%fixnum-ref (%current-tcr) target::tcr.save-tsp) next)
332        (next (%fixnum-ref tsp target::tsp-frame.backptr)
333              (%fixnum-ref tsp target::tsp-frame.backptr)))
334       ()
335    (declare (fixnum tsp next))
336    (let* ((rbp (%fixnum-ref tsp #+x8632-target x8632::tsp-frame.ebp
337                                 #+x8664-target x8664::tsp-frame.rbp)))
338      (declare (fixnum rbp))
339      (if (zerop rbp)
340        (return (values nil nil))
341        (if (and (> db tsp)
342                 (< db next))
343          (return (values tsp rbp)))))))
344
345       
346
347
348
349
350(defun last-binding-before (frame)
351  (declare (fixnum frame))
352  (do* ((db (%current-db-link) (%fixnum-ref db 0))
353        (tcr (%current-tcr))
354        (vs-area (%fixnum-ref tcr target::tcr.vs-area))
355        (vs-low (%fixnum-ref vs-area target::area.low))
356        (vs-high (%fixnum-ref vs-area target::area.high)))
357       ((eql db 0) nil)
358    (declare (fixnum db vs-low vs-high))
359    (if (and (> db vs-low)
360             (< db vs-high))
361      (if (> db frame)
362        (return db))
363      ;; db link points elsewhere; PROGV uses the temp stack
364      ;; to store an indefinite number of bindings.
365      (multiple-value-bind (tsp rbp)
366          (%tsp-frame-containing-progv-binding db)
367        (if tsp
368          (if (> rbp frame)
369            (return db)
370            ;; If the tsp frame is too young, we can skip
371            ;; all of the bindings it contains.  The tsp
372            ;; frame contains two words of overhead, followed
373            ;; by a count of binding records in the frame,
374            ;; followed by the youngest of "count" binding
375            ;; records (which happens to be the value of
376            ;; "db".)  Skip "count" binding records.
377            (dotimes (i (the fixnum (%fixnum-ref tsp target::dnode-size)))
378              (setq db (%fixnum-ref db 0))))
379          ;; If the binding record wasn't on the temp stack and wasn't
380          ;; on the value stack, that probably means that things are
381          ;; seriously screwed up.  This error will be almost
382          ;; meaningless to the user.
383          (error "binding record (#x~16,'0x/#x~16,'0x) not on temp or value stack" (index->address db) db))))))
384         
385
386
387(defun find-x8664-saved-nvrs (frame start-fp context)
388  (let* ((locations (make-array 16 :initial-element nil))
389         (need (logior (ash 1 x8664::save0)
390                       (ash 1 x8664::save1)
391                       (ash 1 x8664::save2)
392                       (ash 1 x8664::save3))))
393    (declare (fixnum need)
394             (dynamic-extent locations))
395    (do* ((parent frame child)
396          (child (child-frame parent context) (child-frame child context)))
397         ((or (= need 0) (eq child start-fp))
398          (values (%svref locations x8664::save0)
399                  (%svref locations x8664::save1)
400                  (%svref locations x8664::save2)
401                  (%svref locations x8664::save3)))
402      (multiple-value-bind (lfun pc) (cfp-lfun child)
403        (when (and lfun pc)
404          (multiple-value-bind (used where) (registers-used-by lfun pc)
405            (when (and used where (logtest used need))
406              (locally (declare (fixnum used))
407                (do* ((i x8664::save3 (1+ i)))
408                     ((or (= i 16) (= used 0)))
409                  (declare (type (mod 16) i))
410                  (when (logbitp i used)
411                    (when (logbitp i need)
412                      (setq need (logandc2 need (ash 1 i)))
413                      (setf (%svref locations i)
414                            (- (the fixnum (1- parent))
415                               (+ where (logcount (logandc2 used (1+ (ash 1 (1+ i)))))))))
416                    (setq used (logandc2 used (ash 1 i)))))))))))))
417                                         
418             
419         
420(defun %apply-in-frame (frame function arglist)
421  (let* ((target-catch (last-catch-since frame nil))
422         (start-fp (if target-catch
423                     (uvref target-catch target::catch-frame.rbp-cell)
424                     (%get-frame-ptr)))
425         (target-xcf (last-xcf-since frame start-fp nil))
426         (target-db-link (last-binding-before frame))
427         (target-tsp (last-tsp-before frame))
428         (target-foreign-sp (last-foreign-sp-before frame)))
429    (multiple-value-bind (save0-loc save1-loc save2-loc save3-loc)
430        (find-x8664-saved-nvrs frame start-fp nil)
431      (let* ((thunk (%clone-x86-function #'%%apply-in-frame-proto
432                                         frame
433                                         target-catch
434                                         target-db-link
435                                         target-xcf
436                                         target-tsp
437                                         target-foreign-sp
438                                         (if save0-loc
439                                           (- save0-loc frame)
440                                           0)
441                                         (if save1-loc
442                                           (- save1-loc frame)
443                                           0)
444                                         (if save2-loc
445                                           (- save2-loc frame)
446                                           0)
447                                         (if save3-loc
448                                           (- save3-loc frame)
449                                           0)
450                                         (coerce-to-function function)
451                                         arglist
452                                         0)))
453        (funcall thunk)))))
454
455           
456   
Note: See TracBrowser for help on using the repository browser.