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

Last change on this file since 14376 was 13896, checked in by gb, 9 years ago

SIGTRAP isn't defined on Win32.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 18.0 KB
Line 
1;;; x86-trap-support
2;;;
3;;;   Copyright (C) 2005-2009 Clozure Associates and contributors
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
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(progn
82  (defconstant gp-regs-offset 0)
83  (defun xp-mxcsr (xp)
84     (pref xp :ucontext_t.uc_mcontext.__fs.__fpu_mxcsr))
85  (defmacro xp-gp-regs (xp)
86    `(pref ,xp :ucontext_t.uc_mcontext.__ss))
87
88  (defconstant flags-register-offset 17)
89  (defconstant rip-register-offset 16) 
90  (defparameter *encoded-gpr-to-indexed-gpr*
91    #(0                                 ;rax
92      2                                 ;rcx
93      3                                 ;rdx
94      1                                 ;rbx
95      7                                 ;rsp
96      6                                 ;rbp
97      5                                 ;rsi
98      4                                 ;rdi
99      8                                 ;r8
100      9                                 ;r9
101      10                                ;r10
102      11                                ;r11
103      12                                ;r12
104      13                                ;r13
105      14                                ;r14
106      15                                ;r15
107      )))
108
109#+solarisx8664-target
110(progn
111  (defconstant gp-regs-offset (+ (get-field-offset :ucontext.uc_mcontext)
112                                 (get-field-offset :mcontext_t.gregs)))
113  (defmacro xp-gp-regs (xp) xp)
114  (defconstant flags-register-offset #$REG_RFL)
115  (defconstant rip-register-offset #$REG_RIP)
116  (defun xp-mxcsr (xp)
117    (pref xp :ucontext.uc_mcontext.fpregs.fp_reg_set.fpchip_state.mxcsr))
118  (defparameter *encoded-gpr-to-indexed-gpr*
119    #(14                                ;rax
120      13                                ;rcx
121      12                                ;rdx
122      11                                ;rbx
123      20                                ;rsp
124      10                                ;rbp
125      9                                 ;rsi
126      8                                 ;rdi
127      7                                 ;r8
128      6                                 ;r9
129      5                                 ;r10
130      4                                 ;r11
131      3                                 ;r12
132      2                                 ;r13
133      1                                 ;r14
134      0                                 ;r15
135      )))
136
137#+win64-target
138(progn
139  (defconstant gp-regs-offset (get-field-offset #>CONTEXT.Rax))
140  (defmacro xp-gp-regs (xp) xp)
141  (defconstant rip-register-offset 16)
142  (defun xp-mxcsr (xp)
143    (pref xp #>CONTEXT.MxCsr))
144  (defparameter *encoded-gpr-to-indexed-gpr*
145    #(0                                 ;rax
146      1                                 ;rcx
147      2                                 ;rdx
148      3                                 ;rbx
149      4                                 ;rsp
150      5                                 ;rbp
151      6                                 ;rsi
152      7                                 ;rdi
153      8                                 ;r8
154      9                                 ;r9
155      10                                ;r10
156      11                                ;r11
157      12                                ;r12
158      13                                ;r13
159      14                                ;r14
160      15                                ;r15
161      )))
162
163#+darwinx8632-target
164(progn
165  (defconstant gp-regs-offset 0)
166  (defmacro xp-gp-regs (xp)
167    `(pref ,xp :ucontext_t.uc_mcontext.__ss))
168  (defun xp-mxcsr (xp)
169    (pref xp :ucontext_t.uc_mcontext.__fs.__fpu_mxcsr))
170  (defconstant flags-register-offset 9)
171  (defconstant eip-register-offset 10)
172  (defparameter *encoded-gpr-to-indexed-gpr*
173    #(0                                 ;eax
174      2                                 ;ecx
175      3                                 ;edx
176      1                                 ;ebx
177      7                                 ;esp
178      6                                 ;ebp
179      5                                 ;esi
180      4                                 ;edi
181      )))
182
183#+linuxx8632-target
184(progn
185  (defconstant gp-regs-offset 0)
186  (defmacro xp-gp-regs (xp)
187    `(pref (pref ,xp :ucontext.uc_mcontext) :mcontext_t.gregs))
188  (defun xp-mxcsr (xp)
189    (pref (pref (pref xp :ucontext.uc_mcontext) :mcontext_t.fpregs)
190          :_fpstate.mxcsr))
191  (defconstant flags-register-offset #$REG_EFL)
192  (defconstant eip-register-offset #$REG_EIP)
193  (defparameter *encoded-gpr-to-indexed-gpr*
194    (vector
195     #$REG_EAX                         ;eax
196      #$REG_ECX                         ;ecx
197      #$REG_EDX                         ;edx
198      #$REG_EBX                         ;ebx
199      #$REG_ESP                         ;esp
200      #$REG_EBP                         ;ebp
201      #$REG_ESI                         ;esi
202      #$REG_EDI                         ;edi
203      )))
204
205#+win32-target
206(progn
207  (defconstant gp-regs-offset 0)
208  (defmacro xp-gp-regs (xp)
209    `,xp)
210  (defun xp-mxcsr (xp)
211    (%get-unsigned-long (pref xp #>CONTEXT.ExtendedRegisters) 24))
212  (defconstant flags-register-offset 48)
213  (defconstant eip-register-offset 45)
214  (defparameter *encoded-gpr-to-indexed-gpr*
215    #(
216     44                                ;eax
217     43                                ;ecx
218     42                                ;edx
219     41                                ;ebx
220     49                                ;esp
221     45                                ;ebp
222     40                                ;esi
223     39                                ;edi
224      )))
225
226#+solarisx8632-target
227(progn
228  (defconstant gp-regs-offset 0)
229  (defmacro xp-gp-regs (xp)
230    `(pref (pref ,xp :ucontext.uc_mcontext) :mcontext_t.gregs))
231  (defun xp-mxcsr (xp)
232    (pref xp :ucontext.uc_mcontext.fpregs.fp_reg_set.fpchip_state.mxcsr))
233  (defconstant flags-register-offset #$EFL)
234  (defconstant eip-register-offset #$EIP)
235  (defparameter *encoded-gpr-to-indexed-gpr*
236    (vector
237     #$EAX
238     #$ECX
239     #$EDX
240     #$EBX
241     #$ESP
242     #$EBP
243     #$ESI
244     #$EDI)
245      ))
246
247#+freebsdx8632-target
248(progn
249  (defconstant gp-regs-offset 0)
250  (defmacro xp-gp-regs (xp)
251    `(pref ,xp :ucontext_t.uc_mcontext))
252  (defun xp-mxcsr (xp)
253    (pref (pref xp :ucontext_t.uc_mcontext.mc_fpstate) :savexmm.sv_env.en_mxcsr)
254)
255  (defconstant flags-register-offset 17)
256  (defconstant eip-register-offset 15)
257  (defparameter *encoded-gpr-to-indexed-gpr*
258    #(
259      12                                ;eax
260      11                                ;ecx
261      10                                ;edx
262      9                                 ;ebx
263      18                                ;esp
264      7                                 ;ebp
265      6                                 ;esi
266      5                                 ;edi
267      )
268      ))
269
270(defun indexed-gpr-lisp (xp igpr)
271  (%get-object (xp-gp-regs xp) (+ gp-regs-offset (ash igpr target::word-shift))))
272(defun (setf indexed-gpr-lisp) (new xp igpr)
273  (%set-object (xp-gp-regs xp) (+ gp-regs-offset (ash igpr target::word-shift)) new))
274(defun encoded-gpr-lisp (xp gpr)
275  (indexed-gpr-lisp xp (aref *encoded-gpr-to-indexed-gpr* gpr)))
276(defun (setf encoded-gpr-lisp) (new xp gpr)
277  (setf (indexed-gpr-lisp xp (aref *encoded-gpr-to-indexed-gpr* gpr)) new))
278(defun indexed-gpr-integer (xp igpr)
279  #+x8664-target
280  (%get-signed-long-long (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8664::word-shift)))
281  #+x8632-target
282  (%get-signed-long (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8632::word-shift))))
283(defun (setf indexed-gpr-integer) (new xp igpr)
284  (setf
285   #+x8664-target
286   (%get-signed-long-long (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8664::word-shift)))
287   #+x8632-target
288   (%get-signed-long (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8632::word-shift)))
289   new))
290(defun encoded-gpr-integer (xp gpr)
291  (indexed-gpr-integer xp (aref *encoded-gpr-to-indexed-gpr* gpr)))
292(defun (setf encoded-gpr-integer) (new xp gpr)
293  (setf (indexed-gpr-integer xp (aref *encoded-gpr-to-indexed-gpr* gpr)) new))
294(defun indexed-gpr-macptr (xp igpr)
295  (%get-ptr (xp-gp-regs xp) (+ gp-regs-offset (ash igpr target::word-shift))))
296(defun (setf indexed-gpr-macptr) (new xp igpr)
297  (setf (%get-ptr (xp-gp-regs xp) (+ gp-regs-offset (ash igpr target::word-shift))) new))
298(defun encoded-gpr-macptr (xp gpr)
299  (indexed-gpr-macptr xp (aref *encoded-gpr-to-indexed-gpr* gpr)))
300(defun (setf encoded-gpr-macptr) (new xp gpr)
301  (setf (indexed-gpr-macptr xp (aref *encoded-gpr-to-indexed-gpr* gpr)) new))
302(defun xp-flags-register (xp)
303  #+windows-target (pref xp #>CONTEXT.EFlags)
304  #-windows-target
305  (progn
306  #+x8664-target
307  (%get-signed-long-long (xp-gp-regs xp) (+ gp-regs-offset (ash flags-register-offset x8664::fixnumshift)))
308  #+x8632-target
309  (%get-signed-long (xp-gp-regs xp) (+ gp-regs-offset (ash flags-register-offset x8632::fixnumshift)))))
310 
311
312
313(defun %get-xcf-byte (xcf-ptr delta)
314  (let* ((containing-object (%get-object xcf-ptr target::xcf.containing-object))
315         (byte-offset (%get-object xcf-ptr target::xcf.relative-pc)))
316    (if containing-object
317      (locally (declare (optimize (speed 3) (safety 0))
318                        (type (simple-array (unsigned-byte 8) (*)) containing-object))
319        (aref containing-object (the fixnum (+ byte-offset delta))))
320      (%get-unsigned-byte (%int-to-ptr byte-offset) delta))))
321
322;;; If the byte following a uuo (which is "skip" bytes long, set
323;;; the xcf's relative PC to the value contained in the 32-bit
324;;; word preceding the current relative PC and return -1, else return skip.
325(defun %check-anchored-uuo (xcf skip)
326  (if (eql 0 (%get-xcf-byte xcf skip))
327    (let* ((new-rpc (+ #+x8664-target target::tag-function
328                       #+x8632-target target::fulltag-misc
329                       (logior (ash (%get-xcf-byte xcf -1) 24)
330                               (ash (%get-xcf-byte xcf -2) 16)
331                               (ash (%get-xcf-byte xcf -3) 8)
332                               (%get-xcf-byte xcf -4)))))
333      (%set-object xcf target::xcf.relative-pc new-rpc)
334      -1)
335    skip))
336                           
337                                 
338(defun decode-arithmetic-error (xp xcf)
339  (declare (ignore xp xcf))
340  (values 'unknown nil))
341
342(eval-when (:compile-toplevel :execute)
343  (progn
344    (defun conditional-os-constant (alternatives)
345      (dolist (c alternatives (error "None of the constants in ~s could be loaded" alternatives))
346        (if (load-os-constant c t)
347          (return (load-os-constant c)))))
348
349    (defconstant integer-divide-by-zero-code
350      (conditional-os-constant '(os::EXCEPTION_INT_DIVIDE_BY_ZERO os::FPE_INTDIV))
351)
352    (defconstant float-divide-by-zero-code
353      (conditional-os-constant '(os::EXCEPTION_FLT_DIVIDE_BY_ZERO os::FPE_FLTDIV)))
354    (defconstant float-overflow-code
355      (conditional-os-constant '(os::FPE_FLTOVF os::EXCEPTION_FLT_OVERFLOW)))
356    (defconstant float-underflow-code
357      (conditional-os-constant '(os::FPE_FLTUND os::EXCEPTION_FLT_UNDERFLOW)))
358    (defconstant float-inexact-code
359      (conditional-os-constant '(os::FPE_FLTRES os::EXCEPTION_FLT_INEXACT_RESULT)))))
360
361(defparameter *pending-gc-notification-hook* nil)
362
363;;; UUOs are handled elsewhere.  This should handle all signals other than
364;;; those generated by UUOs (and the non-UUO cases of things like SIGSEGV.)
365;;; If the signal number is 0, other arguments (besides the exception context XP)
366;;; may not be meaningful.
367(defcallback xcmain (:address xp :address xcf :int signal :long code :long addr :long other :int)
368  (let* ((frame-ptr (macptr->fixnum xcf))
369         (skip 0))
370    (cond ((zerop signal)               ;thread interrupt
371           (cmain))
372          ((< signal 0)
373           (%err-disp-internal code () frame-ptr))
374          ((= signal #$SIGFPE)
375           (setq code (logand #xffffffff code))
376           (multiple-value-bind (operation operands)
377               (decode-arithmetic-error xp xcf)
378             (let* ((condition-name
379                     (cond ((or (= code integer-divide-by-zero-code)
380                                (= code float-divide-by-zero-code))
381                            'division-by-zero)
382                           ((= code float-overflow-code)
383                            'floating-point-overflow)
384                           ((= code float-underflow-code)
385                            'floating-point-underflow)
386                           ((= code float-inexact-code)
387                            'floating-point-inexact)
388                           (t
389                            'floating-point-invalid-operation))))
390               (%error (make-condition condition-name
391                                       :operation operation
392                                       :operands operands
393                                       :status (xp-mxcsr xp))
394                       ()
395                       frame-ptr))))
396          ((= signal #$SIGSEGV)
397           (cond
398             ((or (= code 0) (= code 1))
399              ;; Stack overflow.
400              (let* ((on-tsp (= code 1)))
401                (unwind-protect
402                     (%error
403                      (make-condition
404                       'stack-overflow-condition 
405                       :format-control "Stack overflow on ~a stack."
406                       :format-arguments (list (if on-tsp "temp" "value")))
407                      nil frame-ptr)
408                  (ff-call (%kernel-import target::kernel-import-restore-soft-stack-limit)
409                           :unsigned-fullword code
410                           :void))))
411             ((= code 2)
412              ;; Write to a watched object.
413              (let* ((offset other)
414                     ;; The kernel exception handler leaves the
415                     ;; watched object on the lisp stack under the
416                     ;; xcf.
417                     (object (%get-object xcf target::xcf.size)))
418                (multiple-value-bind (insn insn-length)
419                    (ignore-errors (x86-faulting-instruction xp))
420                  (restart-case (%error (make-condition
421                                         'write-to-watched-object
422                                         :offset offset
423                                         :object object
424                                         :instruction insn)
425                                        nil frame-ptr)
426                    #-windows-target
427                    (emulate ()
428                      :test (lambda (c)
429                              (declare (ignore c))
430                              (x86-can-emulate-instruction insn))
431                      :report
432                      "Emulate this instruction, leaving the object watched."
433                      (flet ((watchedp (object)
434                               (%map-areas #'(lambda (x)
435                                               (when (eq object x)
436                                                 (return-from watchedp t)))
437                                           area-watched)))
438                        (let ((result nil))
439                          (with-other-threads-suspended
440                            (when (watchedp object)
441                              ;; We now trust that the object is in a
442                              ;; static gc area.
443                              (let* ((a (+ (%address-of object) offset))
444                                     (ptr (%int-to-ptr
445                                           (logandc2 a (1- *host-page-size*)))))
446                                (#_mprotect ptr *host-page-size* #$PROT_WRITE)
447                                (setq result (x86-emulate-instruction xp insn))
448                                (#_mprotect ptr *host-page-size*
449                                            (logior #$PROT_READ #$PROT_EXEC)))))
450                          (if result
451                            (setq skip insn-length)
452                            (error "could not emulate the instrution")))))
453                    (skip ()
454                      :test (lambda (c)
455                              (declare (ignore c))
456                              insn)
457                      :report "Skip over this write instruction."
458                      (setq skip insn-length))
459                    (unwatch ()
460                      :report "Unwatch the object and retry the write."
461                      (unwatch object))))))))
462          ((= signal #+win32-target 10 #-win32-target #$SIGBUS)
463           (if (= code -1)
464             (%error (make-condition 'invalid-memory-operation)
465                     ()
466                     frame-ptr)
467             (%error (make-condition 'invalid-memory-access
468                                     :address addr
469                                     :write-p (not (zerop code)))
470                     ()
471                     frame-ptr)))
472          ((= signal #-win32-target #$SIGTRAP #+win32-target 5)
473           (when (= code 0)
474             (let* ((hook *pending-gc-notification-hook*))
475               (declare (special *pending-gc-notification-hook*))
476               (when hook (funcall hook))))))
477    skip))
478
479(defun x86-faulting-instruction (xp)
480  (let* ((code-bytes (make-array 15 :element-type '(unsigned-byte 8)))
481         (pc (indexed-gpr-macptr xp #+x8632-target eip-register-offset
482                                    #+x8664-target rip-register-offset)))
483    (dotimes (i (length code-bytes))
484      (setf (aref code-bytes i) (%get-unsigned-byte pc i)))
485    (let* ((ds (make-x86-disassembly-state
486                :mode-64 #+x8664-target t #+x8632-target nil
487                :code-vector code-bytes
488                :code-pointer 0))
489           (insn (x86-disassemble-instruction ds nil))
490           (len (- (x86-ds-code-pointer ds) (x86-ds-insn-start ds))))
491      (values insn len))))
Note: See TracBrowser for help on using the repository browser.