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

Last change on this file was 16685, checked in by rme, 4 years ago

Update copyright/license headers in files.

File size: 8.2 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;; Copyright 2010 Clozure Associates
4;;;
5;;; Licensed under the Apache License, Version 2.0 (the "License");
6;;; you may not use this file except in compliance with the License.
7;;; You may obtain a copy of the License at
8;;;
9;;;     http://www.apache.org/licenses/LICENSE-2.0
10;;;
11;;; Unless required by applicable law or agreed to in writing, software
12;;; distributed under the License is distributed on an "AS IS" BASIS,
13;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
14;;; See the License for the specific language governing permissions and
15;;; limitations under the License.
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-unsigned-long (xp register-number)
116  (with-xp-registers-and-gpr-offset (xp register-number) (registers offset)
117    (values (%get-signed-long registers offset))))
118
119(defun xp-gpr-signed-doubleword (xp register-number)
120  (with-xp-registers-and-gpr-offset (xp register-number) (registers offset)
121    (values (%%get-signed-longlong registers offset))))
122 
123
124(defun xp-gpr-macptr (xp register-number)
125  (with-xp-registers-and-gpr-offset (xp register-number) (registers offset)
126    (values (%get-ptr registers offset))))
127
128(defun return-address-offset (xp fn machine-state-offset)
129  (with-macptrs ((regs (pref xp #+linuxarm-target :ucontext.uc_mcontext
130                                #+darwinarm-target :ucontext_t.uc_mcontext.__ss)))
131    (if (functionp fn)
132      (or (%code-vector-pc (uvref fn 1) (%inc-ptr regs machine-state-offset))
133           (%get-ptr regs machine-state-offset))
134      (%get-ptr regs machine-state-offset))))
135
136(defconstant lr-offset-in-register-context
137  #+linuxarm-target (get-field-offset :sigcontext.arm_lr)
138  #+darwinarm-target (get-field-offset :__darwin_arm_thread_state.__lr))
139
140(defconstant pc-offset-in-register-context
141  #+linuxarm-target (get-field-offset :sigcontext.arm_pc)
142  #+darwinarm-target (get-field-offset :__darwin_arm_thread_state.__pc))
143
144(defun funcall-with-xp-stack-frames (xp trap-function thunk)
145  (cond ((null trap-function)
146         ; Maybe inside a subprim from a lisp function
147         (let* ((fn (xp-gpr-lisp xp arm::fn))
148                (lr (return-address-offset
149                     xp fn lr-offset-in-register-context)))
150           (if (fixnump lr)
151             (let* ((sp (xp-gpr-lisp xp arm::sp))
152                    (vsp (xp-gpr-lisp xp arm::vsp))
153                    (frame (make-fake-stack-frame sp sp fn lr vsp xp)))
154               (declare (dynamic-extent frame))
155               (funcall thunk (%dnode-address-of frame)))
156             (funcall thunk (xp-gpr-lisp xp arm::sp)))))
157        ((eq trap-function (xp-gpr-lisp xp arm::fn))
158         (let* ((sp (xp-gpr-lisp xp arm::sp))
159                (fn trap-function)
160                (lr (return-address-offset
161                     xp fn pc-offset-in-register-context))
162                (vsp (xp-gpr-lisp xp arm::vsp))
163                (frame (make-fake-stack-frame sp sp fn lr vsp xp)))
164           (declare (dynamic-extent frame))
165           (funcall thunk (%dnode-address-of frame))))
166        ((eq trap-function (xp-gpr-lisp xp arm::nfn))
167         (let* ((sp (xp-gpr-lisp xp arm::sp))
168                (fn (xp-gpr-lisp xp arm::fn))
169                (lr (return-address-offset
170                     xp fn lr-offset-in-register-context))
171                (vsp (xp-gpr-lisp xp arm::vsp))
172                (lr-frame (make-fake-stack-frame sp sp fn lr vsp xp))
173                (pc-fn trap-function)
174                (pc-lr (return-address-offset
175                        xp pc-fn pc-offset-in-register-context))
176                (pc-frame (make-fake-stack-frame sp (%dnode-address-of lr-frame) pc-fn pc-lr vsp xp)))
177           (declare (dynamic-extent lr-frame pc-frame))
178           (funcall thunk (%dnode-address-of pc-frame))))
179        (t (funcall thunk (xp-gpr-lisp xp arm::sp)))))
180
181(defparameter *pending-gc-notification-hook* nil)
182
183(defcallback xcmain (:address xp
184                              :signed-fullword signal
185                              :signed-fullword arg
186                              :signed-fullword fnreg
187                              :signed-fullword offset)
188  (with-xp-stack-frames (xp (unless (eql 0 fnreg) (xp-gpr-lisp xp fnreg)) frame-ptr)
189    (cond ((eql signal 0) (cmain))
190          ((or (eql signal #$SIGBUS)
191               (eql signal #$SIGSEGV))
192           (%error (make-condition 'invalid-memory-access
193                                   :address arg
194                                   :write-p (eql signal #$SIGBUS))
195                   ()
196                   frame-ptr))
197          ((eql signal #$SIGTRAP)
198           (let* ((hook *pending-gc-notification-hook*))
199               (declare (special *pending-gc-notification-hook*))
200               (when hook (funcall hook))))
201          (t
202           (error "cmain callback: signal = ~d, arg = #x~x, fnreg = ~d, offset = ~d"
203                  signal arg fnreg offset)))))
Note: See TracBrowser for help on using the repository browser.