source: branches/arm/lib/arm-backtrace.lisp @ 13922

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

More files from last commit.

arm-callback-support.lisp, arm-error-signal.lisp,
arm-trap-support.lisp,l1-boot-3.lisp: try to get basic stuff working
well enough to enable callbacks. Enable callbacks.

arm-backtrace.lisp: a little bit of platform-specific code and some
code from the PPC port, so that backtrace sort of works.

File size: 4.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 (and (typep p 'fixnum)
21           (lisp-frame-p p nil))
22    (%cfp-lfun p)))
23
24(defun catch-csp-p (p context)
25  (let ((catch (if context
26                 (bt.top-catch context)
27                 (%catch-top (%current-tcr)))))
28    (loop
29      (when (null catch) (return nil))
30      (let ((sp (catch-frame-sp catch)))
31        (when (eql sp p)
32          (return t)))
33      (setq catch (next-catch catch)))))
34
35(defun %stack< (index1 index2 &optional context)
36  (let* ((tcr (if context (bt.tcr context) (%current-tcr)))
37         (cs-area (%fixnum-ref tcr target::tcr.cs-area)))
38    (and (%ptr-in-area-p index1 cs-area)
39         (%ptr-in-area-p index2 cs-area)
40         (< (the fixnum index1) (the fixnum index2)))))
41
42(defun registers-used-by (lfun &optional at-pc)
43  (declare (ignore lfun at-pc))
44  (values nil nil))
45
46(defun exception-frame-p (f)
47  (fake-stack-frame-p f))
48
49
50;;; Used for printing only.
51(defun index->address (p)
52  (when (fake-stack-frame-p p)
53    (setq p (%fake-stack-frame.sp p)))
54  (ldb (byte  32 0)  (ash p arm::fixnumshift)))
55
56(defun %raw-frame-ref (cfp context idx bad)
57  (declare (fixnum idx))
58  (multiple-value-bind (frame base)
59      (vsp-limits cfp context)
60    (let* ((raw-size (- base frame)))
61      (declare (fixnum frame base raw-size))
62      (if (and (>= idx 0)
63               (< idx raw-size))
64        (let* ((addr (- (the fixnum (1- base))
65                        idx)))
66          (multiple-value-bind (db-count first-db last-db)
67              (count-db-links-in-frame frame base context)
68            (let* ((is-db-link
69                    (unless (zerop db-count)
70                      (do* ((last last-db (previous-db-link last first-db)))
71                           ((null last))
72                        (when (= addr last)                          (return t))))))
73              (if is-db-link
74                (oldest-binding-frame-value context addr)
75                (%fixnum-ref addr)))))
76        bad))))
77
78;;; Return two values: the vsp of p and the vsp of p's "parent" frame.
79;;; The "parent" frame vsp might actually be the end of p's segment,
80;;; if the real "parent" frame vsp is in another segment.
81(defun vsp-limits (p context)
82  (let* ((vsp (%frame-savevsp p))
83         parent)
84    (when (eql vsp 0)
85      ; This frame is where the code continues after an unwind-protect cleanup form
86      (setq vsp (%frame-savevsp (child-frame p context))))
87    (flet ((grand-parent (frame)
88             (let ((parent (parent-frame frame context)))
89               (when (and parent (eq parent (%frame-backlink frame context)))
90                 (let ((grand-parent (parent-frame parent context)))
91                   (when (and grand-parent (eq grand-parent (%frame-backlink parent context)))
92                     grand-parent))))))
93      (declare (dynamic-extent #'grand-parent))
94      (let* ((frame p)
95             grand-parent)
96        (loop
97          (setq grand-parent (grand-parent frame))
98          (when (or (null grand-parent) (not (eql 0 (%frame-savevsp grand-parent))))
99            (return))
100          (setq frame grand-parent))
101        (setq parent (parent-frame frame context)))
102      (let* ((parent-vsp (if parent (%frame-savevsp parent) vsp))
103             (tcr (if context (bt.tcr context) (%current-tcr)))
104             (vsp-area (%fixnum-ref tcr target::tcr.vs-area)))
105        (if (eql 0 parent-vsp)
106          (values vsp vsp)              ; p is the kernel frame pushed by an unwind-protect cleanup form
107          (progn
108            (unless vsp-area
109              (error "~s is not a stack frame pointer for context ~s" p tcr))
110            (unless (%ptr-in-area-p parent-vsp vsp-area)
111              (setq parent-vsp (%fixnum-ref vsp-area target::area.high)))
112            (values vsp parent-vsp)))))))
113
114(defun %frame-savevsp (p)
115  (if (fake-stack-frame-p p)
116    (%fake-stack-frame.vsp p)
117    (%%frame-savevsp p)))
Note: See TracBrowser for help on using the repository browser.