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

Last change on this file was 16685, checked in by rme, 4 years ago

Update copyright/license headers in files.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 24.1 KB
Line 
1;;;
2;;; Copyright 2005-2009 Clozure Associates
3;;;
4;;; Licensed under the Apache License, Version 2.0 (the "License");
5;;; you may not use this file except in compliance with the License.
6;;; You may obtain a copy of the License at
7;;;
8;;;     http://www.apache.org/licenses/LICENSE-2.0
9;;;
10;;; Unless required by applicable law or agreed to in writing, software
11;;; distributed under the License is distributed on an "AS IS" BASIS,
12;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13;;; See the License for the specific language governing permissions and
14;;; limitations under the License.
15
16
17(in-package "CCL")
18
19;;; The order in which GPRs appear in an exception context generally
20;;; has nothing to do with how they're encoded in instructions/uuos,
21;;; and is OS-dependent.
22
23#+linuxx8664-target
24(progn
25  (defconstant gp-regs-offset (+ (get-field-offset :ucontext.uc_mcontext)
26                                 (get-field-offset :mcontext_t.gregs)))
27  (defmacro xp-gp-regs (xp) xp)
28  (defconstant flags-register-offset #$REG_EFL)
29  (defconstant rip-register-offset #$REG_RIP)
30  (defun xp-mxcsr (xp)
31    (pref xp :ucontext.uc_mcontext.fpregs.mxcsr))
32  (defmacro xp-xmm-regs (xp)
33    `(pref ,xp :ucontext.uc_mcontext.fpregs._xmm))
34  (defparameter *encoded-gpr-to-indexed-gpr*
35    #(13                                ;rax
36      14                                ;rcx
37      12                                ;rdx
38      11                                ;rbx
39      15                                ;rsp
40      10                                ;rbp
41      9                                 ;rsi
42      8                                 ;rdi
43      0                                 ;r8
44      1                                 ;r9
45      2                                 ;r10
46      3                                 ;r11
47      4                                 ;r12
48      5                                 ;r13
49      6                                 ;r14
50      7                                 ;r15
51      )))
52
53#+freebsdx8664-target
54(progn
55  (defconstant gp-regs-offset (get-field-offset :ucontext_t.uc_mcontext))
56  (defmacro xp-gp-regs (xp) xp)
57  (defconstant flags-register-offset 22)
58  (defconstant rip-register-offset 20)
59  (defun xp-mxcsr (xp)
60    (with-macptrs ((state (pref xp :__ucontext.uc_mcontext.mc_fpstate)))
61      (pref state :savefpu.sv_env.en_mxcsr)))
62  (defmacro xp-xmm-regs (xp)
63    (let* ((state (gensym)))
64      `(with-macptrs ((,state (pref ,xp :__ucontext.uc_mcontext.mc_fpstate)))
65        (pref ,state :savefpu.sv_xmm))))
66     
67  (defparameter *encoded-gpr-to-indexed-gpr*
68    #(7                                 ;rax
69      4                                 ;rcx
70      3                                 ;rdx
71      8                                 ;rbx
72      23                                ;rsp
73      9                                 ;rbp
74      2                                 ;rsi
75      1                                 ;rdi
76      5                                 ;r8
77      6                                 ;r9
78      10                                ;r10
79      11                                ;r11
80      12                                ;r12
81      13                                ;r13
82      14                                ;r14
83      15                                ;r15
84      )))
85
86#+darwinx8664-target
87(progn
88  (defconstant gp-regs-offset 0)
89  (defun xp-mxcsr (xp)
90     (pref xp :ucontext_t.uc_mcontext.__fs.__fpu_mxcsr))
91  (defmacro xp-gp-regs (xp)
92    `(pref ,xp :ucontext_t.uc_mcontext.__ss))
93  (defmacro xp-xmm-regs (xp)
94    `(pref ,xp :ucontext_t.uc_mcontext.__fs.__fpu_xmm0))
95
96  (defconstant flags-register-offset 17)
97  (defconstant rip-register-offset 16) 
98  (defparameter *encoded-gpr-to-indexed-gpr*
99    #(0                                 ;rax
100      2                                 ;rcx
101      3                                 ;rdx
102      1                                 ;rbx
103      7                                 ;rsp
104      6                                 ;rbp
105      5                                 ;rsi
106      4                                 ;rdi
107      8                                 ;r8
108      9                                 ;r9
109      10                                ;r10
110      11                                ;r11
111      12                                ;r12
112      13                                ;r13
113      14                                ;r14
114      15                                ;r15
115      )))
116
117#+solarisx8664-target
118(progn
119  (defconstant gp-regs-offset (+ (get-field-offset :ucontext.uc_mcontext)
120                                 (get-field-offset :mcontext_t.gregs)))
121  (defmacro xp-gp-regs (xp) xp)
122  (defconstant flags-register-offset #$REG_RFL)
123  (defconstant rip-register-offset #$REG_RIP)
124  (defun xp-mxcsr (xp)
125    (pref xp :ucontext.uc_mcontext.fpregs.fp_reg_set.fpchip_state.mxcsr))
126  (defmacro xp-xmm-regs (xp)
127    `(pref ,xp :ucontext.uc_mcontext.fpregs.fp_reg_set.fpchip_state.xmm))
128  (defparameter *encoded-gpr-to-indexed-gpr*
129    #(14                                ;rax
130      13                                ;rcx
131      12                                ;rdx
132      11                                ;rbx
133      20                                ;rsp
134      10                                ;rbp
135      9                                 ;rsi
136      8                                 ;rdi
137      7                                 ;r8
138      6                                 ;r9
139      5                                 ;r10
140      4                                 ;r11
141      3                                 ;r12
142      2                                 ;r13
143      1                                 ;r14
144      0                                 ;r15
145      )))
146
147#+win64-target
148(progn
149  (defconstant gp-regs-offset (get-field-offset #>CONTEXT.Rax))
150  (defmacro xp-gp-regs (xp) xp)
151  (defconstant rip-register-offset 16)
152  (defun xp-mxcsr (xp)
153    (pref xp #>CONTEXT.MxCsr))
154  (defmacro xp-xmm-regs (xp)
155    `(pref ,xp #>CONTEXT.nil.FltSave.XmmRegisters))
156  (defparameter *encoded-gpr-to-indexed-gpr*
157    #(0                                 ;rax
158      1                                 ;rcx
159      2                                 ;rdx
160      3                                 ;rbx
161      4                                 ;rsp
162      5                                 ;rbp
163      6                                 ;rsi
164      7                                 ;rdi
165      8                                 ;r8
166      9                                 ;r9
167      10                                ;r10
168      11                                ;r11
169      12                                ;r12
170      13                                ;r13
171      14                                ;r14
172      15                                ;r15
173      )))
174
175#+darwinx8632-target
176(progn
177  (defconstant gp-regs-offset 0)
178  (defmacro xp-gp-regs (xp)
179    `(pref ,xp :ucontext_t.uc_mcontext.__ss))
180  (defun xp-mxcsr (xp)
181    (pref xp :ucontext_t.uc_mcontext.__fs.__fpu_mxcsr))
182  (defmacro xp-xmm-regs (xp)
183    `(pref ,xp :ucontext_t.uc_mcontext.__fs.__fpu_xmm0))
184  (defconstant flags-register-offset 9)
185  (defconstant eip-register-offset 10)
186  (defparameter *encoded-gpr-to-indexed-gpr*
187    #(0                                 ;eax
188      2                                 ;ecx
189      3                                 ;edx
190      1                                 ;ebx
191      7                                 ;esp
192      6                                 ;ebp
193      5                                 ;esi
194      4                                 ;edi
195      )))
196
197#+linuxx8632-target
198(progn
199  (defconstant gp-regs-offset 0)
200  (defmacro xp-gp-regs (xp)
201    `(pref (pref ,xp :ucontext.uc_mcontext) :mcontext_t.gregs))
202  (defun xp-mxcsr (xp)
203    (pref (pref (pref xp :ucontext.uc_mcontext) :mcontext_t.fpregs)
204          :_fpstate.mxcsr))
205  (defmacro xp-xmm-regs (xp)
206    `(pref (pref ,xp :ucontext.uc_mcontext.fpregs) :_fpstate._xmm))
207  (defconstant flags-register-offset #$REG_EFL)
208  (defconstant eip-register-offset #$REG_EIP)
209  (defparameter *encoded-gpr-to-indexed-gpr*
210    (vector
211     #$REG_EAX                         ;eax
212      #$REG_ECX                         ;ecx
213      #$REG_EDX                         ;edx
214      #$REG_EBX                         ;ebx
215      #$REG_ESP                         ;esp
216      #$REG_EBP                         ;ebp
217      #$REG_ESI                         ;esi
218      #$REG_EDI                         ;edi
219      )))
220
221#+win32-target
222(progn
223  (defconstant gp-regs-offset 0)
224  (defmacro xp-gp-regs (xp)
225    `,xp)
226  (defun xp-mxcsr (xp)
227    (%get-unsigned-long (pref xp #>CONTEXT.ExtendedRegisters) 24))
228  (defmacro xp-xmm-regs (xp)
229    `(%inc-ptr ,xp #x16c))
230  (defconstant flags-register-offset 48)
231  (defconstant eip-register-offset 45)
232  (defparameter *encoded-gpr-to-indexed-gpr*
233    #(
234     44                                ;eax
235     43                                ;ecx
236     42                                ;edx
237     41                                ;ebx
238     49                                ;esp
239     45                                ;ebp
240     40                                ;esi
241     39                                ;edi
242      )))
243
244#+solarisx8632-target
245(progn
246  (defconstant gp-regs-offset 0)
247  (defmacro xp-gp-regs (xp)
248    `(pref (pref ,xp :ucontext.uc_mcontext) :mcontext_t.gregs))
249  (defun xp-mxcsr (xp)
250    (pref xp :ucontext.uc_mcontext.fpregs.fp_reg_set.fpchip_state.mxcsr))
251  (defconstant flags-register-offset #$EFL)
252  (defmacro xp-xmm-regs (xp)
253    `(pref ,xp :ucontext.uc_mcontext.fpregs.fp_reg_set.fpchip_state.xmm))
254  (defconstant eip-register-offset #$EIP)
255  (defparameter *encoded-gpr-to-indexed-gpr*
256    (vector
257     #$EAX
258     #$ECX
259     #$EDX
260     #$EBX
261     #$ESP
262     #$EBP
263     #$ESI
264     #$EDI)
265      ))
266
267#+freebsdx8632-target
268(progn
269  (defconstant gp-regs-offset 0)
270  (defmacro xp-gp-regs (xp)
271    `(pref ,xp :ucontext_t.uc_mcontext))
272  (defun xp-mxcsr (xp)
273    (pref (pref xp :ucontext_t.uc_mcontext.mc_fpstate) :savexmm.sv_env.en_mxcsr))
274  (defmacro xp-xmm-regs (xp)
275    `(pref (pref ,xp :ucontext_t.uc_mcontext.mc_fpstate) :savexmm.sv_xmm))
276  (defconstant flags-register-offset 17)
277  (defconstant eip-register-offset 15)
278  (defparameter *encoded-gpr-to-indexed-gpr*
279    #(
280      12                                ;eax
281      11                                ;ecx
282      10                                ;edx
283      9                                 ;ebx
284      18                                ;esp
285      7                                 ;ebp
286      6                                 ;esi
287      5                                 ;edi
288      )
289      ))
290
291(defun indexed-gpr-lisp (xp igpr)
292  (%get-object (xp-gp-regs xp) (+ gp-regs-offset (ash igpr target::word-shift))))
293(defun (setf indexed-gpr-lisp) (new xp igpr)
294  (%set-object (xp-gp-regs xp) (+ gp-regs-offset (ash igpr target::word-shift)) new))
295(defun encoded-gpr-lisp (xp gpr)
296  (indexed-gpr-lisp xp (aref *encoded-gpr-to-indexed-gpr* gpr)))
297(defun (setf encoded-gpr-lisp) (new xp gpr)
298  (setf (indexed-gpr-lisp xp (aref *encoded-gpr-to-indexed-gpr* gpr)) new))
299(defun indexed-gpr-integer (xp igpr)
300  #+x8664-target
301  (%get-signed-long-long (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8664::word-shift)))
302  #+x8632-target
303  (%get-signed-long (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8632::word-shift))))
304(defun (setf indexed-gpr-integer) (new xp igpr)
305  (setf
306   #+x8664-target
307   (%get-signed-long-long (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8664::word-shift)))
308   #+x8632-target
309   (%get-signed-long (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8632::word-shift)))
310   new))
311(defun encoded-gpr-integer (xp gpr)
312  (indexed-gpr-integer xp (aref *encoded-gpr-to-indexed-gpr* gpr)))
313(defun (setf encoded-gpr-integer) (new xp gpr)
314  (setf (indexed-gpr-integer xp (aref *encoded-gpr-to-indexed-gpr* gpr)) new))
315(defun indexed-gpr-macptr (xp igpr)
316  (%get-ptr (xp-gp-regs xp) (+ gp-regs-offset (ash igpr target::word-shift))))
317(defun (setf indexed-gpr-macptr) (new xp igpr)
318  (setf (%get-ptr (xp-gp-regs xp) (+ gp-regs-offset (ash igpr target::word-shift))) new))
319(defun encoded-gpr-macptr (xp gpr)
320  (indexed-gpr-macptr xp (aref *encoded-gpr-to-indexed-gpr* gpr)))
321(defun (setf encoded-gpr-macptr) (new xp gpr)
322  (setf (indexed-gpr-macptr xp (aref *encoded-gpr-to-indexed-gpr* gpr)) new))
323(defun xp-flags-register (xp)
324  #+windows-target (pref xp #>CONTEXT.EFlags)
325  #-windows-target
326  (progn
327  #+x8664-target
328  (%get-signed-long-long (xp-gp-regs xp) (+ gp-regs-offset (ash flags-register-offset x8664::fixnumshift)))
329  #+x8632-target
330  (%get-signed-long (xp-gp-regs xp) (+ gp-regs-offset (ash flags-register-offset x8632::fixnumshift)))))
331(defmacro xp-xmm-single-float (xp n)
332  `(%get-single-float (xp-xmm-regs ,xp) (ash ,n 4)))
333(defmacro xp-xmm-double-float (xp n)
334  `(%get-double-float (xp-xmm-regs ,xp) (ash ,n 4)))
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      (let* ((high-half (%get-object xcf-ptr target::xcf.pc-high))
344             (low-half (%get-object xcf-ptr target::xcf.pc-low))
345             (pc #+64-bit-target (dpb high-half (byte 32 32) low-half)
346                 #+32-bit-target (dpb high-half (byte 16 16) low-half)))
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           (if (and (zerop code)
470                    (eql other arch::error-allocation-disabled))
471             (restart-case (%error 'allocation-disabled nil frame-ptr)
472                           (continue ()
473                                     :report (lambda (stream)
474                                               (format stream "retry the heap allocation."))))
475             (%err-disp-internal code () frame-ptr)))
476          ((= signal #$SIGFPE)
477           (setq code (logand #xffffffff code))
478           (multiple-value-bind (operation operands)
479               (decode-arithmetic-error xp xcf)
480             (let* ((condition-name
481                     (cond ((or (= code integer-divide-by-zero-code)
482                                (= code float-divide-by-zero-code))
483                            'division-by-zero)
484                           ((= code float-overflow-code)
485                            'floating-point-overflow)
486                           ((= code float-underflow-code)
487                            'floating-point-underflow)
488                           ((= code float-inexact-code)
489                            'floating-point-inexact)
490                           (t
491                            'floating-point-invalid-operation))))
492               (%error (make-condition condition-name
493                                       :operation operation
494                                       :operands operands
495                                       :status (xp-mxcsr xp))
496                       ()
497                       frame-ptr))))
498          ((= signal #$SIGSEGV)
499           (cond
500             ((or (= code 0) (= code 1))
501              ;; Stack overflow.
502              (let* ((on-tsp (= code 1)))
503                (unwind-protect
504                     (%error
505                      (make-condition
506                       'stack-overflow-condition 
507                       :format-control "Stack overflow on ~a stack."
508                       :format-arguments (list (if on-tsp "temp" "value")))
509                      nil frame-ptr)
510                  (ff-call (%kernel-import target::kernel-import-restore-soft-stack-limit)
511                           :unsigned-fullword code
512                           :void))))
513             ((= code 2)
514              ;; Write to a watched object.
515              (let* ((offset other)
516                     ;; The kernel exception handler leaves the
517                     ;; watched object on the lisp stack under the
518                     ;; xcf.
519                     (object (%get-object xcf target::xcf.size)))
520                (multiple-value-bind (insn insn-length)
521                    (ignore-errors (x86-faulting-instruction xp))
522                  (restart-case (%error (make-condition
523                                         'write-to-watched-object
524                                         :offset offset
525                                         :object object
526                                         :instruction insn)
527                                        nil frame-ptr)
528                                #-windows-target
529                                (emulate ()
530                                         :test (lambda (c)
531                                                 (declare (ignore c))
532                                                 (x86-can-emulate-instruction insn))
533                                         :report
534                                         "Emulate this instruction, leaving the object watched."
535                                         (flet ((watchedp (object)
536                                                  (%map-areas #'(lambda (x)
537                                                                  (when (eq object x)
538                                                                    (return-from watchedp t)))
539                                                              area-watched)))
540                                           (let ((result nil))
541                                             (with-other-threads-suspended
542                                                 (when (watchedp object)
543                                                   ;; We now trust that the object is in a
544                                                   ;; static gc area.
545                                                   (let* ((a (+ (%address-of object) offset))
546                                                          (ptr (%int-to-ptr
547                                                                (logandc2 a (1- *host-page-size*)))))
548                                                     (#_mprotect ptr *host-page-size* #$PROT_WRITE)
549                                                     (setq result (x86-emulate-instruction xp insn))
550                                                     (#_mprotect ptr *host-page-size*
551                                                                 (logior #$PROT_READ #$PROT_EXEC)))))
552                                             (if result
553                                               (setq skip insn-length)
554                                               (error "could not emulate the instrution")))))
555                                (skip ()
556                                      :test (lambda (c)
557                                              (declare (ignore c))
558                                              insn)
559                                      :report "Skip over this write instruction."
560                                      (setq skip insn-length))
561                                (unwatch ()
562                                         :report "Unwatch the object and retry the write."
563                                         (unwatch object))))))))
564          ((= signal #+win32-target 10 #-win32-target #$SIGBUS)
565           (if (= code -1)
566             (%error (make-condition 'invalid-memory-operation)
567                     ()
568                     frame-ptr)
569             (%error (make-condition 'invalid-memory-access
570                                     :address addr
571                                     :write-p (not (zerop code)))
572                     ()
573                     frame-ptr)))
574          ((= signal #-win32-target #$SIGTRAP #+win32-target 5)
575           (when (= code 0)
576             (let* ((hook *pending-gc-notification-hook*))
577               (declare (special *pending-gc-notification-hook*))
578               (when hook (funcall hook))))))
579    skip))
580
581(defun x86-faulting-instruction (xp)
582  (let* ((code-bytes (make-array 15 :element-type '(unsigned-byte 8)))
583         (pc (indexed-gpr-macptr xp #+x8632-target eip-register-offset
584                                    #+x8664-target rip-register-offset)))
585    (dotimes (i (length code-bytes))
586      (setf (aref code-bytes i) (%get-unsigned-byte pc i)))
587    (let* ((ds (make-x86-disassembly-state
588                :mode-64 #+x8664-target t #+x8632-target nil
589                :code-vector code-bytes
590                :code-pointer 0))
591           (insn (x86-disassemble-instruction ds nil))
592           (len (- (x86-ds-code-pointer ds) (x86-ds-insn-start ds))))
593      (values insn len))))
Note: See TracBrowser for help on using the repository browser.