source: trunk/source/level-1/arm-trap-support.lisp @ 15109

Last change on this file since 15109 was 14767, checked in by gb, 8 years ago

RETURN-ADDRESS-OFFSET: ARM code vectors are in the 1st element of
the function object, not element 0.

File size: 7.7 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#+androidarm-target
20(eval-when (:compile-toplevel :execute)
21  (def-foreign-type :__sigset_t
22      (:struct nil
23        (:__val (:array :unsigned-long 32)))) 
24  (def-foreign-type nil
25      (:struct :sigcontext
26        (:trap_no :unsigned-long)
27        (:error_code :unsigned-long)
28        (:oldmask :unsigned-long)
29        (:arm_r0 :unsigned-long)
30        (:arm_r1 :unsigned-long)
31        (:arm_r2 :unsigned-long)
32        (:arm_r3 :unsigned-long)
33        (:arm_r4 :unsigned-long)
34        (:arm_r5 :unsigned-long)
35        (:arm_r6 :unsigned-long)
36        (:arm_r7 :unsigned-long)
37        (:arm_r8 :unsigned-long)
38        (:arm_r9 :unsigned-long)
39        (:arm_r10 :unsigned-long)
40        (:arm_fp :unsigned-long)
41        (:arm_ip :unsigned-long)
42        (:arm_sp :unsigned-long)
43        (:arm_lr :unsigned-long)
44        (:arm_pc :unsigned-long)
45        (:arm_cpsr :unsigned-long)
46        (:fault_address :unsigned-long)))
47  (def-foreign-type :mcontext_t (:struct :sigcontext))
48  (def-foreign-type nil
49      (:struct :sigaltstack
50        (:ss_sp :address)
51        (:ss_flags :int)
52        (:ss_size :size_t)))
53  (def-foreign-type :stack_t (:struct :sigaltstack))
54  (def-foreign-type nil
55      (:struct :ucontext
56        (:uc_flags :unsigned-long)
57        (:uc_link (:* (:struct :ucontext)))
58        (:uc_stack :stack_t)
59        (:uc_mcontext :mcontext_t)
60        (:uc_sigmask :__sigset_t)
61        (:uc_regspace (:array :unsigned-long 128))))
62  (def-foreign-type :ucontext_t (:struct :ucontext)))
63 
64   
65 
66 
67       
68       
69#+linuxarm-target
70(progn
71(defmacro with-xp-registers-and-gpr-offset ((xp register-number)
72                                            (registers offset) &body body)
73  (let* ((regform `(pref ,xp :ucontext.uc_mcontext)))
74    `(with-macptrs ((,registers ,regform))
75      (let ((,offset (xp-gpr-offset ,register-number)))
76        ,@body))))
77(defun xp-gpr-offset (register-number)
78  (unless (and (fixnump register-number)
79               (<= -3 (the fixnum register-number))
80               (< (the fixnum register-number) 18))
81    (setq register-number (require-type register-number '(integer -3 (18)))))
82  (the fixnum (* (the fixnum (+ register-number 3)) arm::node-size)))
83(defconstant xp-cpsr-regno 16)
84)
85
86#+darwinarm-target
87(progn
88(defmacro with-xp-registers-and-gpr-offset ((xp register-number)
89                                            (registers offset) &body body)
90  (let* ((regform `(pref ,xp :ucontext_t.uc_mcontext.__ss)))
91    `(with-macptrs ((,registers ,regform))
92      (let ((,offset (xp-gpr-offset ,register-number)))
93        ,@body))))
94(defun xp-gpr-offset (register-number)
95  (unless (and (fixnump register-number)
96               (<= 0 (the fixnum register-number))
97               (< (the fixnum register-number) 17))
98    (setq register-number (require-type register-number '(integer 0 (17)))))
99  (the fixnum (* (the fixnum register-number) arm::node-size)))
100(defconstant xp-cpsr-regno 16)
101)
102
103(defun xp-gpr-lisp (xp register-number)
104  (with-xp-registers-and-gpr-offset (xp register-number) (registers offset)
105    (values (%get-object registers offset))))
106
107(defun (setf xp-gpr-lisp) (value xp register-number)
108  (with-xp-registers-and-gpr-offset (xp register-number) (registers offset)
109    (%set-object registers offset value)))
110
111(defun xp-gpr-signed-long (xp register-number)
112  (with-xp-registers-and-gpr-offset (xp register-number) (registers offset)
113    (values (%get-signed-long registers offset))))
114
115(defun xp-gpr-signed-doubleword (xp register-number)
116  (with-xp-registers-and-gpr-offset (xp register-number) (registers offset)
117    (values (%%get-signed-longlong registers offset))))
118 
119
120(defun xp-gpr-macptr (xp register-number)
121  (with-xp-registers-and-gpr-offset (xp register-number) (registers offset)
122    (values (%get-ptr registers offset))))
123
124(defun return-address-offset (xp fn machine-state-offset)
125  (with-macptrs ((regs (pref xp #+linuxarm-target :ucontext.uc_mcontext
126                                #+darwinarm-target :ucontext_t.uc_mcontext.__ss)))
127    (if (functionp fn)
128      (or (%code-vector-pc (uvref fn 1) (%inc-ptr regs machine-state-offset))
129           (%get-ptr regs machine-state-offset))
130      (%get-ptr regs machine-state-offset))))
131
132(defconstant lr-offset-in-register-context
133  #+linuxarm-target (get-field-offset :sigcontext.arm_lr)
134  #+darwinarm-target (get-field-offset :__darwin_arm_thread_state.__lr))
135
136(defconstant pc-offset-in-register-context
137  #+linuxarm-target (get-field-offset :sigcontext.arm_pc)
138  #+darwinarm-target (get-field-offset :__darwin_arm_thread_state.__pc))
139
140(defun funcall-with-xp-stack-frames (xp trap-function thunk)
141  (cond ((null trap-function)
142         ; Maybe inside a subprim from a lisp function
143         (let* ((fn (xp-gpr-lisp xp arm::fn))
144                (lr (return-address-offset
145                     xp fn lr-offset-in-register-context)))
146           (if (fixnump lr)
147             (let* ((sp (xp-gpr-lisp xp arm::sp))
148                    (vsp (xp-gpr-lisp xp arm::vsp))
149                    (frame (make-fake-stack-frame sp sp fn lr vsp xp)))
150               (declare (dynamic-extent frame))
151               (funcall thunk (%dnode-address-of frame)))
152             (funcall thunk (xp-gpr-lisp xp arm::sp)))))
153        ((eq trap-function (xp-gpr-lisp xp arm::fn))
154         (let* ((sp (xp-gpr-lisp xp arm::sp))
155                (fn trap-function)
156                (lr (return-address-offset
157                     xp fn pc-offset-in-register-context))
158                (vsp (xp-gpr-lisp xp arm::vsp))
159                (frame (make-fake-stack-frame sp sp fn lr vsp xp)))
160           (declare (dynamic-extent frame))
161           (funcall thunk (%dnode-address-of frame))))
162        ((eq trap-function (xp-gpr-lisp xp arm::nfn))
163         (let* ((sp (xp-gpr-lisp xp arm::sp))
164                (fn (xp-gpr-lisp xp arm::fn))
165                (lr (return-address-offset
166                     xp fn lr-offset-in-register-context))
167                (vsp (xp-gpr-lisp xp arm::vsp))
168                (lr-frame (make-fake-stack-frame sp sp fn lr vsp xp))
169                (pc-fn trap-function)
170                (pc-lr (return-address-offset
171                        xp pc-fn pc-offset-in-register-context))
172                (pc-frame (make-fake-stack-frame sp (%dnode-address-of lr-frame) pc-fn pc-lr vsp xp)))
173           (declare (dynamic-extent lr-frame pc-frame))
174           (funcall thunk (%dnode-address-of pc-frame))))
175        (t (funcall thunk (xp-gpr-lisp xp arm::sp)))))
176
177(defcallback xcmain (:address xp
178                              :signed-fullword signal
179                              :signed-fullword arg
180                              :signed-fullword fnreg
181                              :signed-fullword offset)
182  (with-xp-stack-frames (xp (unless (eql 0 fnreg) (xp-gpr-lisp xp fnreg)) frame-ptr)
183    (cond ((eql signal 0) (cmain))
184          ((or (eql signal #$SIGBUS)
185               (eql signal #$SIGSEGV))
186           (%error (make-condition 'invalid-memory-access
187                                   :address arg
188                                   :write-p (eql signal #$SIGBUS))
189                   ()
190                   frame-ptr))
191          (t
192           (error "cmain callback: signal = ~d, arg = #x~x, fnreg = ~d, offset = ~d"
193                  signal arg fnreg offset)))))
Note: See TracBrowser for help on using the repository browser.