source: trunk/ccl/lib/ppc-backtrace.lisp @ 6925

Last change on this file since 6925 was 6925, checked in by gb, 13 years ago

Tighten some things up a bit.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 11.9 KB
Line 
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
18(in-package "CCL")
19
20(def-accessors (fake-stack-frame) %svref
21  nil                           ; 'fake-stack-frame
22  %fake-stack-frame.sp          ; fixnum. The stack pointer where this frame "should" be
23  %fake-stack-frame.next-sp     ; Either sp or another fake-stack-frame
24  %fake-stack-frame.fn          ; The current function
25  %fake-stack-frame.lr          ; fixnum offset from fn (nil if fn is not functionp)
26  %fake-stack-frame.vsp         ; The value stack pointer
27  %fake-stack-frame.xp          ; Exception frame.
28  %fake-stack-frame.link        ; next in *fake-stack-frames* list
29  )
30
31;;; Linked list of fake stack frames.
32;;; %frame-backlink looks here
33(def-standard-initial-binding *fake-stack-frames* nil)
34 
35
36(defun fake-stack-frame-p (x)
37  (istruct-typep x 'fake-stack-frame))
38
39(defun cfp-lfun (p)
40  (if (fake-stack-frame-p p)
41    (let* ((fn (%fake-stack-frame.fn p))
42           (lr (%fake-stack-frame.lr p)))
43      (if (and (typep fn 'function)
44               (typep lr 'fixnum))
45        (values fn lr)
46        (values nil nil)))
47    (%cfp-lfun p)))
48
49
50(defun %stack< (index1 index2 &optional context)
51  (cond ((fake-stack-frame-p index1)
52         (let ((sp1 (%fake-stack-frame.sp index1)))
53           (declare (fixnum sp1))
54           (if (fake-stack-frame-p index2)
55             (or (%stack< sp1 (%fake-stack-frame.sp index2) context)
56                 (eq index2 (%fake-stack-frame.next-sp index1)))
57             (%stack< sp1 (%i+ index2 1) context))))
58        ((fake-stack-frame-p index2)
59         (%stack< index1 (%fake-stack-frame.sp index2) context))
60        (t (let* ((tcr (if context (bt.tcr context) (%current-tcr)))
61                  (cs-area (%fixnum-ref tcr target::tcr.cs-area)))
62             (and (%ptr-in-area-p index1 cs-area)
63                  (%ptr-in-area-p index2 cs-area)
64                  (< (the fixnum index1) (the fixnum index2)))))))
65
66;;; Returns two values:
67;;;  [nil, nil] if it can be reliably determined that function uses no registers at PC
68;;;  [mask, savevsp]  if it can be reliably determined that the registers specified by "mask"
69;;;      were saved at "savevsp" in the function's stack frame
70;;;  [mask, nil] if registers in "mask" MAY have been saved, but we don't know how to restore them
71;;;      (perhaps because the "at-pc" argument wasn't specified.
72
73
74;;; If the last instruction in a code vector is an
75;;; LWZ instruction (of the form "(LWZ rx s16 ry)"),
76;;; then
77;;;   this function uses registers RX-R31.  Note that this leaves
78;;;    us 2 extra bits, since we're only encoding 3 bits worth of
79;;;    register info.
80;;;   RX is saved nearest the top of the vstack
81;;;   s16 is the offset from the saved-vsp to the address at which
82;;;    RX was saved; this is a negative value whose low two bits
83;;;    are ignored
84;;;   (logior (ash (logand s16 3) 5) rY) is the pc at which
85;;;   the registers were saved (a fullword code-vector index).
86;;; This scheme lets us encode any "simple" register usage, where
87;;; the registers were saved once, saved somewhere within the first
88;;; 128 instructions in the code vector, and nothing interesting (to
89;;; backtrace) happens after the registers have been restored.
90;;; If the compiler ever gets cleverer about this, we'll have to use
91;;; some other scheme (perhaps a STW instruction, preceded by branches).
92;;;
93;;; Note that the "last instruction" really means "last instruction
94;;; before any traceback table"; we should be able to truncate the code
95;;; vector (probably by copying it) to strip off the traceback table
96;;; without losing this information.
97;;; Note also that the disassembler would probably ordinarily want to
98;;; hide this last instruction ...
99;;;   
100
101#+ppc32-target
102(defun registers-used-by (lfun &optional at-pc)
103  (let* ((regs-used nil)
104         (where-saved nil))
105    (multiple-value-bind (op-high op-low) (%code-vector-last-instruction (uvref lfun 0))
106      (declare (fixnum op-high op-low))
107      (if (eql (ldb (byte 6 (- 26 16)) op-high) 32)       ; LWZ
108        (let* ((nregs (- 32 (ldb (byte 5 (- 21 16)) op-high)))
109               (pc (dpb (ldb (byte 2 0) op-low) (byte 2 5) (ldb (byte 5 (- 16 16)) op-high)))
110               (offset (%word-to-int (logand op-low (lognot 3)))))
111          (declare (fixnum nregs pc offset))
112          (setq regs-used (1- (ash 1 nregs)))
113          (if at-pc
114            (if (>= at-pc pc)
115              (setq where-saved (- (ash (- offset) -2) nregs))
116              (setq regs-used nil))))))
117    (values (and regs-used (bit-reverse-8 regs-used)) where-saved)))
118
119#+ppc64-target
120(defun registers-used-by (lfun &optional at-pc)
121  (let* ((regs-used nil)
122         (where-saved nil)
123         (instr (%code-vector-last-instruction (uvref lfun 0))))
124      (if (eql (ldb (byte 6 26) instr) 32)       ; LWZ
125        (let* ((nregs (- 32 (ldb (byte 5 21) instr)))
126               (pc (dpb (ldb (byte 2 0) instr) (byte 2 5) (ldb (byte 5 16) instr)))
127               (offset (%word-to-int (logand instr (lognot 7)))))
128          (declare (fixnum nregs pc offset))
129          (setq regs-used (1- (ash 1 nregs)))
130          (if at-pc
131            (if (>= at-pc pc)
132              (setq where-saved (- (ash (- offset) -3) nregs))
133              (setq regs-used nil)))))       
134      (values (and regs-used (bit-reverse-8 regs-used)) where-saved)))   
135 
136
137(defparameter *bit-reverse-8-table*
138  #.(let ((table (make-array 256 :element-type '(unsigned-byte 8))))
139      (dotimes (i 256)
140        (let ((j 0)
141              (out-mask (ash 1 7)))
142          (declare (fixnum j out-mask))
143          (dotimes (bit 8)
144            (when (logbitp bit i)
145              (setq j (logior j out-mask)))
146            (setq out-mask (ash out-mask -1)))
147          (setf (aref table i) j)))
148      table))
149
150(defun bit-reverse-8 (x)
151  (aref *bit-reverse-8-table* x))
152
153(defun %frame-savefn (p)
154  (if (fake-stack-frame-p p)
155    (%fake-stack-frame.fn p)
156    (%%frame-savefn p)))
157
158(defun %frame-savevsp (p)
159  (if (fake-stack-frame-p p)
160    (%fake-stack-frame.vsp p)
161    (%%frame-savevsp p)))
162
163(defun frame-vsp (frame)
164  (%frame-savevsp frame))
165
166;;; Return two values: the vsp of p and the vsp of p's "parent" frame.
167;;; The "parent" frame vsp might actually be the end of p's segment,
168;;; if the real "parent" frame vsp is in another segment.
169(defun vsp-limits (p context)
170  (let* ((vsp (%frame-savevsp p))
171         parent)
172    (when (eql vsp 0)
173      ; This frame is where the code continues after an unwind-protect cleanup form
174      (setq vsp (%frame-savevsp (child-frame p context))))
175    (flet ((grand-parent (frame)
176             (let ((parent (parent-frame frame context)))
177               (when (and parent (eq parent (%frame-backlink frame context)))
178                 (let ((grand-parent (parent-frame parent context)))
179                   (when (and grand-parent (eq grand-parent (%frame-backlink parent context)))
180                     grand-parent))))))
181      (declare (dynamic-extent #'grand-parent))
182      (let* ((frame p)
183             grand-parent)
184        (loop
185          (setq grand-parent (grand-parent frame))
186          (when (or (null grand-parent) (not (eql 0 (%frame-savevsp grand-parent))))
187            (return))
188          (setq frame grand-parent))
189        (setq parent (parent-frame frame context)))
190      (let* ((parent-vsp (if parent (%frame-savevsp parent) vsp))
191             (tcr (if context (bt.tcr context) (%current-tcr)))
192             (vsp-area (%fixnum-ref tcr target::tcr.vs-area)))
193        (if (eql 0 parent-vsp)
194          (values vsp vsp)              ; p is the kernel frame pushed by an unwind-protect cleanup form
195          (progn
196            (unless vsp-area
197              (error "~s is not a stack frame pointer for context ~s" p tcr))
198            (unless (%ptr-in-area-p parent-vsp vsp-area)
199              (setq parent-vsp (%fixnum-ref vsp-area target::area.high)))
200            (values vsp parent-vsp)))))))
201
202
203(defun catch-csp-p (p context)
204  (let ((catch (if context
205                 (bt.top-catch context)
206                 (%catch-top (%current-tcr)))))
207    (loop
208      (when (null catch) (return nil))
209      (let ((sp (catch-frame-sp catch)))
210        (when (eql sp p)
211          (return t)))
212      (setq catch (next-catch catch)))))
213
214(defun last-catch-since (sp context)
215  (let* ((tcr (if context (bt.tcr context) (%current-tcr)))
216         (catch (%catch-top tcr))
217         (last-catch nil))
218    (loop
219      (unless catch (return last-catch))
220      (let ((csp (uvref catch target::catch-frame.csp-cell)))
221        (when (%stack< sp csp context) (return last-catch))
222        (setq last-catch catch
223              catch (next-catch catch))))))
224
225(defun register-number->saved-register-index (regno)
226  (- regno ppc::save7))
227
228(defun %find-register-argument-value (context cfp regval bad)
229  (let* ((last-catch (last-catch-since cfp context))
230         (index (register-number->saved-register-index regval)))
231    (do* ((frame cfp
232                 (child-frame frame context))
233          (first t))
234         ((null frame))
235      (if (fake-stack-frame-p frame)
236        (return-from %find-register-argument-value
237          (xp-gpr-lisp (%fake-stack-frame.xp frame) regval))
238        (if first
239          (setq first nil)
240          (multiple-value-bind (lfun pc)
241              (cfp-lfun frame)
242            (when lfun
243              (multiple-value-bind (mask where)
244                  (registers-used-by lfun pc)
245                (when (if mask (logbitp index mask))
246                  (incf where (logcount (logandc2 mask (1- (ash 1 (1+ index))))))
247                  (return-from
248                   %find-register-argument-value
249                    (raw-frame-ref frame context where bad)))))))))
250    (get-register-value nil last-catch index)))
251
252(defun %raw-frame-ref (cfp context idx bad)
253  (declare (fixnum idx))
254  (multiple-value-bind (frame base)
255      (vsp-limits cfp context)
256    (let* ((raw-size (- base frame)))
257      (declare (fixnum frame base raw-size))
258      (if (and (>= idx 0)
259               (< idx raw-size))
260        (let* ((addr (- (the fixnum (1- base))
261                        idx)))
262          (multiple-value-bind (db-count first-db last-db)
263              (count-db-links-in-frame frame base context)
264            (let* ((is-db-link
265                    (unless (zerop db-count)
266                      (do* ((last last-db (previous-db-link last first-db)))
267                           ((null last))
268                        (when (= addr last)
269                          (return t))))))
270              (if is-db-link
271                (oldest-binding-frame-value context addr)
272                (%fixnum-ref addr)))))
273        bad))))
274
275;;; Used for printing only.
276(defun index->address (p)
277  (when (fake-stack-frame-p p)
278    (setq p (%fake-stack-frame.sp p)))
279  (ldb (byte #+32-bit-target 32 #+64-bit-target 64 0)  (ash p target::fixnumshift)))
280
281
282(defun match-local-name (cellno info pc)
283  (when info
284    (let* ((syms (%car info))
285           (ptrs (%cdr info)))
286      (dotimes (i (length syms))
287        (let ((j (%i+ i (%i+ i i ))))
288          (and (eq (uvref ptrs j) (%ilogior (%ilsl (+ 6 target::word-shift) cellno) #o77))
289               (%i>= pc (uvref ptrs (%i+ j 1)))
290               (%i< pc (uvref ptrs (%i+ j 2)))
291               (return (aref syms i))))))))
292
293(defun get-register-value (address last-catch index)
294  (if address
295    (%fixnum-ref address)
296    (uvref last-catch (+ index target::catch-frame.save-save7-cell))))
297
298;;; Inverse of get-register-value
299
300(defun set-register-value (value address last-catch index)
301  (if address
302    (%fixnum-set address value)
303    (setf (uvref last-catch (+ index target::catch-frame.save-save7-cell))
304          value)))
Note: See TracBrowser for help on using the repository browser.