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

  ViewVC Help
Powered by ViewVC 1.1.5