source: release/1.6/source/level-1/arm-trap-support.lisp @ 14712

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

Darwin/ARM abi changes (signal context accessors.)

File size: 6.2 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#+linuxarm-target
20(progn
21(defmacro with-xp-registers-and-gpr-offset ((xp register-number)
22                                            (registers offset) &body body)
23  (let* ((regform `(pref ,xp :ucontext.uc_mcontext)))
24    `(with-macptrs ((,registers ,regform))
25      (let ((,offset (xp-gpr-offset ,register-number)))
26        ,@body))))
27(defun xp-gpr-offset (register-number)
28  (unless (and (fixnump register-number)
29               (<= -3 (the fixnum register-number))
30               (< (the fixnum register-number) 18))
31    (setq register-number (require-type register-number '(integer -3 (18)))))
32  (the fixnum (* (the fixnum (+ register-number 3)) arm::node-size)))
33(defconstant xp-cpsr-regno 16)
34)
35
36#+darwinarm-target
37(progn
38(defmacro with-xp-registers-and-gpr-offset ((xp register-number)
39                                            (registers offset) &body body)
40  (let* ((regform `(pref ,xp :ucontext_t.uc_mcontext.__ss)))
41    `(with-macptrs ((,registers ,regform))
42      (let ((,offset (xp-gpr-offset ,register-number)))
43        ,@body))))
44(defun xp-gpr-offset (register-number)
45  (unless (and (fixnump register-number)
46               (<= 0 (the fixnum register-number))
47               (< (the fixnum register-number) 17))
48    (setq register-number (require-type register-number '(integer 0 (17)))))
49  (the fixnum (* (the fixnum register-number) arm::node-size)))
50(defconstant xp-cpsr-regno 16)
51)
52
53(defun xp-gpr-lisp (xp register-number)
54  (with-xp-registers-and-gpr-offset (xp register-number) (registers offset)
55    (values (%get-object registers offset))))
56
57(defun (setf xp-gpr-lisp) (value xp register-number)
58  (with-xp-registers-and-gpr-offset (xp register-number) (registers offset)
59    (%set-object registers offset value)))
60
61(defun xp-gpr-signed-long (xp register-number)
62  (with-xp-registers-and-gpr-offset (xp register-number) (registers offset)
63    (values (%get-signed-long registers offset))))
64
65(defun xp-gpr-signed-doubleword (xp register-number)
66  (with-xp-registers-and-gpr-offset (xp register-number) (registers offset)
67    (values (%%get-signed-longlong registers offset))))
68 
69
70(defun xp-gpr-macptr (xp register-number)
71  (with-xp-registers-and-gpr-offset (xp register-number) (registers offset)
72    (values (%get-ptr registers offset))))
73
74(defun return-address-offset (xp fn machine-state-offset)
75  (with-macptrs ((regs (pref xp #+linuxarm-target :ucontext.uc_mcontext
76                                #+darwinarm-target :ucontext_t.uc_mcontext.__ss)))
77    (if (functionp fn)
78      (or (%code-vector-pc (uvref fn 0) (%inc-ptr regs machine-state-offset))
79           (%get-ptr regs machine-state-offset))
80      (%get-ptr regs machine-state-offset))))
81
82(defconstant lr-offset-in-register-context
83  #+linuxarm-target (get-field-offset :sigcontext.arm_lr)
84  #+darwinarm-target (get-field-offset :__darwin_arm_thread_state.__lr))
85
86(defconstant pc-offset-in-register-context
87  #+linuxarm-target (get-field-offset :sigcontext.arm_pc)
88  #+darwinarm-target (get-field-offset :__darwin_arm_thread_state.__pc))
89
90(defun funcall-with-xp-stack-frames (xp trap-function thunk)
91  (cond ((null trap-function)
92         ; Maybe inside a subprim from a lisp function
93         (let* ((fn (xp-gpr-lisp xp arm::fn))
94                (lr (return-address-offset
95                     xp fn lr-offset-in-register-context)))
96           (if (fixnump lr)
97             (let* ((sp (xp-gpr-lisp xp arm::sp))
98                    (vsp (xp-gpr-lisp xp arm::vsp))
99                    (frame (make-fake-stack-frame sp sp fn lr vsp xp)))
100               (declare (dynamic-extent frame))
101               (funcall thunk (%dnode-address-of frame)))
102             (funcall thunk (xp-gpr-lisp xp arm::sp)))))
103        ((eq trap-function (xp-gpr-lisp xp arm::fn))
104         (let* ((sp (xp-gpr-lisp xp arm::sp))
105                (fn trap-function)
106                (lr (return-address-offset
107                     xp fn pc-offset-in-register-context))
108                (vsp (xp-gpr-lisp xp arm::vsp))
109                (frame (make-fake-stack-frame sp sp fn lr vsp xp)))
110           (declare (dynamic-extent frame))
111           (funcall thunk (%dnode-address-of frame))))
112        ((eq trap-function (xp-gpr-lisp xp arm::nfn))
113         (let* ((sp (xp-gpr-lisp xp arm::sp))
114                (fn (xp-gpr-lisp xp arm::fn))
115                (lr (return-address-offset
116                     xp fn lr-offset-in-register-context))
117                (vsp (xp-gpr-lisp xp arm::vsp))
118                (lr-frame (make-fake-stack-frame sp sp fn lr vsp xp))
119                (pc-fn trap-function)
120                (pc-lr (return-address-offset
121                        xp pc-fn pc-offset-in-register-context))
122                (pc-frame (make-fake-stack-frame sp (%dnode-address-of lr-frame) pc-fn pc-lr vsp xp)))
123           (declare (dynamic-extent lr-frame pc-frame))
124           (funcall thunk (%dnode-address-of pc-frame))))
125        (t (funcall thunk (xp-gpr-lisp xp arm::sp)))))
126
127(defcallback xcmain (:address xp
128                              :signed-fullword signal
129                              :signed-fullword arg
130                              :signed-fullword fnreg
131                              :signed-fullword offset)
132  (with-xp-stack-frames (xp (unless (eql 0 fnreg) (xp-gpr-lisp xp fnreg)) frame-ptr)
133    (cond ((eql signal 0) (cmain))
134          ((or (eql signal #$SIGBUS)
135               (eql signal #$SIGSEGV))
136           (%error (make-condition 'invalid-memory-access
137                                   :address arg
138                                   :write-p (eql signal #$SIGBUS))
139                   ()
140                   frame-ptr))
141          (t
142           (error "cmain callback: signal = ~d, arg = #x~x, fnreg = ~d, offset = ~d"
143                  signal arg fnreg offset)))))
Note: See TracBrowser for help on using the repository browser.