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

Last change on this file since 12817 was 12817, checked in by rme, 10 years ago

The xcmain callback actually accepts an additional arg. Use it to pass both
the faulting address and the lisp object when handling a write to a watched
object.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 16.7 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 :long other :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           (cond
418             ((or (= code 0) (= code 1))
419              ;; Stack overflow.
420              (let* ((on-tsp (= code 1)))
421                (unwind-protect
422                     (%error
423                      (make-condition
424                       'stack-overflow-condition 
425                       :format-control "Stack overflow on ~a stack."
426                       :format-arguments (list (if on-tsp "temp" "value")))
427                      nil frame-ptr)
428                  (ff-call (%kernel-import target::kernel-import-restore-soft-stack-limit)
429                           :unsigned-fullword code
430                           :void))))
431             ((= code 2)
432              ;; Write to a watched object.
433              (flet ((%int-to-object (i)
434                       (rlet ((a :address))
435                         (setf (%get-ptr a) (%int-to-ptr i))
436                         (%get-object a 0))))
437                (%error (make-condition
438                         'write-to-watched-object
439                         :address addr
440                         :object (%int-to-object other))
441                        nil frame-ptr)))))
442          ((= signal #+win32-target 10 #-win32-target #$SIGBUS)
443           (if (= code -1)
444             (%error (make-condition 'invalid-memory-operation)
445                     ()
446                     frame-ptr)
447             (%error (make-condition 'invalid-memory-access
448                                     :address addr
449                                     :write-p (not (zerop code)))
450                     ()
451                     frame-ptr)))))
452  0)
453
Note: See TracBrowser for help on using the repository browser.