source: trunk/source/level-1/x86-trap-support.lisp @ 12219

Last change on this file since 12219 was 11887, checked in by gb, 11 years ago

in (X)CMAIN callback:SIGBUS with code = -1 -> INVALID-MEMORY-OPERATION.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 16.5 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  (defun xp-mxcsr (xp)
32    (pref xp :ucontext.uc_mcontext.fpregs.mxcsr))
33  (defparameter *encoded-gpr-to-indexed-gpr*
34    #(13                                ;rax
35      14                                ;rcx
36      12                                ;rdx
37      11                                ;rbx
38      15                                ;rsp
39      10                                ;rbp
40      9                                 ;rsi
41      8                                 ;rdi
42      0                                 ;r8
43      1                                 ;r9
44      2                                 ;r10
45      3                                 ;r11
46      4                                 ;r12
47      5                                 ;r13
48      6                                 ;r14
49      7                                 ;r15
50      )))
51
52#+freebsdx8664-target
53(progn
54  (defconstant gp-regs-offset (get-field-offset :ucontext_t.uc_mcontext))
55  (defmacro xp-gp-regs (xp) xp)
56  (defconstant flags-register-offset 22)
57  (defconstant rip-register-offset 20)
58  (defun xp-mxcsr (xp)
59    (with-macptrs ((state (pref xp :__ucontext.uc_mcontext.mc_fpstate)))
60      (pref state :savefpu.sv_env.en_mxcsr)))
61  (defparameter *encoded-gpr-to-indexed-gpr*
62    #(7                                 ;rax
63      4                                 ;rcx
64      3                                 ;rdx
65      8                                 ;rbx
66      23                                ;rsp
67      9                                 ;rbp
68      2                                 ;rsi
69      1                                 ;rdi
70      5                                 ;r8
71      6                                 ;r9
72      10                                ;r10
73      11                                ;r11
74      12                                ;r12
75      13                                ;r13
76      14                                ;r14
77      15                                ;r15
78      )))
79
80#+darwinx8664-target
81;;; Apple has decided that compliance with some Unix standard or other
82;;; requires gratuitously renaming ucontext/mcontext structures and
83;;; their components.  Do you feel more compliant now ?
84(progn
85  (eval-when (:compile-toplevel :execute)
86    (def-foreign-type nil
87        (:struct :portable_mcontext64
88                 (:es :x86_exception_state64_t)
89                 (:ss :x86_thread_state64_t)
90                 (:fs :x86_float_state64_t)))
91    (def-foreign-type nil
92        (:struct :portable_uc_stack
93                 (:ss_sp (:* :void))
94                 (:ss_size (:unsigned 64))
95                 (:ss_flags  (:signed 32))))
96    (def-foreign-type nil
97        (:struct :portable_ucontext64
98                 (:onstack (:signed 32))
99                 (:sigmask (:unsigned 32))
100                 (:stack (:struct :portable_uc_stack))
101                 (:link :address)
102                 (:uc_mcsize (:unsigned 64))
103                 (:uc_mcontext64 (:* (:struct :portable_mcontext64))))))
104  (defun xp-mxcsr (xp)
105    (%get-unsigned-long
106     (pref (pref xp :portable_ucontext64.uc_mcontext64) :portable_mcontext64.fs) 32))
107  (defconstant gp-regs-offset 0)
108  (defmacro xp-gp-regs (xp)
109    `(pref (pref ,xp :portable_ucontext64.uc_mcontext64) :portable_mcontext64.ss))
110
111  (defconstant flags-register-offset 17)
112  (defconstant rip-register-offset 16) 
113  (defparameter *encoded-gpr-to-indexed-gpr*
114    #(0                                 ;rax
115      2                                 ;rcx
116      3                                 ;rdx
117      1                                 ;rbx
118      7                                 ;rsp
119      6                                 ;rbp
120      5                                 ;rsi
121      4                                 ;rdi
122      8                                 ;r8
123      9                                 ;r9
124      10                                ;r10
125      11                                ;r11
126      12                                ;r12
127      13                                ;r13
128      14                                ;r14
129      15                                ;r15
130      )))
131
132#+solarisx8664-target
133(progn
134  (defconstant gp-regs-offset (+ (get-field-offset :ucontext.uc_mcontext)
135                                 (get-field-offset :mcontext_t.gregs)))
136  (defmacro xp-gp-regs (xp) xp)
137  (defconstant flags-register-offset #$REG_RFL)
138  (defconstant rip-register-offset #$REG_RIP)
139  (defun xp-mxcsr (xp)
140    (pref xp :ucontext.uc_mcontext.fpregs.fp_reg_set.fpchip_state.mxcsr))
141  (defparameter *encoded-gpr-to-indexed-gpr*
142    #(14                                ;rax
143      13                                ;rcx
144      12                                ;rdx
145      11                                ;rbx
146      20                                ;rsp
147      10                                ;rbp
148      9                                 ;rsi
149      8                                 ;rdi
150      7                                 ;r8
151      6                                 ;r9
152      5                                 ;r10
153      4                                 ;r11
154      3                                 ;r12
155      2                                 ;r13
156      1                                 ;r14
157      0                                 ;r15
158      )))
159
160#+win64-target
161(progn
162  (defconstant gp-regs-offset (get-field-offset #>CONTEXT.Rax))
163  (defmacro xp-gp-regs (xp) xp)
164  (defconstant rip-register-offset 16)
165  (defun xp-mxcsr (xp)
166    (pref xp #>CONTEXT.MxCsr))
167  (defparameter *encoded-gpr-to-indexed-gpr*
168    #(0                                 ;rax
169      1                                 ;rcx
170      2                                 ;rdx
171      3                                 ;rbx
172      4                                 ;rsp
173      5                                 ;rbp
174      6                                 ;rsi
175      7                                 ;rdi
176      8                                 ;r8
177      9                                 ;r9
178      10                                ;r10
179      11                                ;r11
180      12                                ;r12
181      13                                ;r13
182      14                                ;r14
183      15                                ;r15
184      )))
185
186#+darwinx8632-target
187(progn
188  (defconstant gp-regs-offset 0)
189  (defmacro xp-gp-regs (xp)
190    `(pref (pref ,xp :ucontext.uc_mcontext) :mcontext.ss))
191  (defun xp-mxcsr (xp)
192    (%get-unsigned-long (pref (pref xp :ucontext.uc_mcontext) :mcontext.fs) 32))
193  (defconstant flags-register-offset 9)
194  (defconstant eip-register-offset 10)
195  (defparameter *encoded-gpr-to-indexed-gpr*
196    #(0                                 ;eax
197      2                                 ;ecx
198      3                                 ;edx
199      1                                 ;ebx
200      7                                 ;esp
201      6                                 ;ebp
202      5                                 ;esi
203      4                                 ;edi
204      )))
205
206#+linuxx8632-target
207(progn
208  (defconstant gp-regs-offset 0)
209  (defmacro xp-gp-regs (xp)
210    `(pref (pref ,xp :ucontext.uc_mcontext) :mcontext_t.gregs))
211  (defun xp-mxcsr (xp)
212    (pref (pref (pref xp :ucontext.uc_mcontext) :mcontext_t.fpregs)
213          :_fpstate.mxcsr))
214  (defconstant flags-register-offset #$REG_EFL)
215  (defconstant eip-register-offset #$REG_EIP)
216  (defparameter *encoded-gpr-to-indexed-gpr*
217    (vector
218     #$REG_EAX                         ;eax
219      #$REG_ECX                         ;ecx
220      #$REG_EDX                         ;edx
221      #$REG_EBX                         ;ebx
222      #$REG_ESP                         ;esp
223      #$REG_EBP                         ;ebp
224      #$REG_ESI                         ;esi
225      #$REG_EDI                         ;edi
226      )))
227
228#+win32-target
229(progn
230  (defconstant gp-regs-offset 0)
231  (defmacro xp-gp-regs (xp)
232    `,xp)
233  (defun xp-mxcsr (xp)
234    (%get-unsigned-long (pref xp #>CONTEXT.ExtendedRegisters) 24))
235  (defconstant flags-register-offset 48)
236  (defconstant eip-register-offset 45)
237  (defparameter *encoded-gpr-to-indexed-gpr*
238    #(
239     44                                ;eax
240     43                                ;ecx
241     42                                ;edx
242     41                                ;ebx
243     49                                ;esp
244     45                                ;ebp
245     40                                ;esi
246     39                                ;edi
247      )))
248
249#+solarisx8632-target
250(progn
251  (defconstant gp-regs-offset 0)
252  (defmacro xp-gp-regs (xp)
253    `(pref (pref ,xp :ucontext.uc_mcontext) :mcontext_t.gregs))
254  (defun xp-mxcsr (xp)
255    (pref xp :ucontext.uc_mcontext.fpregs.fp_reg_set.fpchip_state.mxcsr))
256  (defconstant flags-register-offset #$EFL)
257  (defconstant eip-register-offset #$EIP)
258  (defparameter *encoded-gpr-to-indexed-gpr*
259    (vector
260     #$EAX
261     #$ECX
262     #$EDX
263     #$EBX
264     #$ESP
265     #$EBP
266     #$ESI
267     #$EDI)
268      ))
269
270#+freebsdx8632-target
271(progn
272  (defconstant gp-regs-offset 0)
273  (defmacro xp-gp-regs (xp)
274    `(pref ,xp :ucontext_t.uc_mcontext))
275  (defun xp-mxcsr (xp)
276    (pref (pref xp :ucontext_t.uc_mcontext.mc_fpstate) :savexmm.sv_env.en_mxcsr)
277)
278  (defconstant flags-register-offset 17)
279  (defconstant eip-register-offset 15)
280  (defparameter *encoded-gpr-to-indexed-gpr*
281    #(
282      12                                ;eax
283      11                                ;ecx
284      10                                ;edx
285      9                                 ;ebx
286      18                                ;esp
287      7                                 ;ebp
288      6                                 ;esi
289      5                                 ;edi
290      )
291      ))
292
293(defun indexed-gpr-lisp (xp igpr)
294  (%get-object (xp-gp-regs xp) (+ gp-regs-offset (ash igpr target::word-shift))))
295(defun (setf indexed-gpr-lisp) (new xp igpr)
296  (%set-object (xp-gp-regs xp) (+ gp-regs-offset (ash igpr target::word-shift)) new))
297(defun encoded-gpr-lisp (xp gpr)
298  (indexed-gpr-lisp xp (aref *encoded-gpr-to-indexed-gpr* gpr)))
299(defun (setf encoded-gpr-lisp) (new xp gpr)
300  (setf (indexed-gpr-lisp xp (aref *encoded-gpr-to-indexed-gpr* gpr)) new))
301(defun indexed-gpr-integer (xp igpr)
302  #+x8664-target
303  (%get-signed-long-long (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8664::word-shift)))
304  #+x8632-target
305  (%get-signed-long (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8632::word-shift))))
306(defun (setf indexed-gpr-integer) (new xp igpr)
307  (setf
308   #+x8664-target
309   (%get-signed-long-long (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8664::word-shift)))
310   #+x8632-target
311   (%get-signed-long (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8632::word-shift)))
312   new))
313(defun encoded-gpr-integer (xp gpr)
314  (indexed-gpr-integer xp (aref *encoded-gpr-to-indexed-gpr* gpr)))
315(defun (setf encoded-gpr-integer) (new xp gpr)
316  (setf (indexed-gpr-integer xp (aref *encoded-gpr-to-indexed-gpr* gpr)) new))
317(defun indexed-gpr-macptr (xp igpr)
318  (%get-ptr (xp-gp-regs xp) (+ gp-regs-offset (ash igpr target::word-shift))))
319(defun (setf indexed-gpr-macptr) (new xp igpr)
320  (setf (%get-ptr (xp-gp-regs xp) (+ gp-regs-offset (ash igpr target::word-shift))) new))
321(defun encoded-gpr-macptr (xp gpr)
322  (indexed-gpr-macptr xp (aref *encoded-gpr-to-indexed-gpr* gpr)))
323(defun (setf encoded-gpr-macptr) (new xp gpr)
324  (setf (indexed-gpr-macptr xp (aref *encoded-gpr-to-indexed-gpr* gpr)) new))
325(defun xp-flags-register (xp)
326  #+windows-target (pref xp #>CONTEXT.EFlags)
327  #-windows-target
328  (progn
329  #+x8664-target
330  (%get-signed-long-long (xp-gp-regs xp) (+ gp-regs-offset (ash flags-register-offset x8664::fixnumshift)))
331  #+x8632-target
332  (%get-signed-long (xp-gp-regs xp) (+ gp-regs-offset (ash flags-register-offset x8632::fixnumshift)))))
333 
334
335
336(defun %get-xcf-byte (xcf-ptr delta)
337  (let* ((containing-object (%get-object xcf-ptr target::xcf.containing-object))
338         (byte-offset (%get-object xcf-ptr target::xcf.relative-pc)))
339    (if containing-object
340      (locally (declare (optimize (speed 3) (safety 0))
341                        (type (simple-array (unsigned-byte 8) (*)) containing-object))
342        (aref containing-object (the fixnum (+ byte-offset delta))))
343      (%get-unsigned-byte (%int-to-ptr byte-offset) delta))))
344
345;;; If the byte following a uuo (which is "skip" bytes long, set
346;;; the xcf's relative PC to the value contained in the 32-bit
347;;; word preceding the current relative PC and return -1, else return skip.
348(defun %check-anchored-uuo (xcf skip)
349  (if (eql 0 (%get-xcf-byte xcf skip))
350    (let* ((new-rpc (+ #+x8664-target target::tag-function
351                       #+x8632-target target::fulltag-misc
352                       (logior (ash (%get-xcf-byte xcf -1) 24)
353                               (ash (%get-xcf-byte xcf -2) 16)
354                               (ash (%get-xcf-byte xcf -3) 8)
355                               (%get-xcf-byte xcf -4)))))
356      (%set-object xcf target::xcf.relative-pc new-rpc)
357      -1)
358    skip))
359                           
360                                 
361(defun decode-arithmetic-error (xp xcf)
362  (declare (ignore xp xcf))
363  (values 'unknown nil))
364
365(eval-when (:compile-toplevel :execute)
366  (progn
367    (defun conditional-os-constant (alternatives)
368      (dolist (c alternatives (error "None of the constants in ~s could be loaded" alternatives))
369        (if (load-os-constant c t)
370          (return (load-os-constant c)))))
371
372    (defconstant integer-divide-by-zero-code
373      (conditional-os-constant '(os::EXCEPTION_INT_DIVIDE_BY_ZERO os::FPE_INTDIV))
374)
375    (defconstant float-divide-by-zero-code
376      (conditional-os-constant '(os::EXCEPTION_FLT_DIVIDE_BY_ZERO os::FPE_FLTDIV)))
377    (defconstant float-overflow-code
378      (conditional-os-constant '(os::FPE_FLTOVF os::EXCEPTION_FLT_OVERFLOW)))
379    (defconstant float-underflow-code
380      (conditional-os-constant '(os::FPE_FLTUND os::EXCEPTION_FLT_UNDERFLOW)))
381    (defconstant float-inexact-code
382      (conditional-os-constant '(os::FPE_FLTRES os::EXCEPTION_FLT_INEXACT_RESULT)))))
383
384;;; UUOs are handled elsewhere.  This should handle all signals other than
385;;; those generated by UUOs (and the non-UUO cases of things like SIGSEGV.)
386;;; If the signal number is 0, other arguments (besides the exception context XP)
387;;; may not be meaningful.
388(defcallback xcmain (:address xp :address xcf :int signal :long code :long addr  :int)
389  (let* ((frame-ptr (macptr->fixnum xcf)))
390    (cond ((zerop signal)               ;thread interrupt
391           (cmain))
392          ((< signal 0)
393           (%err-disp-internal code () frame-ptr))
394          ((= signal #$SIGFPE)
395           (setq code (logand #xffffffff code))
396           (multiple-value-bind (operation operands)
397               (decode-arithmetic-error xp xcf)
398             (let* ((condition-name
399                     (cond ((or (= code integer-divide-by-zero-code)
400                                (= code float-divide-by-zero-code))
401                            'division-by-zero)
402                           ((= code float-overflow-code)
403                            'floating-point-overflow)
404                           ((= code float-underflow-code)
405                            'floating-point-underflow)
406                           ((= code float-inexact-code)
407                            'floating-point-inexact)
408                           (t
409                            'floating-point-invalid-operation))))
410               (%error (make-condition condition-name
411                                       :operation operation
412                                       :operands operands
413                                       :status (xp-mxcsr xp))
414                       ()
415                       frame-ptr))))
416          ((= signal #$SIGSEGV)
417           ;; Stack overflow.
418           (let* ((on-tsp (not (eql 0 code))))
419             (unwind-protect
420                  (%error
421                   (make-condition
422                    'stack-overflow-condition 
423                    :format-control "Stack overflow on ~a stack."
424                    :format-arguments (list
425                                       (if on-tsp "temp" "value"))
426                    )
427                   nil frame-ptr)
428               (ff-call (%kernel-import target::kernel-import-restore-soft-stack-limit)
429                        :unsigned-fullword code
430                        :void))))
431          ((= signal #+win32-target 10 #-win32-target #$SIGBUS)
432           (if (= code -1)
433             (%error (make-condition 'invalid-memory-operation)
434                     ()
435                     frame-ptr)
436             (%error (make-condition 'invalid-memory-access
437                                     :address addr
438                                     :write-p (not (zerop code)))
439                     ()
440                     frame-ptr)))))
441  0)
442
Note: See TracBrowser for help on using the repository browser.