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

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

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

revision 1.6.1.1 by ram, Wed Oct 19 23:21:29 1994 UTC revision 1.8 by rtoy, Fri Mar 19 15:18:59 2010 UTC
# Line 3  Line 3 
3  ;;; **********************************************************************  ;;; **********************************************************************
4  ;;; This code was written as part of the CMU Common Lisp project at  ;;; This code was written as part of the CMU Common Lisp project at
5  ;;; Carnegie Mellon University, and has been placed in the public domain.  ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;; If you want to use this code or any part of CMU Common Lisp, please contact  
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.  
6  ;;;  ;;;
7  (ext:file-comment  (ext:file-comment
8    "$Header$")    "$Header$")
# Line 19  Line 17 
17  (use-package "C-CALL")  (use-package "C-CALL")
18  (use-package "UNIX")  (use-package "UNIX")
19    
20    (intl:textdomain "cmucl")
21    
22  (export '(fixup-code-object internal-error-arguments  (export '(fixup-code-object internal-error-arguments
23            s-context-program-counter s-context-register            sigcontext-program-counter sigcontext-register
24            s-context-float-register s-context-floating-point-modes            sigcontext-float-register sigcontext-floating-point-modes
25            extern-alien-name sanctify-for-execution))            extern-alien-name sanctify-for-execution))
26    
27    
28  ;;;; The s-context structure.  ;;;; The sigcontext structure.
29    
30  #+hpux  #+hpux
31  (def-alien-type save-state  (def-alien-type save-state
# Line 80  Line 80 
80      (sl-ss save-state)))      (sl-ss save-state)))
81    
82  #+hpux  #+hpux
83  (def-alien-type s-context  (def-alien-type sigcontext
84    (struct nil    (struct nil
85      (sc-sl siglocal)      (sc-sl siglocal)
86      ; the rest of this structure left out (since save-state not complete?)      ; the rest of this structure left out (since save-state not complete?)
# Line 94  Line 94 
94      (fpregs (array unsigned-long 32))))      (fpregs (array unsigned-long 32))))
95    
96  #+MACH  #+MACH
97  (def-alien-type s-context  (def-alien-type sigcontext
98    (struct nil    (struct nil
99      (sc-onstack unsigned-long)      (sc-onstack unsigned-long)
100      (sc-mask unsigned-long)      (sc-mask unsigned-long)
# Line 164  Line 164 
164    
165  ;;; INTERNAL-ERROR-ARGUMENTS -- interface.  ;;; INTERNAL-ERROR-ARGUMENTS -- interface.
166  ;;;  ;;;
167  ;;; Given the s-context, extract the internal error arguments from the  ;;; Given the sigcontext, extract the internal error arguments from the
168  ;;; instruction stream.  ;;; instruction stream.
169  ;;;  ;;;
170  (defun internal-error-arguments (scp)  (defun internal-error-arguments (scp)
171    (declare (type (alien (* s-context)) scp))    (declare (type (alien (* sigcontext)) scp))
172    (with-alien ((scp (* s-context) scp))    (with-alien ((scp (* sigcontext) scp))
173      (let ((pc (s-context-program-counter scp)))      (let ((pc (sigcontext-program-counter scp)))
174        (declare (type system-area-pointer pc))        (declare (type system-area-pointer pc))
175        (let* ((length (sap-ref-8 pc 4))        (let* ((length (sap-ref-8 pc 4))
176               (vector (make-array length :element-type '(unsigned-byte 8))))               (vector (make-array length :element-type '(unsigned-byte 8))))
# Line 190  Line 190 
190              (values error-number (sc-offsets))))))))              (values error-number (sc-offsets))))))))
191    
192    
193  ;;;; s-context access functions.  ;;;; Sigcontext access functions.
194    
195  ;;; s-context-PROGRAM-COUNTER -- Interface  ;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface
196  ;;;  ;;;
197  (defun s-context-program-counter (scp)  (defun sigcontext-program-counter (scp)
198    (declare (type (alien (* s-context)) scp))    (declare (type (alien (* sigcontext)) scp))
199    (with-alien ((scp (* s-context) scp))    (with-alien ((scp (* sigcontext) scp))
200      #+hpux      #+hpux
201      (int-sap (logandc2 (slot (slot (slot scp 'sc-sl) 'sl-ss) 'ss-pcoq-head) 3))      (int-sap (logandc2 (slot (slot (slot scp 'sc-sl) 'sl-ss) 'ss-pcoq-head) 3))
202      #+MACH      #+MACH
203      (int-sap (logandc2 (slot scp 'sc-pcoqh) 3))      (int-sap (logandc2 (slot scp 'sc-pcoqh) 3))
204      ))      ))
205    
206  ;;; s-context-REGISTER -- Interface  ;;; SIGCONTEXT-REGISTER -- Interface
207  ;;;  ;;;
208  ;;; 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
209  ;;; interrupts.  ;;; interrupts.
210  ;;;  ;;;
211  (defun s-context-register (scp index)  (defun sigcontext-register (scp index)
212    (declare (type (alien (* s-context)) scp))    (declare (type (alien (* sigcontext)) scp))
213    (with-alien ((scp (* s-context) scp))    (with-alien ((scp (* sigcontext) scp))
214      #+hpux      #+hpux
215      (deref (slot (slot (slot scp 'sc-sl) 'sl-ss) 'regs) index)      (deref (slot (slot (slot scp 'sc-sl) 'sl-ss) 'regs) index)
216      #+MACH      #+MACH
217      (deref (slot (slot scp 'sc-ap) 'regs) index)      (deref (slot (slot scp 'sc-ap) 'regs) index)
218      ))      ))
219    
220  (defun %set-s-context-register (scp index new)  (defun %set-sigcontext-register (scp index new)
221    (declare (type (alien (* s-context)) scp))    (declare (type (alien (* sigcontext)) scp))
222    (with-alien ((scp (* s-context) scp))    (with-alien ((scp (* sigcontext) scp))
223      #+hpux      #+hpux
224      (setf (deref (slot (slot (slot scp 'sc-sl) 'sl-ss) 'regs) index) new)      (setf (deref (slot (slot (slot scp 'sc-sl) 'sl-ss) 'regs) index) new)
225      #+MACH      #+MACH
226      (setf (deref (slot (slot scp 'sc-ap) 'regs) index) new)      (setf (deref (slot (slot scp 'sc-ap) 'regs) index) new)
227      new))      new))
228    
229  (defsetf s-context-register %set-s-context-register)  (defsetf sigcontext-register %set-sigcontext-register)
230    
231    
232  ;;; s-context-FLOAT-REGISTER  --  Interface  ;;; SIGCONTEXT-FLOAT-REGISTER  --  Interface
233  ;;;  ;;;
234  ;;; Like s-context-REGISTER, but returns the value of a float register.  ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.
235  ;;; Format is the type of float to return.  ;;; Format is the type of float to return.
236  ;;;  ;;;
237  (defun s-context-float-register (scp index format)  (defun sigcontext-float-register (scp index format)
238    (declare (type (alien (* s-context)) scp))    (declare (type (alien (* sigcontext)) scp))
239    (error "s-context-float-register not implemented." scp index format)    (error "sigcontext-float-register not implemented." scp index format)
240    #+nil    #+nil
241    (with-alien ((scp (* s-context) scp))    (with-alien ((scp (* sigcontext) scp))
242      (let ((sap (alien-sap (slot scp 'sc-fpregs))))      (let ((sap (alien-sap (slot scp 'sc-fpregs))))
243        (ecase format        (ecase format
244          (single-float (system:sap-ref-single sap (* index vm:word-bytes)))          (single-float (system:sap-ref-single sap (* index vm:word-bytes)))
245          (double-float (system:sap-ref-double sap (* index vm:word-bytes)))))))          (double-float (system:sap-ref-double sap (* index vm:word-bytes)))))))
246  ;;;  ;;;
247  (defun %set-s-context-float-register (scp index format new-value)  (defun %set-sigcontext-float-register (scp index format new-value)
248    (declare (type (alien (* s-context)) scp))    (declare (type (alien (* sigcontext)) scp))
249    (error "%set-s-context-float-register not implemented."    (error "%set-sigcontext-float-register not implemented."
250           scp index format new-value)           scp index format new-value)
251    #+nil    #+nil
252    (with-alien ((scp (* s-context) scp))    (with-alien ((scp (* sigcontext) scp))
253      (let ((sap (alien-sap (slot scp 'sc-fpregs))))      (let ((sap (alien-sap (slot scp 'sc-fpregs))))
254        (ecase format        (ecase format
255          (single-float          (single-float
# Line 257  Line 257 
257          (double-float          (double-float
258           (setf (sap-ref-double sap (* index vm:word-bytes)) new-value))))))           (setf (sap-ref-double sap (* index vm:word-bytes)) new-value))))))
259  ;;;  ;;;
260  (defsetf s-context-float-register %set-s-context-float-register)  (defsetf sigcontext-float-register %set-sigcontext-float-register)
261    
262    
263  ;;; s-context-FLOATING-POINT-MODES  --  Interface  ;;; SIGCONTEXT-FLOATING-POINT-MODES  --  Interface
264  ;;;  ;;;
265  ;;;    Given a s-context pointer, return the floating point modes word in the  ;;;    Given a sigcontext pointer, return the floating point modes word in the
266  ;;; same format as returned by FLOATING-POINT-MODES.  ;;; same format as returned by FLOATING-POINT-MODES.
267  ;;;  ;;;
268  (defun s-context-floating-point-modes (scp)  (defun sigcontext-floating-point-modes (scp)
269    (declare (type (alien (* s-context)) scp))    (declare (type (alien (* sigcontext)) scp))
270    (error "s-context-floating-point-modes not implimented." scp)    (error "sigcontext-floating-point-modes not implimented." scp)
271    #+nil    #+nil
272    (with-alien ((scp (* s-context) scp))    (with-alien ((scp (* sigcontext) scp))
273      (slot scp 'sc-fpc-csr)))      (slot scp 'sc-fpc-csr)))
274    
275    

Legend:
Removed from v.1.6.1.1  
changed lines
  Added in v.1.8

  ViewVC Help
Powered by ViewVC 1.1.5