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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (hide annotations)
Thu Jun 18 11:54:21 1992 UTC (21 years, 10 months ago) by wlott
Branch: MAIN
Changes since 1.2: +3 -4 lines
Fixed the mask in the :branch branch of FIXUP-CODE-OBJECT.
1 wlott 1.1 ;;; -*- Package: HPPA -*-
2     ;;;
3     ;;; **********************************************************************
4     ;;; 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.
6     ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7     ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8     ;;;
9     (ext:file-comment
10 wlott 1.3 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/hppa-vm.lisp,v 1.3 1992/06/18 11:54:21 wlott Exp $")
11 wlott 1.1 ;;;
12     ;;; **********************************************************************
13     ;;;
14     ;;; This file contains the HPPA specific runtime stuff.
15     ;;;
16     (in-package "HPPA")
17     (use-package "SYSTEM")
18     (use-package "ALIEN")
19     (use-package "C-CALL")
20     (use-package "UNIX")
21    
22     (export '(fixup-code-object internal-error-arguments
23     sigcontext-register sigcontext-float-register
24     sigcontext-floating-point-modes extern-alien-name))
25    
26    
27     ;;;; The sigcontext structure.
28    
29     (def-alien-type save-state
30     (struct nil
31     (regs (array unsigned-long 32))
32     (filler (array unsigned-long 32))
33     (fpregs (array unsigned-long 32))))
34    
35     (def-alien-type sigcontext
36     (struct nil
37     (sc-onstack unsigned-long)
38     (sc-mask unsigned-long)
39     (sc-sp system-area-pointer)
40     (sc-fp system-area-pointer)
41     (sc-ap (* save-state))
42     (sc-pcsqh unsigned-long)
43     (sc-pc system-area-pointer) ; HP calls it the sc-pcoqh.
44     (sc-pcsqt unsigned-long)
45     (sc-pcoqt system-area-pointer)
46     (sc-ps unsigned-long)))
47    
48    
49     ;;;; Add machine specific features to *features*
50    
51     (pushnew :hppa *features*)
52    
53    
54    
55     ;;;; MACHINE-TYPE and MACHINE-VERSION
56    
57     (defun machine-type ()
58     "Returns a string describing the type of the local machine."
59     "HPPA")
60    
61     (defun machine-version ()
62     "Returns a string describing the version of the local machine."
63     "HPPA")
64    
65    
66    
67     ;;; FIXUP-CODE-OBJECT -- Interface
68     ;;;
69     (defun fixup-code-object (code offset value kind)
70     (unless (zerop (rem offset word-bytes))
71     (error "Unaligned instruction? offset=#x~X." offset))
72     (system:without-gcing
73     (let* ((sap (truly-the system-area-pointer
74     (%primitive c::code-instructions code)))
75     (inst (sap-ref-32 sap offset)))
76     (setf (sap-ref-32 sap offset)
77     (ecase kind
78     (:load
79     (logior (ash (ldb (byte 11 0) value) 1)
80     (logand inst #xffffc000)))
81     (:load-short
82     (let ((low-bits (ldb (byte 11 0) value)))
83     (assert (<= 0 low-bits (1- (ash 1 4))))
84     (logior (ash low-bits 17)
85     (logand inst #xffe0ffff))))
86     (:hi
87     (logior (ash (ldb (byte 5 13) value) 16)
88     (ash (ldb (byte 2 18) value) 14)
89     (ash (ldb (byte 2 11) value) 12)
90     (ash (ldb (byte 11 20) value) 1)
91     (ldb (byte 1 31) value)
92     (logand inst #xffe00000)))
93     (:branch
94     (let ((bits (ldb (byte 9 2) value)))
95     (assert (zerop (ldb (byte 2 0) value)))
96 wlott 1.3 (logior (ash bits 3)
97     (logand inst #xffe0e002)))))))))
98 wlott 1.1
99    
100    
101     ;;;; Internal-error-arguments.
102    
103     ;;; INTERNAL-ERROR-ARGUMENTS -- interface.
104     ;;;
105     ;;; Given the sigcontext, extract the internal error arguments from the
106     ;;; instruction stream.
107     ;;;
108     (defun internal-error-arguments (scp)
109     (declare (type (alien (* sigcontext)) scp))
110     (with-alien ((scp (* sigcontext) scp))
111     (let ((pc (slot scp 'sc-pc)))
112     (declare (type system-area-pointer pc))
113     (let* ((length (sap-ref-8 pc 4))
114     (vector (make-array length :element-type '(unsigned-byte 8))))
115     (declare (type (unsigned-byte 8) length)
116     (type (simple-array (unsigned-byte 8) (*)) vector))
117     (copy-from-system-area pc (* byte-bits 5)
118     vector (* word-bits
119     vector-data-offset)
120     (* length byte-bits))
121     (let* ((index 0)
122     (error-number (c::read-var-integer vector index)))
123     (collect ((sc-offsets))
124     (loop
125     (when (>= index length)
126     (return))
127     (sc-offsets (c::read-var-integer vector index)))
128     (values error-number (sc-offsets))))))))
129    
130    
131     ;;;; Sigcontext access functions.
132    
133     ;;; SIGCONTEXT-REGISTER -- Internal.
134     ;;;
135     ;;; An escape register saves the value of a register for a frame that someone
136     ;;; interrupts.
137     ;;;
138     (defun sigcontext-register (scp index)
139     (declare (type (alien (* sigcontext)) scp))
140     (with-alien ((scp (* sigcontext) scp))
141     (deref (slot (slot scp 'sc-ap) 'regs) index)))
142    
143     (defun %set-sigcontext-register (scp index new)
144     (declare (type (alien (* sigcontext)) scp))
145     (with-alien ((scp (* sigcontext) scp))
146     (setf (deref (slot (slot scp 'sc-ap) 'regs) index) new)
147     new))
148    
149     (defsetf sigcontext-register %set-sigcontext-register)
150    
151    
152     ;;; SIGCONTEXT-FLOAT-REGISTER -- Internal
153     ;;;
154     ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.
155     ;;; Format is the type of float to return.
156     ;;;
157     (defun sigcontext-float-register (scp index format)
158     (declare (type (alien (* sigcontext)) scp))
159     (error "sigcontext-float-register not implimented." scp index format)
160     #+nil
161     (with-alien ((scp (* sigcontext) scp))
162     (let ((sap (alien-sap (slot scp 'sc-fpregs))))
163     (ecase format
164     (single-float (system:sap-ref-single sap (* index vm:word-bytes)))
165     (double-float (system:sap-ref-double sap (* index vm:word-bytes)))))))
166     ;;;
167     (defun %set-sigcontext-float-register (scp index format new-value)
168     (declare (type (alien (* sigcontext)) scp))
169     (error "%set-sigcontext-float-register not implimented."
170     scp index format new-value)
171     #+nil
172     (with-alien ((scp (* sigcontext) scp))
173     (let ((sap (alien-sap (slot scp 'sc-fpregs))))
174     (ecase format
175     (single-float
176     (setf (sap-ref-single sap (* index vm:word-bytes)) new-value))
177     (double-float
178     (setf (sap-ref-double sap (* index vm:word-bytes)) new-value))))))
179     ;;;
180     (defsetf sigcontext-float-register %set-sigcontext-float-register)
181    
182    
183     ;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface
184     ;;;
185     ;;; Given a sigcontext pointer, return the floating point modes word in the
186     ;;; same format as returned by FLOATING-POINT-MODES.
187     ;;;
188     (defun sigcontext-floating-point-modes (scp)
189     (declare (type (alien (* sigcontext)) scp))
190     (error "sigcontext-floating-point-modes not implimented." scp)
191     #+nil
192     (with-alien ((scp (* sigcontext) scp))
193     (slot scp 'sc-fpc-csr)))
194    
195    
196    
197     ;;; EXTERN-ALIEN-NAME -- interface.
198     ;;;
199     ;;; The loader uses this to convert alien names to the form they occure in
200 wlott 1.2 ;;; the symbol table (for example, prepending an underscore). On the HPPA
201     ;;; we just leave it alone.
202 wlott 1.1 ;;;
203     (defun extern-alien-name (name)
204     (declare (type simple-base-string name))
205 wlott 1.2 name)
206 wlott 1.1
207    

  ViewVC Help
Powered by ViewVC 1.1.5