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

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

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

revision 1.7 by ram, Fri Feb 8 13:34:42 1991 UTC revision 1.7.1.1 by wlott, Fri Jan 24 04:35:54 1992 UTC
# Line 17  Line 17 
17  ;;;  ;;;
18  (in-package "MIPS")  (in-package "MIPS")
19  (use-package "SYSTEM")  (use-package "SYSTEM")
20    (use-package "ALIEN")
21    (use-package "C-CALL")
22    (use-package "UNIX")
23    
24    (export '(fixup-code-object internal-error-arguments
25              sigcontext-register sigcontext-float-register
26              sigcontext-floating-point-modes))
27    
28    
29    ;;;; The sigcontext structure.
30    
31    (def-alien-type sigcontext
32      (struct nil
33        (sc-onstack unsigned-long)
34        (sc-mask unsigned-long)
35        (sc-pc system-area-pointer)
36        (sc-regs (array unsigned-long 32))
37        (sc-mdlo unsigned-long)
38        (sc-mdhi unsigned-long)
39        (sc-ownedfp unsigned-long)
40        (sc-fpregs (array unsigned-long 32))
41        (sc-fpc-csr unsigned-long)
42        (sc-fpc-eir unsigned-long)
43        (sc-cause unsigned-long)
44        (sc-badvaddr system-area-pointer)
45        (sc-badpaddr system-area-pointer)))
46    
 (export '(fixup-code-object internal-error-arguments))  
47    
48    
49  ;;;; Add machine specific features to *features*  ;;;; Add machine specific features to *features*
# Line 63  Line 88 
88            (setf (sap-ref-16 sap (* word-offset 2))            (setf (sap-ref-16 sap (* word-offset 2))
89                  (ldb (byte 16 0) fixup))))))))                  (ldb (byte 16 0) fixup))))))))
90    
   
   
91    
92  ;;;; Internal-error-arguments.  ;;;; Internal-error-arguments.
93    
# Line 73  Line 96 
96  ;;; Given the sigcontext, extract the internal error arguments from the  ;;; Given the sigcontext, extract the internal error arguments from the
97  ;;; instruction stream.  ;;; instruction stream.
98  ;;;  ;;;
99  (defun internal-error-arguments (sc)  (defun internal-error-arguments (scp)
100    (alien-bind ((sc sc mach:sigcontext t))    (declare (type (alien (* sigcontext)) scp))
101      (let ((pc (alien-access (mach:sigcontext-pc (alien-value sc)))))    (with-alien ((scp (* sigcontext) scp))
102        (let ((pc (slot scp 'sc-pc)))
103        (declare (type system-area-pointer pc))        (declare (type system-area-pointer pc))
104        (when (logbitp 31        (when (logbitp 31 (slot scp 'sc-cause))
                      (alien-access (mach:sigcontext-cause (alien-value sc))))  
105          (setf pc (sap+ pc 4)))          (setf pc (sap+ pc 4)))
106        (when (= (sap-ref-8 pc 4) 255)        (when (= (sap-ref-8 pc 4) 255)
107          (setf pc (sap+ pc 1)))          (setf pc (sap+ pc 1)))
# Line 100  Line 123 
123              (values error-number (sc-offsets))))))))              (values error-number (sc-offsets))))))))
124    
125    
126    ;;;; Sigcontext access functions.
127    
128    ;;; SIGCONTEXT-REGISTER -- Internal.
129    ;;;
130    ;;; An escape register saves the value of a register for a frame that someone
131    ;;; interrupts.
132    ;;;
133    (defun sigcontext-register (scp index)
134      (declare (type (alien (* sigcontext)) scp))
135      (with-alien ((scp (* sigcontext) scp))
136        (deref (slot scp 'sc-regs) index)))
137    
138    (defun %set-sigcontext-register (scp index new)
139      (declare (type (alien (* sigcontext)) scp))
140      (with-alien ((scp (* sigcontext) scp))
141        (setf (deref (slot scp 'sc-regs) index) new)
142        new))
143    
144    (defsetf sigcontext-register %set-sigcontext-register)
145    
146    
147    ;;; SIGCONTEXT-FLOAT-REGISTER  --  Internal
148    ;;;
149    ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.
150    ;;; Format is the type of float to return.
151    ;;;
152    (defun sigcontext-float-register (scp index format)
153      (declare (type (alien (* sigcontext)) scp))
154      (with-alien ((scp (* sigcontext) scp))
155        (let ((sap (alien-sap (slot scp 'sc-fpregs))))
156          (ecase format
157            (single-float (system:sap-ref-single sap index))
158            (double-float (system:sap-ref-double sap index))))))
159    ;;;
160    (defun %set-sigcontext-float-register (scp index format new-value)
161      (declare (type (alien (* sigcontext)) scp))
162      (with-alien ((scp (* sigcontext) scp))
163        (let ((sap (alien-sap (slot scp 'sc-fpregs))))
164          (ecase format
165            (single-float
166             (setf (sap-ref-single sap index) new-value))
167            (double-float
168             (setf (sap-ref-double sap index) new-value))))))
169    ;;;
170    (defsetf sigcontext-float-register %set-sigcontext-float-register)
171    
172    
173  ;;; SIGCONTEXT-FLOATING-POINT-MODES  --  Interface  ;;; SIGCONTEXT-FLOATING-POINT-MODES  --  Interface
174  ;;;  ;;;
175  ;;;    Given a sigcontext pointer, return the floating point modes word in the  ;;;    Given a sigcontext pointer, return the floating point modes word in the
176  ;;; same format as returned by FLOATING-POINT-MODES.  ;;; same format as returned by FLOATING-POINT-MODES.
177  ;;;  ;;;
178  (defun sigcontext-floating-point-modes (scp)  (defun sigcontext-floating-point-modes (scp)
179    (alien-bind ((sc (make-alien 'mach:sigcontext    (declare (type (alien (* sigcontext)) scp))
180                                               #.(ext:c-sizeof 'mach:sigcontext)     (with-alien ((scp (* sigcontext) scp))
181                                               scp)      (slot scp 'sc-fpc-csr)))
                           mach:sigcontext  
                           t))  
     (alien-access (mach:sigcontext-fpc_csr (alien-value sc)))))  

Legend:
Removed from v.1.7  
changed lines
  Added in v.1.7.1.1

  ViewVC Help
Powered by ViewVC 1.1.5