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

Last change on this file since 15018 was 15000, checked in by rme, 8 years ago

In r14968, we overloaded a couple of slots in the x86 xcf
in order to represent the absolute pc value as two fixnums.
Instead of doing that, add two slots to the x86 xcf and
always put the the encoded absolute pc there.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 22.4 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  (defmacro xp-xmm-regs (xp)
34    `(pref ,xp :ucontext.uc_mcontext.fpregs._xmm))
35  (defparameter *encoded-gpr-to-indexed-gpr*
36    #(13                                ;rax
37      14                                ;rcx
38      12                                ;rdx
39      11                                ;rbx
40      15                                ;rsp
41      10                                ;rbp
42      9                                 ;rsi
43      8                                 ;rdi
44      0                                 ;r8
45      1                                 ;r9
46      2                                 ;r10
47      3                                 ;r11
48      4                                 ;r12
49      5                                 ;r13
50      6                                 ;r14
51      7                                 ;r15
52      )))
53
54#+freebsdx8664-target
55(progn
56  (defconstant gp-regs-offset (get-field-offset :ucontext_t.uc_mcontext))
57  (defmacro xp-gp-regs (xp) xp)
58  (defconstant flags-register-offset 22)
59  (defconstant rip-register-offset 20)
60  (defun xp-mxcsr (xp)
61    (with-macptrs ((state (pref xp :__ucontext.uc_mcontext.mc_fpstate)))
62      (pref state :savefpu.sv_env.en_mxcsr)))
63  (defmacro xp-xmm-regs (xp)
64    (let* ((state (gensym)))
65      `(with-macptrs ((,state (pref ,xp :__ucontext.uc_mcontext.mc_fpstate)))
66        (pref ,state :savefpu.sv_xmm))))
67     
68  (defparameter *encoded-gpr-to-indexed-gpr*
69    #(7                                 ;rax
70      4                                 ;rcx
71      3                                 ;rdx
72      8                                 ;rbx
73      23                                ;rsp
74      9                                 ;rbp
75      2                                 ;rsi
76      1                                 ;rdi
77      5                                 ;r8
78      6                                 ;r9
79      10                                ;r10
80      11                                ;r11
81      12                                ;r12
82      13                                ;r13
83      14                                ;r14
84      15                                ;r15
85      )))
86
87#+darwinx8664-target
88(progn
89  (defconstant gp-regs-offset 0)
90  (defun xp-mxcsr (xp)
91     (pref xp :ucontext_t.uc_mcontext.__fs.__fpu_mxcsr))
92  (defmacro xp-gp-regs (xp)
93    `(pref ,xp :ucontext_t.uc_mcontext.__ss))
94  (defmacro xp-xmm-regs (xp)
95    `(pref ,xp :ucontext_t.uc_mcontext.__fs.__fpu_xmm0))
96
97  (defconstant flags-register-offset 17)
98  (defconstant rip-register-offset 16) 
99  (defparameter *encoded-gpr-to-indexed-gpr*
100    #(0                                 ;rax
101      2                                 ;rcx
102      3                                 ;rdx
103      1                                 ;rbx
104      7                                 ;rsp
105      6                                 ;rbp
106      5                                 ;rsi
107      4                                 ;rdi
108      8                                 ;r8
109      9                                 ;r9
110      10                                ;r10
111      11                                ;r11
112      12                                ;r12
113      13                                ;r13
114      14                                ;r14
115      15                                ;r15
116      )))
117
118#+solarisx8664-target
119(progn
120  (defconstant gp-regs-offset (+ (get-field-offset :ucontext.uc_mcontext)
121                                 (get-field-offset :mcontext_t.gregs)))
122  (defmacro xp-gp-regs (xp) xp)
123  (defconstant flags-register-offset #$REG_RFL)
124  (defconstant rip-register-offset #$REG_RIP)
125  (defun xp-mxcsr (xp)
126    (pref xp :ucontext.uc_mcontext.fpregs.fp_reg_set.fpchip_state.mxcsr))
127  (defmacro xp-xmm-regs (xp)
128    `(pref ,xp :ucontext.uc_mcontext.fpregs.fp_reg_set.fpchip_state.xmm))
129  (defparameter *encoded-gpr-to-indexed-gpr*
130    #(14                                ;rax
131      13                                ;rcx
132      12                                ;rdx
133      11                                ;rbx
134      20                                ;rsp
135      10                                ;rbp
136      9                                 ;rsi
137      8                                 ;rdi
138      7                                 ;r8
139      6                                 ;r9
140      5                                 ;r10
141      4                                 ;r11
142      3                                 ;r12
143      2                                 ;r13
144      1                                 ;r14
145      0                                 ;r15
146      )))
147
148#+win64-target
149(progn
150  (defconstant gp-regs-offset (get-field-offset #>CONTEXT.Rax))
151  (defmacro xp-gp-regs (xp) xp)
152  (defconstant rip-register-offset 16)
153  (defun xp-mxcsr (xp)
154    (pref xp #>CONTEXT.MxCsr))
155  (defmacro xp-xmm-regs (xp)
156    `(pref ,xp #>CONTEXT.nil.FltSave.XmmRegisters))
157  (defparameter *encoded-gpr-to-indexed-gpr*
158    #(0                                 ;rax
159      1                                 ;rcx
160      2                                 ;rdx
161      3                                 ;rbx
162      4                                 ;rsp
163      5                                 ;rbp
164      6                                 ;rsi
165      7                                 ;rdi
166      8                                 ;r8
167      9                                 ;r9
168      10                                ;r10
169      11                                ;r11
170      12                                ;r12
171      13                                ;r13
172      14                                ;r14
173      15                                ;r15
174      )))
175
176#+darwinx8632-target
177(progn
178  (defconstant gp-regs-offset 0)
179  (defmacro xp-gp-regs (xp)
180    `(pref ,xp :ucontext_t.uc_mcontext.__ss))
181  (defun xp-mxcsr (xp)
182    (pref xp :ucontext_t.uc_mcontext.__fs.__fpu_mxcsr))
183  (defmacro xp-xmm-regs (xp)
184    `(pref ,xp :ucontext_t.uc_mcontext.__fs.__fpu_xmm0))
185  (defconstant flags-register-offset 9)
186  (defconstant eip-register-offset 10)
187  (defparameter *encoded-gpr-to-indexed-gpr*
188    #(0                                 ;eax
189      2                                 ;ecx
190      3                                 ;edx
191      1                                 ;ebx
192      7                                 ;esp
193      6                                 ;ebp
194      5                                 ;esi
195      4                                 ;edi
196      )))
197
198#+linuxx8632-target
199(progn
200  (defconstant gp-regs-offset 0)
201  (defmacro xp-gp-regs (xp)
202    `(pref (pref ,xp :ucontext.uc_mcontext) :mcontext_t.gregs))
203  (defun xp-mxcsr (xp)
204    (pref (pref (pref xp :ucontext.uc_mcontext) :mcontext_t.fpregs)
205          :_fpstate.mxcsr))
206  (defmacro xp-xmm-regs (xp)
207    `(pref (pref ,xp :ucontext.uc_mcontext.fpregs) :_fpstate._xmm))
208  (defconstant flags-register-offset #$REG_EFL)
209  (defconstant eip-register-offset #$REG_EIP)
210  (defparameter *encoded-gpr-to-indexed-gpr*
211    (vector
212     #$REG_EAX                         ;eax
213      #$REG_ECX                         ;ecx
214      #$REG_EDX                         ;edx
215      #$REG_EBX                         ;ebx
216      #$REG_ESP                         ;esp
217      #$REG_EBP                         ;ebp
218      #$REG_ESI                         ;esi
219      #$REG_EDI                         ;edi
220      )))
221
222#+win32-target
223(progn
224  (defconstant gp-regs-offset 0)
225  (defmacro xp-gp-regs (xp)
226    `,xp)
227  (defun xp-mxcsr (xp)
228    (%get-unsigned-long (pref xp #>CONTEXT.ExtendedRegisters) 24))
229  (defmacro xp-xmm-regs (xp)
230    `(%inc-ptr ,xp #x16c))
231  (defconstant flags-register-offset 48)
232  (defconstant eip-register-offset 45)
233  (defparameter *encoded-gpr-to-indexed-gpr*
234    #(
235     44                                ;eax
236     43                                ;ecx
237     42                                ;edx
238     41                                ;ebx
239     49                                ;esp
240     45                                ;ebp
241     40                                ;esi
242     39                                ;edi
243      )))
244
245#+solarisx8632-target
246(progn
247  (defconstant gp-regs-offset 0)
248  (defmacro xp-gp-regs (xp)
249    `(pref (pref ,xp :ucontext.uc_mcontext) :mcontext_t.gregs))
250  (defun xp-mxcsr (xp)
251    (pref xp :ucontext.uc_mcontext.fpregs.fp_reg_set.fpchip_state.mxcsr))
252  (defconstant flags-register-offset #$EFL)
253  (defmacro xp-xmm-regs (xp)
254    `(pref ,xp :ucontext.uc_mcontext.fpregs.fp_reg_set.fpchip_state.xmm))
255  (defconstant eip-register-offset #$EIP)
256  (defparameter *encoded-gpr-to-indexed-gpr*
257    (vector
258     #$EAX
259     #$ECX
260     #$EDX
261     #$EBX
262     #$ESP
263     #$EBP
264     #$ESI
265     #$EDI)
266      ))
267
268#+freebsdx8632-target
269(progn
270  (defconstant gp-regs-offset 0)
271  (defmacro xp-gp-regs (xp)
272    `(pref ,xp :ucontext_t.uc_mcontext))
273  (defun xp-mxcsr (xp)
274    (pref (pref xp :ucontext_t.uc_mcontext.mc_fpstate) :savexmm.sv_env.en_mxcsr))
275  (defmacro xp-xmm-regs (xp)
276    `(pref (pref ,xp :ucontext_t.uc_mcontext.mc_fpstate) :savexmm.sv_xmm))
277  (defconstant flags-register-offset 17)
278  (defconstant eip-register-offset 15)
279  (defparameter *encoded-gpr-to-indexed-gpr*
280    #(
281      12                                ;eax
282      11                                ;ecx
283      10                                ;edx
284      9                                 ;ebx
285      18                                ;esp
286      7                                 ;ebp
287      6                                 ;esi
288      5                                 ;edi
289      )
290      ))
291
292(defun indexed-gpr-lisp (xp igpr)
293  (%get-object (xp-gp-regs xp) (+ gp-regs-offset (ash igpr target::word-shift))))
294(defun (setf indexed-gpr-lisp) (new xp igpr)
295  (%set-object (xp-gp-regs xp) (+ gp-regs-offset (ash igpr target::word-shift)) new))
296(defun encoded-gpr-lisp (xp gpr)
297  (indexed-gpr-lisp xp (aref *encoded-gpr-to-indexed-gpr* gpr)))
298(defun (setf encoded-gpr-lisp) (new xp gpr)
299  (setf (indexed-gpr-lisp xp (aref *encoded-gpr-to-indexed-gpr* gpr)) new))
300(defun indexed-gpr-integer (xp igpr)
301  #+x8664-target
302  (%get-signed-long-long (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8664::word-shift)))
303  #+x8632-target
304  (%get-signed-long (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8632::word-shift))))
305(defun (setf indexed-gpr-integer) (new xp igpr)
306  (setf
307   #+x8664-target
308   (%get-signed-long-long (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8664::word-shift)))
309   #+x8632-target
310   (%get-signed-long (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8632::word-shift)))
311   new))
312(defun encoded-gpr-integer (xp gpr)
313  (indexed-gpr-integer xp (aref *encoded-gpr-to-indexed-gpr* gpr)))
314(defun (setf encoded-gpr-integer) (new xp gpr)
315  (setf (indexed-gpr-integer xp (aref *encoded-gpr-to-indexed-gpr* gpr)) new))
316(defun indexed-gpr-macptr (xp igpr)
317  (%get-ptr (xp-gp-regs xp) (+ gp-regs-offset (ash igpr target::word-shift))))
318(defun (setf indexed-gpr-macptr) (new xp igpr)
319  (setf (%get-ptr (xp-gp-regs xp) (+ gp-regs-offset (ash igpr target::word-shift))) new))
320(defun encoded-gpr-macptr (xp gpr)
321  (indexed-gpr-macptr xp (aref *encoded-gpr-to-indexed-gpr* gpr)))
322(defun (setf encoded-gpr-macptr) (new xp gpr)
323  (setf (indexed-gpr-macptr xp (aref *encoded-gpr-to-indexed-gpr* gpr)) new))
324(defun xp-flags-register (xp)
325  #+windows-target (pref xp #>CONTEXT.EFlags)
326  #-windows-target
327  (progn
328  #+x8664-target
329  (%get-signed-long-long (xp-gp-regs xp) (+ gp-regs-offset (ash flags-register-offset x8664::fixnumshift)))
330  #+x8632-target
331  (%get-signed-long (xp-gp-regs xp) (+ gp-regs-offset (ash flags-register-offset x8632::fixnumshift)))))
332(defmacro xp-xmm-single-float (xp n)
333  `(%get-single-float (xp-xmm-regs ,xp) (ash ,n 4)))
334(defmacro xp-xmm-double-float (xp n)
335  `(%get-double-float (xp-xmm-regs ,xp) (ash ,n 4)))
336
337(defun %get-xcf-byte (xcf-ptr delta)
338  (let* ((containing-object (%get-object xcf-ptr target::xcf.containing-object))
339         (byte-offset (%get-object xcf-ptr target::xcf.relative-pc)))
340    (if containing-object
341      (locally (declare (optimize (speed 3) (safety 0))
342                        (type (simple-array (unsigned-byte 8) (*)) containing-object))
343        (aref containing-object (the fixnum (+ byte-offset delta))))
344      (let* ((high-half (%get-object xcf-ptr target::xcf.pc-high))
345             (low-half (%get-object xcf-ptr target::xcf.pc-low))
346             (pc #+64-bit-target (dpb high-half (byte 32 32) low-half)
347                 #+32-bit-target (dpb high-half (byte 16 16) low-half)))
348        (%get-unsigned-byte (%int-to-ptr pc) delta)))))
349
350;;; If the byte following a uuo (which is "skip" bytes long, set
351;;; the xcf's relative PC to the value contained in the 32-bit
352;;; word preceding the current relative PC and return -1, else return skip.
353(defun %check-anchored-uuo (xcf skip)
354  (if (eql 0 (%get-xcf-byte xcf skip))
355    (let* ((new-rpc (+ #+x8664-target target::tag-function
356                       #+x8632-target target::fulltag-misc
357                       (logior (ash (%get-xcf-byte xcf -1) 24)
358                               (ash (%get-xcf-byte xcf -2) 16)
359                               (ash (%get-xcf-byte xcf -3) 8)
360                               (%get-xcf-byte xcf -4)))))
361      (%set-object xcf target::xcf.relative-pc new-rpc)
362      -1)
363    skip))
364
365(defun arithmetic-error-operation-from-instruction (instruction)
366  (let* ((name (make-keyword (string-upcase (x86-di-mnemonic instruction)))))
367    (case name
368      ((:divss :divsd :idivl :idivq) '/)
369      ((:mulss :mulsd) '*)
370      ((:addss :addsd) '+)
371      ((:subss :subsd) '-)
372      (t 'coerce))))
373
374(defun arithmetic-error-operands-from-instruction (instruction xp)
375  (let* ((name (make-keyword (string-upcase (x86-di-mnemonic instruction)))))
376    (let* ((op0 (x86-di-op0 instruction))
377           (op1 (x86-di-op1 instruction))
378           (xmmop0 (register-operand-regno op0 #.x86::+operand-type-RegXMM+))
379           (xmmop1 (register-operand-regno op1 #.x86::+operand-type-RegXMM+)))
380      (collect ((opvals))
381        (case name
382          ((:divss :mulss :addss :subss)
383           (when (and xmmop0 xmmop1)
384             (opvals (xp-xmm-single-float xp xmmop1))
385             (opvals (xp-xmm-single-float xp xmmop0))))
386          ((:divsd :mulsd :addsd :subsd)
387           (when (and xmmop0 xmmop1)
388             (opvals (xp-xmm-double-float xp xmmop1))
389             (opvals (xp-xmm-double-float xp xmmop0))))
390          ;; (coerce a-double 'single-float) can overflow.
391          (:cvtsd2ss
392           (when xmmop0
393             (opvals (xp-xmm-double-float xp xmmop1))
394             (opvals 'single-float)))
395          #+x8632-target
396          (:idivl
397           (let* ((reg (register-operand-regno op0 #.x86::+operand-type-Reg32+)))
398             (when reg
399               (opvals (logior (ash (encoded-gpr-integer xp 2) 32)
400                               (logand #xfffffffff (encoded-gpr-integer xp 0))))
401               (opvals (encoded-gpr-integer xp reg)))))
402          #+x8664-target
403          (:idivq
404           (let* ((reg (register-operand-regno op0 #.x86::+operand-type-Reg64+)))
405             (when reg
406               (opvals (logior (ash (encoded-gpr-integer xp 2) 64)
407                               (logand (1- (ash 1 64)) (encoded-gpr-integer xp 0))))
408               (opvals (encoded-gpr-integer xp reg)))))
409               
410           
411          )
412        (opvals)))))
413
414
415                                 
416(defun decode-arithmetic-error (xp xcf)
417  (declare (ignorable xp xcf))
418  (let* ((code-vector (make-array 15 :element-type '(unsigned-byte 8)))
419         (xfunction (%alloc-misc 1 target::subtag-xfunction)))
420    (dotimes (i 15)                     ;maximum instructon size
421      (setf (aref code-vector i) (%get-xcf-byte xcf i)))
422    (setf (uvref xfunction 0) code-vector)
423    (let* ((ds (make-x86-disassembly-state
424                :mode-64 #+x8664-target t #+x8632-target nil
425                :code-vector code-vector
426                :constants-vector xfunction
427                :entry-point 0
428                :code-pointer 0           ; for next-u32/next-u16 below
429                :symbolic-names nil
430                :pending-labels (list 0)
431                :code-limit 15
432                :code-pointer 0))
433           (instruction (ignore-errors (x86-disassemble-instruction ds nil))))
434      (if instruction
435        (values (arithmetic-error-operation-from-instruction  instruction)
436                (arithmetic-error-operands-from-instruction instruction xp))
437        (values 'unknown nil)))))
438
439(eval-when (:compile-toplevel :execute)
440  (progn
441    (defun conditional-os-constant (alternatives)
442      (dolist (c alternatives (error "None of the constants in ~s could be loaded" alternatives))
443        (if (load-os-constant c t)
444          (return (load-os-constant c)))))
445
446    (defconstant integer-divide-by-zero-code
447      (conditional-os-constant '(os::EXCEPTION_INT_DIVIDE_BY_ZERO os::FPE_INTDIV))
448)
449    (defconstant float-divide-by-zero-code
450      (conditional-os-constant '(os::EXCEPTION_FLT_DIVIDE_BY_ZERO os::FPE_FLTDIV)))
451    (defconstant float-overflow-code
452      (conditional-os-constant '(os::FPE_FLTOVF os::EXCEPTION_FLT_OVERFLOW)))
453    (defconstant float-underflow-code
454      (conditional-os-constant '(os::FPE_FLTUND os::EXCEPTION_FLT_UNDERFLOW)))
455    (defconstant float-inexact-code
456      (conditional-os-constant '(os::FPE_FLTRES os::EXCEPTION_FLT_INEXACT_RESULT)))))
457
458(defparameter *pending-gc-notification-hook* nil)
459
460;;; UUOs are handled elsewhere.  This should handle all signals other than
461;;; those generated by UUOs (and the non-UUO cases of things like SIGSEGV.)
462;;; If the signal number is 0, other arguments (besides the exception context XP)
463;;; may not be meaningful.
464(defcallback xcmain (:address xp :address xcf :int signal :long code :long addr :long other :int)
465  (let* ((frame-ptr (macptr->fixnum xcf))
466         (skip 0))
467    (cond ((zerop signal)               ;thread interrupt
468           (cmain))
469          ((< signal 0)
470           (%err-disp-internal code () frame-ptr))
471          ((= signal #$SIGFPE)
472           (setq code (logand #xffffffff code))
473           (multiple-value-bind (operation operands)
474               (decode-arithmetic-error xp xcf)
475             (let* ((condition-name
476                     (cond ((or (= code integer-divide-by-zero-code)
477                                (= code float-divide-by-zero-code))
478                            'division-by-zero)
479                           ((= code float-overflow-code)
480                            'floating-point-overflow)
481                           ((= code float-underflow-code)
482                            'floating-point-underflow)
483                           ((= code float-inexact-code)
484                            'floating-point-inexact)
485                           (t
486                            'floating-point-invalid-operation))))
487               (%error (make-condition condition-name
488                                       :operation operation
489                                       :operands operands
490                                       :status (xp-mxcsr xp))
491                       ()
492                       frame-ptr))))
493          ((= signal #$SIGSEGV)
494           (cond
495             ((or (= code 0) (= code 1))
496              ;; Stack overflow.
497              (let* ((on-tsp (= code 1)))
498                (unwind-protect
499                     (%error
500                      (make-condition
501                       'stack-overflow-condition 
502                       :format-control "Stack overflow on ~a stack."
503                       :format-arguments (list (if on-tsp "temp" "value")))
504                      nil frame-ptr)
505                  (ff-call (%kernel-import target::kernel-import-restore-soft-stack-limit)
506                           :unsigned-fullword code
507                           :void))))
508             ((= code 2)
509              ;; Write to a watched object.
510              (let* ((offset other)
511                     ;; The kernel exception handler leaves the
512                     ;; watched object on the lisp stack under the
513                     ;; xcf.
514                     (object (%get-object xcf target::xcf.size)))
515                (multiple-value-bind (insn insn-length)
516                    (ignore-errors (x86-faulting-instruction xp))
517                  (restart-case (%error (make-condition
518                                         'write-to-watched-object
519                                         :offset offset
520                                         :object object
521                                         :instruction insn)
522                                        nil frame-ptr)
523                    #-windows-target
524                    (emulate ()
525                      :test (lambda (c)
526                              (declare (ignore c))
527                              (x86-can-emulate-instruction insn))
528                      :report
529                      "Emulate this instruction, leaving the object watched."
530                      (flet ((watchedp (object)
531                               (%map-areas #'(lambda (x)
532                                               (when (eq object x)
533                                                 (return-from watchedp t)))
534                                           area-watched)))
535                        (let ((result nil))
536                          (with-other-threads-suspended
537                            (when (watchedp object)
538                              ;; We now trust that the object is in a
539                              ;; static gc area.
540                              (let* ((a (+ (%address-of object) offset))
541                                     (ptr (%int-to-ptr
542                                           (logandc2 a (1- *host-page-size*)))))
543                                (#_mprotect ptr *host-page-size* #$PROT_WRITE)
544                                (setq result (x86-emulate-instruction xp insn))
545                                (#_mprotect ptr *host-page-size*
546                                            (logior #$PROT_READ #$PROT_EXEC)))))
547                          (if result
548                            (setq skip insn-length)
549                            (error "could not emulate the instrution")))))
550                    (skip ()
551                      :test (lambda (c)
552                              (declare (ignore c))
553                              insn)
554                      :report "Skip over this write instruction."
555                      (setq skip insn-length))
556                    (unwatch ()
557                      :report "Unwatch the object and retry the write."
558                      (unwatch object))))))))
559          ((= signal #+win32-target 10 #-win32-target #$SIGBUS)
560           (if (= code -1)
561             (%error (make-condition 'invalid-memory-operation)
562                     ()
563                     frame-ptr)
564             (%error (make-condition 'invalid-memory-access
565                                     :address addr
566                                     :write-p (not (zerop code)))
567                     ()
568                     frame-ptr)))
569          ((= signal #-win32-target #$SIGTRAP #+win32-target 5)
570           (when (= code 0)
571             (let* ((hook *pending-gc-notification-hook*))
572               (declare (special *pending-gc-notification-hook*))
573               (when hook (funcall hook))))))
574    skip))
575
576(defun x86-faulting-instruction (xp)
577  (let* ((code-bytes (make-array 15 :element-type '(unsigned-byte 8)))
578         (pc (indexed-gpr-macptr xp #+x8632-target eip-register-offset
579                                    #+x8664-target rip-register-offset)))
580    (dotimes (i (length code-bytes))
581      (setf (aref code-bytes i) (%get-unsigned-byte pc i)))
582    (let* ((ds (make-x86-disassembly-state
583                :mode-64 #+x8664-target t #+x8632-target nil
584                :code-vector code-bytes
585                :code-pointer 0))
586           (insn (x86-disassemble-instruction ds nil))
587           (len (- (x86-ds-code-pointer ds) (x86-ds-insn-start ds))))
588      (values insn len))))
Note: See TracBrowser for help on using the repository browser.