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

Last change on this file since 14842 was 14842, checked in by gb, 8 years ago

Determine arithmetic-error-operands for integer division,
double->single coercion.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 22.3 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      ;; xcf.relative-pc is a fixnum, but it might be negative.
345      (let* ((encoded-pc (%get-ptr xcf-ptr target::xcf.relative-pc))
346             (pc (ash (%ptr-to-int encoded-pc) (- target::fixnumshift))))
347        (%get-unsigned-byte (%int-to-ptr pc) delta)))))
348
349;;; If the byte following a uuo (which is "skip" bytes long, set
350;;; the xcf's relative PC to the value contained in the 32-bit
351;;; word preceding the current relative PC and return -1, else return skip.
352(defun %check-anchored-uuo (xcf skip)
353  (if (eql 0 (%get-xcf-byte xcf skip))
354    (let* ((new-rpc (+ #+x8664-target target::tag-function
355                       #+x8632-target target::fulltag-misc
356                       (logior (ash (%get-xcf-byte xcf -1) 24)
357                               (ash (%get-xcf-byte xcf -2) 16)
358                               (ash (%get-xcf-byte xcf -3) 8)
359                               (%get-xcf-byte xcf -4)))))
360      (%set-object xcf target::xcf.relative-pc new-rpc)
361      -1)
362    skip))
363
364(defun arithmetic-error-operation-from-instruction (instruction)
365  (let* ((name (make-keyword (string-upcase (x86-di-mnemonic instruction)))))
366    (case name
367      ((:divss :divsd :idivl :idivq) '/)
368      ((:mulss :mulsd) '*)
369      ((:addss :addsd) '+)
370      ((:subss :subsd) '-)
371      (t 'coerce))))
372
373(defun arithmetic-error-operands-from-instruction (instruction xp)
374  (let* ((name (make-keyword (string-upcase (x86-di-mnemonic instruction)))))
375    (let* ((op0 (x86-di-op0 instruction))
376           (op1 (x86-di-op1 instruction))
377           (xmmop0 (register-operand-regno op0 #.x86::+operand-type-RegXMM+))
378           (xmmop1 (register-operand-regno op1 #.x86::+operand-type-RegXMM+)))
379      (collect ((opvals))
380        (case name
381          ((:divss :mulss :addss :subss)
382           (when (and xmmop0 xmmop1)
383             (opvals (xp-xmm-single-float xp xmmop1))
384             (opvals (xp-xmm-single-float xp xmmop0))))
385          ((:divsd :mulsd :addsd :subsd)
386           (when (and xmmop0 xmmop1)
387             (opvals (xp-xmm-double-float xp xmmop1))
388             (opvals (xp-xmm-double-float xp xmmop0))))
389          ;; (coerce a-double 'single-float) can overflow.
390          (:cvtsd2ss
391           (when xmmop0
392             (opvals (xp-xmm-double-float xp xmmop1))
393             (opvals 'single-float)))
394          #+x8632-target
395          (:idivl
396           (let* ((reg (register-operand-regno op0 #.x86::+operand-type-Reg32+)))
397             (when reg
398               (opvals (logior (ash (encoded-gpr-integer xp 2) 32)
399                               (logand #xfffffffff (encoded-gpr-integer xp 0))))
400               (opvals (encoded-gpr-integer xp reg)))))
401          #+x8664-target
402          (:idivq
403           (let* ((reg (register-operand-regno op0 #.x86::+operand-type-Reg64+)))
404             (when reg
405               (opvals (logior (ash (encoded-gpr-integer xp 2) 64)
406                               (logand (1- (ash 1 64)) (encoded-gpr-integer xp 0))))
407               (opvals (encoded-gpr-integer xp reg)))))
408               
409           
410          )
411        (opvals)))))
412
413
414                                 
415(defun decode-arithmetic-error (xp xcf)
416  (declare (ignorable xp xcf))
417  (let* ((code-vector (make-array 15 :element-type '(unsigned-byte 8)))
418         (xfunction (%alloc-misc 1 target::subtag-xfunction)))
419    (dotimes (i 15)                     ;maximum instructon size
420      (setf (aref code-vector i) (%get-xcf-byte xcf i)))
421    (setf (uvref xfunction 0) code-vector)
422    (let* ((ds (make-x86-disassembly-state
423                :mode-64 #+x8664-target t #+x8632-target nil
424                :code-vector code-vector
425                :constants-vector xfunction
426                :entry-point 0
427                :code-pointer 0           ; for next-u32/next-u16 below
428                :symbolic-names nil
429                :pending-labels (list 0)
430                :code-limit 15
431                :code-pointer 0))
432           (instruction (ignore-errors (x86-disassemble-instruction ds nil))))
433      (if instruction
434        (values (arithmetic-error-operation-from-instruction  instruction)
435                (arithmetic-error-operands-from-instruction instruction xp))
436        (values 'unknown nil)))))
437
438(eval-when (:compile-toplevel :execute)
439  (progn
440    (defun conditional-os-constant (alternatives)
441      (dolist (c alternatives (error "None of the constants in ~s could be loaded" alternatives))
442        (if (load-os-constant c t)
443          (return (load-os-constant c)))))
444
445    (defconstant integer-divide-by-zero-code
446      (conditional-os-constant '(os::EXCEPTION_INT_DIVIDE_BY_ZERO os::FPE_INTDIV))
447)
448    (defconstant float-divide-by-zero-code
449      (conditional-os-constant '(os::EXCEPTION_FLT_DIVIDE_BY_ZERO os::FPE_FLTDIV)))
450    (defconstant float-overflow-code
451      (conditional-os-constant '(os::FPE_FLTOVF os::EXCEPTION_FLT_OVERFLOW)))
452    (defconstant float-underflow-code
453      (conditional-os-constant '(os::FPE_FLTUND os::EXCEPTION_FLT_UNDERFLOW)))
454    (defconstant float-inexact-code
455      (conditional-os-constant '(os::FPE_FLTRES os::EXCEPTION_FLT_INEXACT_RESULT)))))
456
457(defparameter *pending-gc-notification-hook* nil)
458
459;;; UUOs are handled elsewhere.  This should handle all signals other than
460;;; those generated by UUOs (and the non-UUO cases of things like SIGSEGV.)
461;;; If the signal number is 0, other arguments (besides the exception context XP)
462;;; may not be meaningful.
463(defcallback xcmain (:address xp :address xcf :int signal :long code :long addr :long other :int)
464  (let* ((frame-ptr (macptr->fixnum xcf))
465         (skip 0))
466    (cond ((zerop signal)               ;thread interrupt
467           (cmain))
468          ((< signal 0)
469           (%err-disp-internal code () frame-ptr))
470          ((= signal #$SIGFPE)
471           (setq code (logand #xffffffff code))
472           (multiple-value-bind (operation operands)
473               (decode-arithmetic-error xp xcf)
474             (let* ((condition-name
475                     (cond ((or (= code integer-divide-by-zero-code)
476                                (= code float-divide-by-zero-code))
477                            'division-by-zero)
478                           ((= code float-overflow-code)
479                            'floating-point-overflow)
480                           ((= code float-underflow-code)
481                            'floating-point-underflow)
482                           ((= code float-inexact-code)
483                            'floating-point-inexact)
484                           (t
485                            'floating-point-invalid-operation))))
486               (%error (make-condition condition-name
487                                       :operation operation
488                                       :operands operands
489                                       :status (xp-mxcsr xp))
490                       ()
491                       frame-ptr))))
492          ((= signal #$SIGSEGV)
493           (cond
494             ((or (= code 0) (= code 1))
495              ;; Stack overflow.
496              (let* ((on-tsp (= code 1)))
497                (unwind-protect
498                     (%error
499                      (make-condition
500                       'stack-overflow-condition 
501                       :format-control "Stack overflow on ~a stack."
502                       :format-arguments (list (if on-tsp "temp" "value")))
503                      nil frame-ptr)
504                  (ff-call (%kernel-import target::kernel-import-restore-soft-stack-limit)
505                           :unsigned-fullword code
506                           :void))))
507             ((= code 2)
508              ;; Write to a watched object.
509              (let* ((offset other)
510                     ;; The kernel exception handler leaves the
511                     ;; watched object on the lisp stack under the
512                     ;; xcf.
513                     (object (%get-object xcf target::xcf.size)))
514                (multiple-value-bind (insn insn-length)
515                    (ignore-errors (x86-faulting-instruction xp))
516                  (restart-case (%error (make-condition
517                                         'write-to-watched-object
518                                         :offset offset
519                                         :object object
520                                         :instruction insn)
521                                        nil frame-ptr)
522                    #-windows-target
523                    (emulate ()
524                      :test (lambda (c)
525                              (declare (ignore c))
526                              (x86-can-emulate-instruction insn))
527                      :report
528                      "Emulate this instruction, leaving the object watched."
529                      (flet ((watchedp (object)
530                               (%map-areas #'(lambda (x)
531                                               (when (eq object x)
532                                                 (return-from watchedp t)))
533                                           area-watched)))
534                        (let ((result nil))
535                          (with-other-threads-suspended
536                            (when (watchedp object)
537                              ;; We now trust that the object is in a
538                              ;; static gc area.
539                              (let* ((a (+ (%address-of object) offset))
540                                     (ptr (%int-to-ptr
541                                           (logandc2 a (1- *host-page-size*)))))
542                                (#_mprotect ptr *host-page-size* #$PROT_WRITE)
543                                (setq result (x86-emulate-instruction xp insn))
544                                (#_mprotect ptr *host-page-size*
545                                            (logior #$PROT_READ #$PROT_EXEC)))))
546                          (if result
547                            (setq skip insn-length)
548                            (error "could not emulate the instrution")))))
549                    (skip ()
550                      :test (lambda (c)
551                              (declare (ignore c))
552                              insn)
553                      :report "Skip over this write instruction."
554                      (setq skip insn-length))
555                    (unwatch ()
556                      :report "Unwatch the object and retry the write."
557                      (unwatch object))))))))
558          ((= signal #+win32-target 10 #-win32-target #$SIGBUS)
559           (if (= code -1)
560             (%error (make-condition 'invalid-memory-operation)
561                     ()
562                     frame-ptr)
563             (%error (make-condition 'invalid-memory-access
564                                     :address addr
565                                     :write-p (not (zerop code)))
566                     ()
567                     frame-ptr)))
568          ((= signal #-win32-target #$SIGTRAP #+win32-target 5)
569           (when (= code 0)
570             (let* ((hook *pending-gc-notification-hook*))
571               (declare (special *pending-gc-notification-hook*))
572               (when hook (funcall hook))))))
573    skip))
574
575(defun x86-faulting-instruction (xp)
576  (let* ((code-bytes (make-array 15 :element-type '(unsigned-byte 8)))
577         (pc (indexed-gpr-macptr xp #+x8632-target eip-register-offset
578                                    #+x8664-target rip-register-offset)))
579    (dotimes (i (length code-bytes))
580      (setf (aref code-bytes i) (%get-unsigned-byte pc i)))
581    (let* ((ds (make-x86-disassembly-state
582                :mode-64 #+x8664-target t #+x8632-target nil
583                :code-vector code-bytes
584                :code-pointer 0))
585           (insn (x86-disassemble-instruction ds nil))
586           (len (- (x86-ds-code-pointer ds) (x86-ds-insn-start ds))))
587      (values insn len))))
Note: See TracBrowser for help on using the repository browser.