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

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

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

revision 1.16 by wlott, Tue Mar 16 13:04:15 1993 UTC revision 1.16.1.1 by ram, Wed Oct 19 23:25:47 1994 UTC
# Line 18  Line 18 
18  (use-package "UNIX")  (use-package "UNIX")
19    
20  (export '(fixup-code-object internal-error-arguments  (export '(fixup-code-object internal-error-arguments
21            sigcontext-program-counter sigcontext-register            s-context-program-counter s-context-register
22            sigcontext-float-register sigcontext-floating-point-modes            s-context-float-register s-context-floating-point-modes
23            extern-alien-name sanctify-for-execution))            extern-alien-name sanctify-for-execution))
24    
25    
26  ;;;; The sigcontext structure.  ;;;; The s-context structure.
27    
28  (def-alien-type sigcontext-regs  (def-alien-type s-context-regs
29    (struct nil    (struct nil
30      (regs (array unsigned-long 32))      (regs (array unsigned-long 32))
31      (fpregs (array unsigned-long 32))      (fpregs (array unsigned-long 32))
32      (y unsigned-long)      (y unsigned-long)
33      (fsr unsigned-long)))      (fsr unsigned-long)))
34    
35  (def-alien-type sigcontext  (def-alien-type s-context
36    (struct nil    (struct nil
37      (sc-onstack unsigned-long)      (sc-onstack unsigned-long)
38      (sc-mask unsigned-long)      (sc-mask unsigned-long)
# Line 40  Line 40 
40      (sc-pc system-area-pointer)      (sc-pc system-area-pointer)
41      (sc-npc system-area-pointer)      (sc-npc system-area-pointer)
42      (sc-psr unsigned-long)      (sc-psr unsigned-long)
43      (sc-g1 (* sigcontext-regs))      (sc-g1 (* s-context-regs))
44      (sc-o0 unsigned-long)))      (sc-o0 unsigned-long)))
45    
46    
# Line 89  Line 89 
89    
90  ;;; INTERNAL-ERROR-ARGUMENTS -- interface.  ;;; INTERNAL-ERROR-ARGUMENTS -- interface.
91  ;;;  ;;;
92  ;;; Given the sigcontext, extract the internal error arguments from the  ;;; Given the s-context, extract the internal error arguments from the
93  ;;; instruction stream.  ;;; instruction stream.
94  ;;;  ;;;
95  (defun internal-error-arguments (scp)  (defun internal-error-arguments (scp)
96    (declare (type (alien (* sigcontext)) scp))    (declare (type (alien (* s-context)) scp))
97    (let* ((pc (with-alien ((scp (* sigcontext) scp))    (let* ((pc (with-alien ((scp (* s-context) scp))
98                 (slot scp 'sc-pc)))                 (slot scp 'sc-pc)))
99           (bad-inst (sap-ref-32 pc 0))           (bad-inst (sap-ref-32 pc 0))
100           (op (ldb (byte 2 30) bad-inst))           (op (ldb (byte 2 30) bad-inst))
# Line 111  Line 111 
111             (values #.(error-number-or-lose 'unknown-error) nil)))))             (values #.(error-number-or-lose 'unknown-error) nil)))))
112    
113  (defun args-for-unimp-inst (scp)  (defun args-for-unimp-inst (scp)
114    (declare (type (alien (* sigcontext)) scp))    (declare (type (alien (* s-context)) scp))
115    (let* ((pc (with-alien ((scp (* sigcontext) scp))    (let* ((pc (with-alien ((scp (* s-context) scp))
116                 (slot scp 'sc-pc)))                 (slot scp 'sc-pc)))
117           (length (sap-ref-8 pc 4))           (length (sap-ref-8 pc 4))
118           (vector (make-array length :element-type '(unsigned-byte 8))))           (vector (make-array length :element-type '(unsigned-byte 8))))
# Line 133  Line 133 
133                 (values error-number (sc-offsets))))))                 (values error-number (sc-offsets))))))
134    
135  (defun args-for-tagged-add-inst (scp bad-inst)  (defun args-for-tagged-add-inst (scp bad-inst)
136    (declare (type (alien (* sigcontext)) scp))    (declare (type (alien (* s-context)) scp))
137    (let* ((rs1 (ldb (byte 5 14) bad-inst))    (let* ((rs1 (ldb (byte 5 14) bad-inst))
138           (op1 (di::make-lisp-obj (sigcontext-register scp rs1))))           (op1 (di::make-lisp-obj (s-context-register scp rs1))))
139      (if (fixnump op1)      (if (fixnump op1)
140          (if (zerop (ldb (byte 1 13) bad-inst))          (if (zerop (ldb (byte 1 13) bad-inst))
141              (let* ((rs2 (ldb (byte 5 0) bad-inst))              (let* ((rs2 (ldb (byte 5 0) bad-inst))
142                     (op2 (di::make-lisp-obj (sigcontext-register scp rs2))))                     (op2 (di::make-lisp-obj (s-context-register scp rs2))))
143                (if (fixnump op2)                (if (fixnump op2)
144                    (values #.(error-number-or-lose 'unknown-error) nil)                    (values #.(error-number-or-lose 'unknown-error) nil)
145                    (values #.(error-number-or-lose 'object-not-fixnum-error)                    (values #.(error-number-or-lose 'object-not-fixnum-error)
# Line 164  Line 164 
164              (list (c::make-sc-offset sparc:descriptor-reg-sc-number reg)))))              (list (c::make-sc-offset sparc:descriptor-reg-sc-number reg)))))
165    
166    
167  ;;;; Sigcontext access functions.  ;;;; s-context access functions.
168    
169  ;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface.  ;;; s-context-PROGRAM-COUNTER -- Interface.
170  ;;;  ;;;
171  (defun sigcontext-program-counter (scp)  (defun s-context-program-counter (scp)
172    (declare (type (alien (* sigcontext)) scp))    (declare (type (alien (* s-context)) scp))
173    (with-alien ((scp (* sigcontext) scp))    (with-alien ((scp (* s-context) scp))
174      (slot scp 'sc-pc)))      (slot scp 'sc-pc)))
175    
176  ;;; SIGCONTEXT-REGISTER -- Interface.  ;;; s-context-REGISTER -- Interface.
177  ;;;  ;;;
178  ;;; 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
179  ;;; interrupts.  ;;; interrupts.
180  ;;;  ;;;
181  (defun sigcontext-register (scp index)  (defun s-context-register (scp index)
182    (declare (type (alien (* sigcontext)) scp))    (declare (type (alien (* s-context)) scp))
183    (with-alien ((scp (* sigcontext) scp))    (with-alien ((scp (* s-context) scp))
184      (deref (slot (slot scp 'sc-g1) 'regs) index)))      (deref (slot (slot scp 'sc-g1) 'regs) index)))
185    
186  (defun %set-sigcontext-register (scp index new)  (defun %set-s-context-register (scp index new)
187    (declare (type (alien (* sigcontext)) scp))    (declare (type (alien (* s-context)) scp))
188    (with-alien ((scp (* sigcontext) scp))    (with-alien ((scp (* s-context) scp))
189      (setf (deref (slot (slot scp 'sc-g1) 'regs) index) new)      (setf (deref (slot (slot scp 'sc-g1) 'regs) index) new)
190      new))      new))
191    
192  (defsetf sigcontext-register %set-sigcontext-register)  (defsetf s-context-register %set-s-context-register)
193    
194    
195  ;;; SIGCONTEXT-FLOAT-REGISTER  --  Interface  ;;; s-context-FLOAT-REGISTER  --  Interface
196  ;;;  ;;;
197  ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.  ;;; Like s-context-REGISTER, but returns the value of a float register.
198  ;;; Format is the type of float to return.  ;;; Format is the type of float to return.
199  ;;;  ;;;
200  (defun sigcontext-float-register (scp index format)  (defun s-context-float-register (scp index format)
201    (declare (type (alien (* sigcontext)) scp))    (declare (type (alien (* s-context)) scp))
202    (with-alien ((scp (* sigcontext) scp))    (with-alien ((scp (* s-context) scp))
203      (let ((sap (alien-sap (slot (slot scp 'sc-g1) 'fpregs))))      (let ((sap (alien-sap (slot (slot scp 'sc-g1) 'fpregs))))
204        (ecase format        (ecase format
205          (single-float (system:sap-ref-single sap (* index vm:word-bytes)))          (single-float (system:sap-ref-single sap (* index vm:word-bytes)))
206          (double-float (system:sap-ref-double sap (* index vm:word-bytes)))))))          (double-float (system:sap-ref-double sap (* index vm:word-bytes)))))))
207  ;;;  ;;;
208  (defun %set-sigcontext-float-register (scp index format new-value)  (defun %set-s-context-float-register (scp index format new-value)
209    (declare (type (alien (* sigcontext)) scp))    (declare (type (alien (* s-context)) scp))
210    (with-alien ((scp (* sigcontext) scp))    (with-alien ((scp (* s-context) scp))
211      (let ((sap (alien-sap (slot (slot scp 'sc-g1) 'fpregs))))      (let ((sap (alien-sap (slot (slot scp 'sc-g1) 'fpregs))))
212        (ecase format        (ecase format
213          (single-float          (single-float
# Line 215  Line 215 
215          (double-float          (double-float
216           (setf (sap-ref-double sap (* index vm:word-bytes)) new-value))))))           (setf (sap-ref-double sap (* index vm:word-bytes)) new-value))))))
217  ;;;  ;;;
218  (defsetf sigcontext-float-register %set-sigcontext-float-register)  (defsetf s-context-float-register %set-s-context-float-register)
219    
220    
221  ;;; SIGCONTEXT-FLOATING-POINT-MODES  --  Interface  ;;; s-context-FLOATING-POINT-MODES  --  Interface
222  ;;;  ;;;
223  ;;;    Given a sigcontext pointer, return the floating point modes word in the  ;;;    Given a s-context pointer, return the floating point modes word in the
224  ;;; same format as returned by FLOATING-POINT-MODES.  ;;; same format as returned by FLOATING-POINT-MODES.
225  ;;;  ;;;
226  (defun sigcontext-floating-point-modes (scp)  (defun s-context-floating-point-modes (scp)
227    (declare (type (alien (* sigcontext)) scp))    (declare (type (alien (* s-context)) scp))
228    (with-alien ((scp (* sigcontext) scp))    (with-alien ((scp (* s-context) scp))
229      (slot (slot scp 'sc-g1) 'fsr)))      (slot (slot scp 'sc-g1) 'fsr)))
230    
231    

Legend:
Removed from v.1.16  
changed lines
  Added in v.1.16.1.1

  ViewVC Help
Powered by ViewVC 1.1.5