source: branches/1.2/devel/source/level-1/x86-trap-support.lisp @ 8123

Last change on this file since 8123 was 7856, checked in by gb, 12 years ago

If the byte following a UUO is 0, update the xcf's relative PC from
the (32-bit) word preceding the current rpc (address of UUO. and
prepare to tell the kernel that we skipped -1 bytes (to indicate
that it should set the real PC based on the updated relative PC.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 9.6 KB
Line 
1;;; x86-trap-support
2;;;
3;;;   Copyright (C) 2005-2006 Clozure Associates and contributors
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL 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
18(in-package "CCL")
19
20;;; The order in which GPRs appear in an exception context generally
21;;; has nothing to do with how they're encoded in instructions/uuos,
22;;; and is OS-dependent.
23
24#+linuxx8664-target
25(progn
26  (defconstant gp-regs-offset (+ (get-field-offset :ucontext.uc_mcontext)
27                                 (get-field-offset :mcontext_t.gregs)))
28  (defmacro xp-gp-regs (xp) xp)
29  (defconstant flags-register-offset #$REG_EFL)
30  (defconstant rip-register-offset #$REG_RIP)
31  (defparameter *encoded-gpr-to-indexed-gpr*
32    #(13                                ;rax
33      14                                ;rcx
34      12                                ;rdx
35      11                                ;rbx
36      15                                ;rsp
37      10                                ;rbp
38      9                                 ;rsi
39      8                                 ;rdi
40      0                                 ;r8
41      1                                 ;r9
42      2                                 ;r10
43      3                                 ;r11
44      4                                 ;r12
45      5                                 ;r13
46      6                                 ;r14
47      7                                 ;r15
48      )))
49
50#+freebsdx8664-target
51(progn
52  (defconstant gp-regs-offset (get-field-offset :ucontext_t.uc_mcontext))
53  (defmacro xp-gp-regs (xp) xp)
54  (defconstant flags-register-offset 22)
55  (defconstant rip-register-offset 20)
56  (defparameter *encoded-gpr-to-indexed-gpr*
57    #(7                                 ;rax
58      4                                 ;rcx
59      3                                 ;rdx
60      8                                 ;rbx
61      23                                ;rsp
62      9                                 ;rbp
63      2                                 ;rsi
64      1                                 ;rdi
65      5                                 ;r8
66      6                                 ;r9
67      10                                ;r10
68      11                                ;r11
69      12                                ;r12
70      13                                ;r13
71      14                                ;r14
72      15                                ;r15
73      )))
74
75#+darwinx8664-target
76;;; Apple has decided that compliance with some Unix standard or other
77;;; requires gratuitously renaming ucontext/mcontext structures and
78;;; their components.  Do you feel more compliant now ?
79(progn
80  (eval-when (:compile-toplevel :execute)
81    (def-foreign-type nil
82        (:struct :portable_mcontext64
83                 (:es :x86_exception_state64_t)
84                 (:ss :x86_thread_state64_t)
85                 (:fs :x86_float_state64_t)))
86    (def-foreign-type nil
87        (:struct :portable_uc_stack
88                 (:ss_sp (:* :void))
89                 (:ss_size (:unsigned 64))
90                 (:ss_flags  (:signed 32))))
91    (def-foreign-type nil
92        (:struct :portable_ucontext64
93                 (:onstack (:signed 32))
94                 (:sigmask (:unsigned 32))
95                 (:stack (:struct :portable_uc_stack))
96                 (:link :address)
97                 (:uc_mcsize (:unsigned 64))
98                 (:uc_mcontext64 (:* (:struct :portable_mcontext64))))))
99  (defconstant gp-regs-offset 0)
100  (defmacro xp-gp-regs (xp)
101    `(pref (pref ,xp :portable_ucontext64.uc_mcontext64) :portable_mcontext64.ss))
102
103  (defconstant flags-register-offset 17)
104  (defconstant rip-register-offset 16) 
105  (defparameter *encoded-gpr-to-indexed-gpr*
106    #(0                                 ;rax
107      2                                 ;rcx
108      3                                 ;rdx
109      1                                 ;rbx
110      7                                 ;rsp
111      6                                 ;rbp
112      5                                 ;rsi
113      4                                 ;rdi
114      8                                 ;r8
115      9                                 ;r9
116      10                                ;r10
117      11                                ;r11
118      12                                ;r12
119      13                                ;r13
120      14                                ;r14
121      15                                ;r15
122      )))
123
124(defun indexed-gpr-lisp (xp igpr)
125  (%get-object (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8664::word-shift))))
126(defun (setf indexed-gpr-lisp) (new xp igpr)
127  (%set-object (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8664::word-shift)) new))
128(defun encoded-gpr-lisp (xp gpr)
129  (indexed-gpr-lisp xp (aref *encoded-gpr-to-indexed-gpr* gpr)))
130(defun (setf encoded-gpr-lisp) (new xp gpr)
131  (setf (indexed-gpr-lisp xp (aref *encoded-gpr-to-indexed-gpr* gpr)) new))
132(defun indexed-gpr-integer (xp igpr)
133  (%get-signed-long-long (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8664::word-shift))))
134(defun (setf indexed-gpr-integer) (new xp igpr)
135  (setf
136   (%get-signed-long-long (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8664::word-shift)))
137   new))
138(defun encoded-gpr-integer (xp gpr)
139  (indexed-gpr-integer xp (aref *encoded-gpr-to-indexed-gpr* gpr)))
140(defun (setf encoded-gpr-integer) (new xp gpr)
141  (setf (indexed-gpr-integer xp (aref *encoded-gpr-to-indexed-gpr* gpr)) new))
142(defun indexed-gpr-macptr (xp igpr)
143  (%get-ptr (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8664::word-shift))))
144(defun (setf indexed-gpr-macptr) (new xp igpr)
145  (setf (%get-ptr (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8664::word-shift))) new))
146(defun indexed-gpr-macptr (xp igpr)
147  (%get-ptr (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8664::word-shift))))
148(defun encoded-gpr-macptr (xp gpr)
149  (indexed-gpr-macptr xp (aref *encoded-gpr-to-indexed-gpr* gpr)))
150(defun (setf encoded-gpr-macptr) (new xp gpr)
151  (setf (indexed-gpr-macptr xp (aref *encoded-gpr-to-indexed-gpr* gpr)) new))
152(defun xp-flags-register (xp)
153  (%get-signed-long-long (xp-gp-regs xp) (+ gp-regs-offset (ash flags-register-offset x8664::fixnumshift))))
154 
155
156
157(defun %get-xcf-byte (xcf-ptr delta)
158  (let* ((containing-object (%get-object xcf-ptr x8664::xcf.containing-object))
159         (byte-offset (%get-object xcf-ptr x8664::xcf.relative-pc)))
160    (if containing-object
161      (locally (declare (optimize (speed 3) (safety 0))
162                        (type (simple-array (unsigned-byte 8) (*)) containing-object))
163        (aref containing-object (the fixnum (+ byte-offset delta))))
164      (%get-unsigned-byte (%int-to-ptr byte-offset) delta))))
165
166;;; If the byte following a uuo (which is "skip" bytes long, set
167;;; the xcf's relative PC to the value contained in the 32-bit
168;;; word preceding the current relative PC and return -1, else return skip.
169(defun %check-anchored-uuo (xcf skip)
170  (if (eql 0 (%get-xcf-byte xcf skip))
171    (let* ((new-rpc (+ target::tag-function
172                       (logior (ash (%get-xcf-byte xcf -1) 24)
173                               (ash (%get-xcf-byte xcf -2) 16)
174                               (ash (%get-xcf-byte xcf -3) 8)
175                               (%get-xcf-byte xcf -4)))))
176      (%set-object xcf x8664::xcf.relative-pc new-rpc)
177      -1)
178    skip))
179                           
180                                 
181(defun decode-arithmetic-error (xp xcf)
182  (declare (ignore xp xcf))
183  (values 'unknown nil))
184
185;;; UUOs are handled elsewhere.  This should handle all signals other than
186;;; those generated by UUOs (and the non-UUO cases of things like SIGSEGV.)
187;;; If the signal number is 0, other arguments (besides the exception context XP)
188;;; may not be meaningful.
189(defcallback xcmain (:address xp :address xcf :int signal :long code :long addr  :int)
190  (let* ((frame-ptr (macptr->fixnum xcf)))
191    (cond ((zerop signal)               ;thread interrupt
192           (cmain))
193          ((< signal 0)
194           (%err-disp-internal code () frame-ptr))
195          ((= signal #$SIGFPE)
196           (multiple-value-bind (operation operands)
197               (decode-arithmetic-error xp xcf)
198             (let* ((condition-name
199                     (cond ((or (= code #$FPE_INTDIV)
200                                (= code #$FPE_FLTDIV))
201                            'division-by-zero)
202                           ((= code #$FPE_FLTOVF)
203                            'floating-point-overflow)
204                           ((= code #$FPE_FLTUND)
205                            'floating-point-underflow)
206                           ((= code #$FPE_FLTRES)
207                            'floating-point-inexact)
208                           (t
209                            'floating-point-invalid-operation))))
210               (%error (make-condition condition-name
211                                       :operation operation
212                                       :operands operands)
213                       ()
214                       frame-ptr))))
215          ((= signal #$SIGSEGV)
216           ;; Stack overflow.
217           (let* ((on-tsp (not (eql 0 code))))
218             (unwind-protect
219                  (%error
220                   (make-condition
221                    'stack-overflow-condition 
222                    :format-control "Stack overflow on ~a stack."
223                    :format-arguments (list
224                                       (if on-tsp "temp" "value"))
225                    )
226                   nil frame-ptr)
227               (ff-call (%kernel-import target::kernel-import-restore-soft-stack-limit)
228                        :unsigned-fullword code
229                        :void))))
230          ((= signal #$SIGBUS)
231           (%error (make-condition 'invalid-memory-access
232                    :address addr
233                    :write-p (not (zerop code)))
234                   ()
235                   frame-ptr))))
236  0)
237
Note: See TracBrowser for help on using the repository browser.