/[cmucl]/src/code/x86-vm.lisp
ViewVC logotype

Diff of /src/code/x86-vm.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.28 by rtoy, Wed Nov 14 17:44:07 2007 UTC revision 1.29 by cshapiro, Thu Jan 3 11:41:52 2008 UTC
# Line 31  Line 31 
31    
32    
33  ;;;; The sigcontext structure.  ;;;; The sigcontext structure.
 ;;;; Add machine specific features to *features*  
34    
35  (pushnew :x86 *features*)  (def-alien-type sigcontext system-area-pointer)
36    
37    ;;;; Add machine specific features to *features*
38    
39  #+linux  (pushnew :x86 *features*)
 (def-alien-type nil  
   (struct fpreg  
           (significand (array unsigned-short 4))  
           (exponent unsigned-short)))  
 #+linux  
 (def-alien-type  nil  
    (struct fpstate  
         (cw  unsigned-long)  
         (sw  unsigned-long)  
         (tag  unsigned-long)  
         (ipoff  unsigned-long)  
         (cssel  unsigned-long)  
         (dataoff  unsigned-long)  
         (datasel unsigned-long)  
         (fpreg (array (struct fpreg) 8))  
         (status unsigned-long)))  
   
 #+darwin  
 (def-alien-type sigcontext-regs  
   (struct nil  
     (trapno unsigned-int)  
     (err unsigned-int)  
     (faultvaddr unsigned-int)  
     (eax unsigned-int)  
     (ebx unsigned-int)  
     (ecx unsigned-int)  
     (edx unsigned-int)  
     (edi unsigned-int)  
     (esi unsigned-int)  
     (ebp unsigned-int)  
     (esp unsigned-int)  
     (ss unsigned-int)  
     (eflags unsigned-int)  
     (eip unsigned-int)  
     (cs unsigned-int)  
     (ds unsigned-int)  
     (es unsigned-int)  
     (fs unsigned-int)  
     (gs unsigned-int)  
     (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  
 #+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  
 (def-alien-type sigcontext  
   (struct nil  
     (sc-sigmask (array unsigned-int 4))  
     (sc-mcontext sigcontext-regs)))  
   
 ;;; OpenBSD also have sigcontext structs that look more like Linux.  
 #+openbsd  
 (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)  
         (sc-mask    unsigned-int)  
         (sc-trapno  unsigned-int)  
         (sc-err     unsigned-int)  
         ))  
   
 ;; NetBSD  
 #+netbsd  
 (def-alien-type sigcontext-regs  
   (struct nil  
     (gs unsigned-long)  
     (fs unsigned-long)  
     (es unsigned-long)  
     (ds unsigned-long)  
     (edi unsigned-long)  
     (esi unsigned-long)  
     (ebp unsigned-long)  
     (esp unsigned-long)  
     (ebx unsigned-long)  
     (edx unsigned-long)  
     (ecx unsigned-long)  
     (eax unsigned-long)  
     (trapno unsigned-long)  
     (err unsigned-long)  
     (eip unsigned-long)  
     (cs unsigned-long)  
     (efl unsigned-long)  
     (uesp unsigned-long)  
     (ss unsigned-long)))  
   
 #+netbsd  
 (def-alien-type sigcontext  
   (struct nil  
     (sc-flags unsigned-long)  
     (sc-link system-area-pointer)  
     (sc-sigmask (array unsigned-long 4))  
     (sc-stack (array unsigned-long 3))  
     (sc-mcontext sigcontext-regs)))  
   
 ;; For Linux...  
 #+linux  
 (def-alien-type sigcontext-regs  
   (struct nil  
     (gs unsigned-long)  
     (fs unsigned-long)  
     (es unsigned-long)  
     (ds unsigned-long)  
     (edi unsigned-long)  
     (esi unsigned-long)  
     (ebp unsigned-long)  
     (esp unsigned-long)  
     (ebx unsigned-long)  
     (edx unsigned-long)  
     (ecx unsigned-long)  
     (eax unsigned-long)  
     (trapno unsigned-long)  
     (err unsigned-long)  
     (eip unsigned-long)  
     (cs unsigned-long)  
     (eflags unsigned-long)  
     (esp_at_signal unsigned-long)  
     (ss unsigned-long)  
     (fpstate (* (struct fpstate)))  
     (oldmask 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)))  
40    
41    
42  ;;;; MACHINE-TYPE and MACHINE-VERSION  ;;;; MACHINE-TYPE and MACHINE-VERSION
# Line 380  Line 204 
204  ;;;  ;;;
205  (defun sigcontext-program-counter (scp)  (defun sigcontext-program-counter (scp)
206    (declare (type (alien (* sigcontext)) scp))    (declare (type (alien (* sigcontext)) scp))
207    (with-alien ((scp (* sigcontext) scp))    (let ((fn (extern-alien "os_sigcontext_pc"
208      (int-sap (slot (slot scp 'sc-mcontext) 'eip))))                            (function system-area-pointer
209                                        (* sigcontext)))))
210        (sap-ref-sap (alien-funcall fn scp) 0)))
211    
212  ;;; SIGCONTEXT-REGISTER -- Interface.  ;;; SIGCONTEXT-REGISTER -- Interface.
213  ;;;  ;;;
# Line 390  Line 216 
216  ;;;  ;;;
217  (defun sigcontext-register (scp index)  (defun sigcontext-register (scp index)
218    (declare (type (alien (* sigcontext)) scp))    (declare (type (alien (* sigcontext)) scp))
219    (with-alien ((scp (* sigcontext) scp))    (let ((fn (extern-alien "os_sigcontext_reg"
220      (case index                            (function system-area-pointer
221        (#.eax-offset (slot (slot scp 'sc-mcontext) 'eax))                                      (* sigcontext)
222        (#.ecx-offset (slot (slot scp 'sc-mcontext) 'ecx))                                      (integer 32)))))
223        (#.edx-offset (slot (slot scp 'sc-mcontext) 'edx))      (sap-ref-32 (alien-funcall fn scp index) 0)))
       (#.ebx-offset (slot (slot scp 'sc-mcontext) 'ebx))  
       (#.esp-offset (slot (slot scp 'sc-mcontext) 'esp))  
       (#.ebp-offset (slot (slot scp 'sc-mcontext) 'ebp))  
       (#.esi-offset (slot (slot scp 'sc-mcontext) 'esi))  
       (#.edi-offset (slot (slot scp 'sc-mcontext) 'edi)))))  
224    
225  (defun %set-sigcontext-register (scp index new)  (defun %set-sigcontext-register (scp index new)
226    (declare (type (alien (* sigcontext)) scp))    (declare (type (alien (* sigcontext)) scp))
227    (with-alien ((scp (* sigcontext) scp))    (let ((fn (extern-alien "os_sigcontext_reg"
228      (case index                            (function system-area-pointer
229        (#.eax-offset (setf (slot (slot scp 'sc-mcontext) 'eax) new))                                      (* sigcontext)
230        (#.ecx-offset (setf (slot (slot scp 'sc-mcontext) 'ecx) new))                                      (integer 32)))))
231        (#.edx-offset (setf (slot (slot scp 'sc-mcontext) 'edx) new))      (setf (sap-ref-32 (alien-funcall fn scp index) 0) new)))
       (#.ebx-offset (setf (slot (slot scp 'sc-mcontext) 'ebx) new))  
       (#.esp-offset (setf (slot (slot scp 'sc-mcontext) 'esp) new))  
       (#.ebp-offset (setf (slot (slot scp 'sc-mcontext) 'ebp) new))  
       (#.esi-offset (setf (slot (slot scp 'sc-mcontext) 'esi) new))  
       (#.edi-offset (setf (slot (slot scp 'sc-mcontext) 'edi) new))))  
   new)  
232    
233  (defsetf sigcontext-register %set-sigcontext-register)  (defsetf sigcontext-register %set-sigcontext-register)
234    
# Line 423  Line 238 
238  ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.  ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.
239  ;;; Format is the type of float to return.  ;;; Format is the type of float to return.
240  ;;;  ;;;
 #+linux  
241  (defun sigcontext-float-register (scp index format)  (defun sigcontext-float-register (scp index format)
242    (declare (type (alien (* sigcontext)) scp))    (declare (type (alien (* sigcontext)) scp))
243    (with-alien ((scp (* sigcontext) scp))    (let ((fn (extern-alien "os_sigcontext_fpu_reg"
244      (let ((reg-sap (alien-sap (deref (slot (deref (slot (slot scp 'sc-mcontext) 'fpstate) 0)                            (function system-area-pointer
245                                             'fpreg)                                      (* sigcontext)
246                                       index))))                                      (integer 32)))))
247        (coerce (sys:sap-ref-long reg-sap 0) format))))      (coerce (sap-ref-long (alien-funcall fn scp index) 0) format)))
248    ;;;
249  ;;; Not supported on Free/OpenBSD because the floating point state is not  (defun %set-sigcontext-float-register (scp index format new)
250  ;;; saved.  For now we assume this is true for all modern BSDs    (declare (type (alien (* sigcontext)) scp))
251  #+BSD    (let ((fn (extern-alien "os_sigcontext_fpu_reg"
252  (defun sigcontext-float-register (scp index format)                            (function system-area-pointer
253    (declare (ignore scp index))                                      (* sigcontext)
254    (coerce 0l0 format))                                      (integer 32)))))
255        (let* ((sap (alien-funcall fn scp index))
256  #+linux             (result (setf (sap-ref-long sap 0) (coerce new 'long-float))))
257  (defun %set-sigcontext-float-register (scp index format new-value)        (coerce result format))))
   (declare (type (alien (* sigcontext)) scp))  
   (with-alien ((scp (* sigcontext) scp))  
     (let ((reg-sap (alien-sap (deref (slot (deref (slot (slot scp 'sc-mcontext) 'fpstate) 0)  
                                             'fpreg)  
                                      index))))  
       (declare (ignorable reg-sap))  
       #+not-yet  
       (setf (sys:sap-ref-long reg-sap 0) (coerce new-value 'long-float))  
       (coerce new-value format))))  
   
 ;;; Not supported on Free/OpenBSD.  
 #+BSD  
 (defun %set-sigcontext-float-register (scp index format new-value)  
   (declare (ignore scp index))  
   (coerce new-value format))  
   
258  ;;;  ;;;
259  (defsetf sigcontext-float-register %set-sigcontext-float-register)  (defsetf sigcontext-float-register %set-sigcontext-float-register)
260    
# Line 465  Line 263 
263  ;;;    Given a sigcontext pointer, return the floating point modes word in the  ;;;    Given a sigcontext pointer, return the floating point modes word in the
264  ;;; same format as returned by FLOATING-POINT-MODES.  ;;; same format as returned by FLOATING-POINT-MODES.
265  ;;;  ;;;
   
 #+bsd  
 (defun sigcontext-floating-point-modes (scp)  
   (declare (type (alien (* sigcontext)) scp)  
            (ignore scp))  
   ;; This is broken until some future release of FreeBSD/OpenBSD!!!  
   (floating-point-modes))  
   
 #+linux  
266  (defun sigcontext-floating-point-modes (scp)  (defun sigcontext-floating-point-modes (scp)
267    (declare (type (alien (* sigcontext)) scp))    (declare (type (alien (* sigcontext)) scp))
268    (let ((cw (slot (deref (slot (slot scp 'sc-mcontext) 'fpstate) 0) 'cw))    (let ((fn (extern-alien "os_sigcontext_fpu_modes"
269          (sw (slot (deref (slot (slot scp 'sc-mcontext) 'fpstate) 0) 'sw)))                            (function (integer 32)
270      ;;(format t "cw = ~4x~%sw = ~4x~%" cw sw)                                      (* sigcontext)))))
271      ;; NOT TESTED -- clear sticky bits to clear interrupt condition      (alien-funcall fn scp)))
     (setf (slot (deref (slot (slot scp 'sc-mcontext) 'fpstate) 0) 'sw) (logandc2 sw #x3f))  
     ;;(format t "new sw = ~x~%" (slot (deref (slot (slot scp 'sc-mcontext) 'fpstate) 0) 'sw))  
     ;; simulate floating-point-modes VOP  
     (logior (ash (logand sw #xffff) 16) (logxor (logand cw #xffff) #x3f))))  
272    
273    
274  ;;; EXTERN-ALIEN-NAME -- interface.  ;;; EXTERN-ALIEN-NAME -- interface.

Legend:
Removed from v.1.28  
changed lines
  Added in v.1.29

  ViewVC Help
Powered by ViewVC 1.1.5