Skip to content
Snippets Groups Projects
Commit 84a8690a authored by cshapiro's avatar cshapiro
Browse files

Always pass the whole ucontext_t into Lisp. Update the x86 sigcontext

definitions accordingly.
parent 6bf5be87
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/x86-vm.lisp,v 1.26 2007/07/22 05:39:39 cshapiro Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/x86-vm.lisp,v 1.27 2007/09/04 10:22:54 cshapiro Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -56,56 +56,69 @@ ...@@ -56,56 +56,69 @@
(status unsigned-long))) (status unsigned-long)))
#+darwin #+darwin
(def-alien-type sigcontext (def-alien-type sigcontext-regs
(struct nil (struct nil
;; x86_exception_state32_t
(trapno unsigned-int) (trapno unsigned-int)
(err unsigned-int) (err unsigned-int)
(faultvaddr unsigned-int) (faultvaddr unsigned-int)
;; x86_thread_state32_t (eax unsigned-int)
(sc-eax unsigned-int) (ebx unsigned-int)
(sc-ebx unsigned-int) (ecx unsigned-int)
(sc-ecx unsigned-int) (edx unsigned-int)
(sc-edx unsigned-int) (edi unsigned-int)
(sc-edi unsigned-int) (esi unsigned-int)
(sc-esi unsigned-int) (ebp unsigned-int)
(sc-fp unsigned-int) (esp unsigned-int)
(sc-sp unsigned-int)
(ss unsigned-int) (ss unsigned-int)
(eflags unsigned-int) (eflags unsigned-int)
(sc-pc unsigned-int) (eip unsigned-int)
(cs unsigned-int) (cs unsigned-int)
(ds unsigned-int) (ds unsigned-int)
(es unsigned-int) (es unsigned-int)
(fs unsigned-int) (fs unsigned-int)
(gs unsigned-int) (gs unsigned-int)
;; x86_float_state32_t
(fpstate (array char 512)))) (fpstate (array char 512))))
#+darwin
(def-alien-type sigcontext
(struct nil
(sc-onstack int)
(sc-sigmask unsigned-int)
(sc-stack (array unsigned-int 3))
(sc-link system-area-pointer)
(sc-mcsize unsigned-int)
(sc-mcontext (* sigcontext-regs))))
;;; for FreeBSD ;;; for FreeBSD
#+freebsd
(def-alien-type sigcontext-regs
(struct nil
(onstack unsigned-int)
(gs unsigned-int)
(fs unsigned-int)
(es unsigned-int)
(ds unsigned-int)
(edi unsigned-int)
(esi unsigned-int)
(ebp unsigned-int)
(isp unsigned-int)
(ebx unsigned-int)
(edx unsigned-int)
(ecx unsigned-int)
(eax unsigned-int)
(trapno unsigned-int)
(err unsigned-int)
(eip unsigned-int)
(cs unsigned-int)
(eflags unsigned-int)
(esp unsigned-int)
(ss unsigned-int)))
#+freebsd #+freebsd
(def-alien-type sigcontext (def-alien-type sigcontext
(struct nil (struct nil
(sc-onstack unsigned-int) (sc-sigmask (array unsigned-int 4))
(sc-gs unsigned-int) (sc-mcontext sigcontext-regs)))
(sc-fs unsigned-int)
(sc-es unsigned-int)
(sc-ds unsigned-int)
(sc-edi unsigned-int)
(sc-esi unsigned-int)
(sc-fp unsigned-int)
(sc-isp unsigned-int)
(sc-ebx unsigned-int)
(sc-edx unsigned-int)
(sc-ecx unsigned-int)
(sc-eax unsigned-int)
(trapno unsigned-int)
(err unsigned-int)
(sc-pc unsigned-int)
(sc-cs unsigned-int)
(sc-efl unsigned-int) ; sc_ps
(sc-sp unsigned-int)
(sc-ss unsigned-int)))
;;; OpenBSD also have sigcontext structs that look more like Linux. ;;; OpenBSD also have sigcontext structs that look more like Linux.
#+openbsd #+openbsd
...@@ -134,109 +147,72 @@ ...@@ -134,109 +147,72 @@
)) ))
;; NetBSD ;; NetBSD
#+netbsd1.6
(def-alien-type sigcontext
(struct nil
(sc-gs unsigned-int)
(sc-fs unsigned-int)
(sc-es unsigned-int)
(sc-ds unsigned-int)
(sc-edi unsigned-int)
(sc-esi unsigned-int)
(sc-fp unsigned-int) ;; ebp
(sc-ebx unsigned-int)
(sc-edx unsigned-int)
(sc-ecx unsigned-int)
(sc-eax unsigned-int)
(sc-pc unsigned-int)
(sc-cs unsigned-int)
(sc-efl unsigned-int) ; sc_ps
(sc-sp unsigned-int)
(sc-ss unsigned-int)
(sc-onstack unsigned-int)
;; Old NetBSD 1.3 signal mask
(sc-oldmask unsigned-int)
(sc-trapno unsigned-int)
(sc-err unsigned-int)
;; New signal mask (post NetBSD 1.3)
(sc-mask (array unsigned-int 4))
))
#+netbsd
(def-alien-type sigaltstack
(struct nil
(ss-sp unsigned-int)
(ss-size unsigned-int)
(ss-flags unsigned-int)))
#+netbsd #+netbsd
(def-alien-type mcontext (def-alien-type sigcontext-regs
(struct nil (struct nil
(mc-gs unsigned-long) (gs unsigned-long)
(mc-fs unsigned-long) (fs unsigned-long)
(mc-es unsigned-long) (es unsigned-long)
(mc-ds unsigned-long) (ds unsigned-long)
(mc-edi unsigned-long) (edi unsigned-long)
(mc-esi unsigned-long) (esi unsigned-long)
(mc-ebp unsigned-long) (ebp unsigned-long)
(mc-esp unsigned-long) (esp unsigned-long)
(mc-ebx unsigned-long) (ebx unsigned-long)
(mc-edx unsigned-long) (edx unsigned-long)
(mc-ecx unsigned-long) (ecx unsigned-long)
(mc-eax unsigned-long) (eax unsigned-long)
(mc-trapno unsigned-long) (trapno unsigned-long)
(mc-err unsigned-long) (err unsigned-long)
(mc-eip unsigned-long) (eip unsigned-long)
(mc-cs unsigned-long) (cs unsigned-long)
(mc-efl unsigned-long) (efl unsigned-long)
(mc-uesp unsigned-long) (uesp unsigned-long)
(mc-ss unsigned-long))) (ss unsigned-long)))
#+netbsd #+netbsd
(def-alien-type sigcontext (def-alien-type sigcontext
(struct nil (struct nil
(uc-flags unsigned-long) (sc-flags unsigned-long)
(uc-link unsigned-long) (sc-link system-area-pointer)
(uc-sigmask (array unsigned-long 4)) (sc-sigmask (array unsigned-long 4))
(uc-stack sigaltstack) (sc-stack (array unsigned-long 3))
(uc-mcontext mcontext))) (sc-mcontext sigcontext-regs)))
;; For Linux... ;; For Linux...
#+linux #+linux
(def-alien-type sigcontext (def-alien-type sigcontext-regs
(struct nil (struct nil
(gs unsigned-short) (gs unsigned-long)
(__gsh unsigned-short) (fs unsigned-long)
(fs unsigned-short) (es unsigned-long)
(__fsh unsigned-short) (ds unsigned-long)
(sc-es unsigned-short) (edi unsigned-long)
(__esh unsigned-short) (esi unsigned-long)
(sc-ds unsigned-short) (ebp unsigned-long)
(__dsh unsigned-short) (esp unsigned-long)
(sc-edi unsigned-long) (ebx unsigned-long)
(sc-esi unsigned-long) (edx unsigned-long)
(ebp unsigned-long) (ecx unsigned-long)
(sc-sp unsigned-long) (eax unsigned-long)
(sc-ebx unsigned-long) (trapno unsigned-long)
(sc-edx unsigned-long) (err unsigned-long)
(sc-ecx unsigned-long) (eip unsigned-long)
(sc-eax unsigned-long) (cs unsigned-long)
(trapno unsigned-long) (eflags unsigned-long)
(err unsigned-long) (esp_at_signal unsigned-long)
(sc-pc unsigned-long) (ss unsigned-long)
(sc-cs unsigned-short) (fpstate (* (struct ftpstate)))
(__csh unsigned-short) (oldmask unsigned-long)
(sc-efl unsigned-long) (cr2 unsigned-long)))
(esp_at_signal unsigned-long)
(sc-ss unsigned-short)
(__ssh unsigned-short)
; (fpstate unsigned-long) ;; fpstate struct pointer
(fpstate (* (struct fpstate)))
(sc-mask unsigned-long)
(cr2 unsigned-long)))
#+linux
(def-alien-type sigcontext
(struct nil
(sc-flags unsigned-long)
(sc-link system-area-pointer)
(sc-stack (array unsigned-long 3))
(sc-mcontext sigcontext-regs)))
;;;; MACHINE-TYPE and MACHINE-VERSION ;;;; MACHINE-TYPE and MACHINE-VERSION
...@@ -374,11 +350,10 @@ ...@@ -374,11 +350,10 @@
;;; Given the sigcontext, extract the internal error arguments from the ;;; Given the sigcontext, extract the internal error arguments from the
;;; instruction stream. ;;; instruction stream.
;;; ;;;
#-netbsd
(defun internal-error-arguments (scp) (defun internal-error-arguments (scp)
(declare (type (alien (* sigcontext)) scp)) (declare (type (alien (* sigcontext)) scp))
(with-alien ((scp (* sigcontext) scp)) (with-alien ((scp (* sigcontext) scp))
(let ((pc (int-sap (slot scp 'sc-pc)))) (let ((pc (sigcontext-program-counter scp)))
(declare (type system-area-pointer pc)) (declare (type system-area-pointer pc))
;; using INT3 the pc is .. INT3 <here> code length bytes... ;; using INT3 the pc is .. INT3 <here> code length bytes...
(let* ((length (sap-ref-8 pc 1)) (let* ((length (sap-ref-8 pc 1))
...@@ -398,108 +373,46 @@ ...@@ -398,108 +373,46 @@
(sc-offsets (c::read-var-integer vector index))) (sc-offsets (c::read-var-integer vector index)))
(values error-number (sc-offsets)))))))) (values error-number (sc-offsets))))))))
#+netbsd
(defun internal-error-arguments (ucp)
(declare (type (alien (* sigcontext)) ucp))
(with-alien ((mcp (* mcontext) (slot ucp 'uc-mcontext)))
(let ((pc (int-sap (slot mcp 'mc-eip))))
(declare (type system-area-pointer pc))
;; using INT3 the pc is .. INT3 <here> code length bytes...
(let* ((length (sap-ref-8 pc 1))
(vector (make-array length :element-type '(unsigned-byte 8))))
(declare (type (unsigned-byte 8) length)
(type (simple-array (unsigned-byte 8) (*)) vector))
(copy-from-system-area pc (* vm:byte-bits 2)
vector (* vm:word-bits
vm:vector-data-offset)
(* length vm:byte-bits))
(let* ((index 0)
(error-number (c::read-var-integer vector index)))
(collect ((sc-offsets))
(loop
(when (>= index length)
(return))
(sc-offsets (c::read-var-integer vector index)))
(values error-number (sc-offsets))))))))
;;;; Sigcontext access functions. ;;;; Sigcontext access functions.
;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface. ;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface.
;;; ;;;
#-netbsd
(defun sigcontext-program-counter (scp) (defun sigcontext-program-counter (scp)
(declare (type (alien (* sigcontext)) scp)) (declare (type (alien (* sigcontext)) scp))
(with-alien ((scp (* sigcontext) scp)) (with-alien ((scp (* sigcontext) scp))
(int-sap (slot scp 'sc-pc)))) (int-sap (slot (slot scp 'sc-mcontext) 'eip))))
#+netbsd
(defun sigcontext-program-counter (ucp)
(declare (type (alien (* sigcontext)) ucp))
(with-alien ((mcp (* mcontext) (slot ucp 'uc-mcontext)))
(int-sap (slot mcp 'sc-eip))))
;;; SIGCONTEXT-REGISTER -- Interface. ;;; SIGCONTEXT-REGISTER -- Interface.
;;; ;;;
;;; An escape register saves the value of a register for a frame that someone ;;; An escape register saves the value of a register for a frame that someone
;;; interrupts. ;;; interrupts.
;;; ;;;
#-netbsd
(defun sigcontext-register (scp index) (defun sigcontext-register (scp index)
(declare (type (alien (* sigcontext)) scp)) (declare (type (alien (* sigcontext)) scp))
(with-alien ((scp (* sigcontext) scp)) (with-alien ((scp (* sigcontext) scp))
(case index ; ugly -- I know. (case index
(#.eax-offset (slot scp 'sc-eax)) (#.eax-offset (slot (slot scp 'sc-mcontext) 'eax))
(#.ecx-offset (slot scp 'sc-ecx)) (#.ecx-offset (slot (slot scp 'sc-mcontext) 'ecx))
(#.edx-offset (slot scp 'sc-edx)) (#.edx-offset (slot (slot scp 'sc-mcontext) 'edx))
(#.ebx-offset (slot scp 'sc-ebx)) (#.ebx-offset (slot (slot scp 'sc-mcontext) 'ebx))
(#.esp-offset (slot scp 'sc-sp)) (#.esp-offset (slot (slot scp 'sc-mcontext) 'esp))
(#.ebp-offset (slot scp #-linux 'sc-fp #+linux 'ebp)) (#.ebp-offset (slot (slot scp 'sc-mcontext) 'ebp))
(#.esi-offset (slot scp 'sc-esi)) (#.esi-offset (slot (slot scp 'sc-mcontext) 'esi))
(#.edi-offset (slot scp 'sc-edi))))) (#.edi-offset (slot (slot scp 'sc-mcontext) 'edi)))))
#-netbsd
(defun %set-sigcontext-register (scp index new) (defun %set-sigcontext-register (scp index new)
(declare (type (alien (* sigcontext)) scp)) (declare (type (alien (* sigcontext)) scp))
(with-alien ((scp (* sigcontext) scp)) (with-alien ((scp (* sigcontext) scp))
(case index (case index
(#.eax-offset (setf (slot scp 'sc-eax) new)) (#.eax-offset (setf (slot (slot scp 'sc-mcontext) 'eax) new))
(#.ecx-offset (setf (slot scp 'sc-ecx) new)) (#.ecx-offset (setf (slot (slot scp 'sc-mcontext) 'ecx) new))
(#.edx-offset (setf (slot scp 'sc-edx) new)) (#.edx-offset (setf (slot (slot scp 'sc-mcontext) 'edx) new))
(#.ebx-offset (setf (slot scp 'sc-ebx) new)) (#.ebx-offset (setf (slot (slot scp 'sc-mcontext) 'ebx) new))
(#.esp-offset (setf (slot scp 'sc-sp) new)) (#.esp-offset (setf (slot (slot scp 'sc-mcontext) 'esp) new))
(#.ebp-offset (setf (slot scp #-linux 'sc-fp #+linux 'ebp) new)) (#.ebp-offset (setf (slot (slot scp 'sc-mcontext) 'ebp) new))
(#.esi-offset (setf (slot scp 'sc-esi) new)) (#.esi-offset (setf (slot (slot scp 'sc-mcontext) 'esi) new))
(#.edi-offset (setf (slot scp 'sc-edi) new)))) (#.edi-offset (setf (slot (slot scp 'sc-mcontext) 'edi) new))))
new)
#+netbsd
(defun sigcontext-register (ucp index)
(declare (type (alien (* sigcontext)) ucp))
(with-alien ((mcp (* mcontext) (slot ucp 'uc-mcontext)))
(case index ; ugly -- I know.
(#.eax-offset (slot mcp 'mc-eax))
(#.ecx-offset (slot mcp 'mc-ecx))
(#.edx-offset (slot mcp 'mc-edx))
(#.ebx-offset (slot mcp 'mc-ebx))
(#.esp-offset (slot mcp 'mc-esp))
(#.ebp-offset (slot mcp 'mc-ebp))
(#.esi-offset (slot mcp 'mc-esi))
(#.edi-offset (slot mcp 'mc-edi)))))
#+netbsd
(defun %set-sigcontext-register (ucp index new)
(declare (type (alien (* sigcontext)) ucp))
(with-alien ((mcp (* mcontext) (slot ucp 'uc-mcontext)))
(case index
(#.eax-offset (setf (slot mcp 'mc-eax) new))
(#.ecx-offset (setf (slot mcp 'mc-ecx) new))
(#.edx-offset (setf (slot mcp 'mc-edx) new))
(#.ebx-offset (setf (slot mcp 'mc-ebx) new))
(#.esp-offset (setf (slot mcp 'mc-esp) new))
(#.ebp-offset (setf (slot mcp 'mc-ebp) new))
(#.esi-offset (setf (slot mcp 'mc-esi) new))
(#.edi-offset (setf (slot mcp 'mc-edi) new))))
new) new)
(defsetf sigcontext-register %set-sigcontext-register) (defsetf sigcontext-register %set-sigcontext-register)
......
/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/interrupt.c,v 1.49 2007/07/25 10:23:54 cshapiro Exp $ */ /* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/interrupt.c,v 1.50 2007/09/04 10:22:54 cshapiro Exp $ */
/* Interrupt handling magic. */ /* Interrupt handling magic. */
...@@ -167,11 +167,7 @@ interrupt_internal_error(HANDLER_ARGS, boolean continuable) ...@@ -167,11 +167,7 @@ interrupt_internal_error(HANDLER_ARGS, boolean continuable)
/* Allocate the SAP object while the interrupts are still disabled. */ /* Allocate the SAP object while the interrupts are still disabled. */
if (internal_errors_enabled) if (internal_errors_enabled)
#if (defined(DARWIN) || defined(__FreeBSD__) || defined(__linux__)) && defined(i386)
context_sap = alloc_sap(&context->uc_mcontext);
#else
context_sap = alloc_sap(context); context_sap = alloc_sap(context);
#endif
sigprocmask(SIG_SETMASK, &context->uc_sigmask, 0); sigprocmask(SIG_SETMASK, &context->uc_sigmask, 0);
...@@ -273,11 +269,7 @@ interrupt_handle_now(HANDLER_ARGS) ...@@ -273,11 +269,7 @@ interrupt_handle_now(HANDLER_ARGS)
else if (LowtagOf(handler.lisp) == type_FunctionPointer) { else if (LowtagOf(handler.lisp) == type_FunctionPointer) {
/* Allocate the SAP object while the interrupts are still /* Allocate the SAP object while the interrupts are still
disabled. */ disabled. */
#if (defined(DARWIN) || defined(__FreeBSD__) || defined(__linux__)) && defined(__i386__)
lispobj context_sap = alloc_sap(&context->uc_mcontext);
#else
lispobj context_sap = alloc_sap(context); lispobj context_sap = alloc_sap(context);
#endif
/* Allow signals again. */ /* Allow signals again. */
sigprocmask(SIG_SETMASK, &context->uc_sigmask, 0); sigprocmask(SIG_SETMASK, &context->uc_sigmask, 0);
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment