source: trunk/source/lib/arm-backtrace.lisp @ 14423

Last change on this file since 14423 was 14119, checked in by gb, 9 years ago

Changes from ARM branch. Need testing ...

File size: 6.4 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2010 Clozure Associates
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(in-package "CCL")
18
19(defun cfp-lfun (p)
20  (if (fake-stack-frame-p p)
21    (let* ((fn (%fixnum-ref p arm::fake-stack-frame.fn))
22           (lr (%fixnum-ref p arm::fake-stack-frame.lr)))
23      (if (and (typep fn 'function)
24               (typep lr 'fixnum))
25        (values fn lr)
26        (values nil nil)))
27    (if (and (typep p 'fixnum)
28             (lisp-frame-p p nil))
29      (%cfp-lfun p))))
30
31(defun catch-csp-p (p context)
32  (let ((catch (if context
33                 (bt.top-catch context)
34                 (%catch-top (%current-tcr)))))
35    (loop
36      (when (null catch) (return nil))
37      (let ((sp (catch-frame-sp catch)))
38        (when (eql sp p)
39          (return t)))
40      (setq catch (next-catch catch)))))
41
42(defun %stack< (index1 index2 &optional context)
43  (let* ((tcr (if context (bt.tcr context) (%current-tcr)))
44         (cs-area (%fixnum-ref tcr target::tcr.cs-area)))
45    (and (%ptr-in-area-p index1 cs-area)
46         (%ptr-in-area-p index2 cs-area)
47         (< (the fixnum index1) (the fixnum index2)))))
48
49(defun registers-used-by (lfun &optional at-pc)
50  (declare (ignore lfun at-pc))
51  (values nil nil))
52
53(defun exception-frame-p (f)
54  (fake-stack-frame-p f))
55
56
57;;; Used for printing only.
58(defun index->address (p)
59  (when (fake-stack-frame-p p)
60    (setq p (%fixnum-ref p arm::fake-stack-frame.sp)))
61  (ldb (byte  32 0)  (ash p arm::fixnumshift)))
62
63(defun %raw-frame-ref (cfp context idx bad)
64  (declare (fixnum idx))
65  (multiple-value-bind (frame base)
66      (vsp-limits cfp context)
67    (let* ((raw-size (- base frame)))
68      (declare (fixnum frame base raw-size))
69      (if (and (>= idx 0)
70               (< idx raw-size))
71        (let* ((addr (- (the fixnum (1- base))
72                        idx)))
73          (multiple-value-bind (db-count first-db last-db)
74              (count-db-links-in-frame frame base context)
75            (let* ((is-db-link
76                    (unless (zerop db-count)
77                      (do* ((last last-db (previous-db-link last first-db)))
78                           ((null last))
79                        (when (= addr last)                          (return t))))))
80              (if is-db-link
81                (oldest-binding-frame-value context addr)
82                (%fixnum-ref addr)))))
83        bad))))
84
85;;; Return two values: the vsp of p and the vsp of p's "parent" frame.
86;;; The "parent" frame vsp might actually be the end of p's segment,
87;;; if the real "parent" frame vsp is in another segment.
88(defun vsp-limits (p context)
89  (let* ((vsp (%frame-savevsp p))
90         parent)
91    (when (eql vsp 0)
92      ; This frame is where the code continues after an unwind-protect cleanup form
93      (setq vsp (%frame-savevsp (child-frame p context))))
94    (flet ((grand-parent (frame)
95             (let ((parent (parent-frame frame context)))
96               (when (and parent (eq parent (%frame-backlink frame context)))
97                 (let ((grand-parent (parent-frame parent context)))
98                   (when (and grand-parent (eq grand-parent (%frame-backlink parent context)))
99                     grand-parent))))))
100      (declare (dynamic-extent #'grand-parent))
101      (let* ((frame p)
102             grand-parent)
103        (loop
104          (setq grand-parent (grand-parent frame))
105          (when (or (null grand-parent) (not (eql 0 (%frame-savevsp grand-parent))))
106            (return))
107          (setq frame grand-parent))
108        (setq parent (parent-frame frame context)))
109      (let* ((parent-vsp (if parent (%frame-savevsp parent) vsp))
110             (tcr (if context (bt.tcr context) (%current-tcr)))
111             (vsp-area (%fixnum-ref tcr target::tcr.vs-area)))
112        (if (eql 0 parent-vsp)
113          (values vsp vsp)              ; p is the kernel frame pushed by an unwind-protect cleanup form
114          (progn
115            (unless vsp-area
116              (error "~s is not a stack frame pointer for context ~s" p tcr))
117            (unless (%ptr-in-area-p parent-vsp vsp-area)
118              (setq parent-vsp (%fixnum-ref vsp-area target::area.high)))
119            (values vsp parent-vsp)))))))
120
121(defun %frame-savevsp (p)
122  (if (fake-stack-frame-p p)
123    (%fixnum-ref p arm::fake-stack-frame.vsp)
124    (%%frame-savevsp p)))
125
126;;; Lexprs ?
127(defun arg-check-call-arguments (frame function)
128  (declare (ignore function))
129  (xp-argument-list (%fixnum-ref frame arm::fake-stack-frame.xp)))
130
131;;; Should never be called.
132(defun %find-register-argument-value (context csp regval bad)
133  (declare (ignore context csp regval))
134  bad)
135
136;;; Shouldn't be called.
137(defun %set-register-argument-value (context csp regval new)
138  (declare (ignore context csp regval))
139  new)
140
141(defun %raw-frame-set (frame context idx new)
142  (declare (fixnum frame idx))
143  (let* ((base (parent-frame frame context))
144         (raw-size (- base frame)))
145    (declare (fixnum base raw-size))
146    (if (and (>= idx 0)
147             (< idx raw-size))
148      (let* ((addr (- (the fixnum (1- base))
149                      idx)))
150        (multiple-value-bind (db-count first-db last-db)
151            (count-db-links-in-frame frame base context)
152          (let* ((is-db-link
153                  (unless (zerop db-count)
154                    (do* ((last last-db (previous-db-link last first-db)))
155                         ((null last))
156                      (when (= addr last)
157                        (return t))))))
158            (if is-db-link
159              (setf (oldest-binding-frame-value context addr) new)
160              (setf (%fixnum-ref addr) new))))))))
161
162(defun match-local-name (cellno info pc)
163  (when info
164    (let* ((syms (%car info))
165           (ptrs (%cdr info)))
166      (dotimes (i (length syms))
167        (let ((j (%i+ i (%i+ i i ))))
168          (and (eq (uvref ptrs j) (%ilogior (%ilsl (+ 6 target::word-shift) cellno) #o77))
169               (%i>= pc (uvref ptrs (%i+ j 1)))
170               (%i< pc (uvref ptrs (%i+ j 2)))
171               (return (aref syms i))))))))
Note: See TracBrowser for help on using the repository browser.