/[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 - (show 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 ;;; -*- 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.3 1992/06/18 11:54:21 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-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 (logior (ash bits 3)
97 (logand inst #xffe0e002)))))))))
98
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 ;;; the symbol table (for example, prepending an underscore). On the HPPA
201 ;;; we just leave it alone.
202 ;;;
203 (defun extern-alien-name (name)
204 (declare (type simple-base-string name))
205 name)
206
207

  ViewVC Help
Powered by ViewVC 1.1.5