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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17 - (show annotations)
Mon Oct 31 04:11:27 1994 UTC (19 years, 5 months ago) by ram
Branch: MAIN
CVS Tags: RELEASE_18a
Branch point for: RELENG_18
Changes since 1.16: +1 -3 lines
Fix headed boilerplate.
1 ;;; -*- Package: SPARC -*-
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 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/sparc-vm.lisp,v 1.17 1994/10/31 04:11:27 ram Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This file contains the SPARC specific runtime stuff.
13 ;;;
14 (in-package "SPARC")
15 (use-package "SYSTEM")
16 (use-package "UNIX")
17
18 (export '(fixup-code-object internal-error-arguments
19 sigcontext-program-counter sigcontext-register
20 sigcontext-float-register sigcontext-floating-point-modes
21 extern-alien-name sanctify-for-execution))
22
23
24 ;;;; The sigcontext structure.
25
26 (def-alien-type sigcontext-regs
27 (struct nil
28 (regs (array unsigned-long 32))
29 (fpregs (array unsigned-long 32))
30 (y unsigned-long)
31 (fsr unsigned-long)))
32
33 (def-alien-type sigcontext
34 (struct nil
35 (sc-onstack unsigned-long)
36 (sc-mask unsigned-long)
37 (sc-sp system-area-pointer)
38 (sc-pc system-area-pointer)
39 (sc-npc system-area-pointer)
40 (sc-psr unsigned-long)
41 (sc-g1 (* sigcontext-regs))
42 (sc-o0 unsigned-long)))
43
44
45 ;;;; Add machine specific features to *features*
46
47 (pushnew :SPARCstation *features*)
48 (pushnew :sparc *features*)
49 (pushnew :sun4 *features*)
50
51
52
53 ;;;; MACHINE-TYPE and MACHINE-VERSION
54
55 (defun machine-type ()
56 "Returns a string describing the type of the local machine."
57 "SPARCstation")
58
59 (defun machine-version ()
60 "Returns a string describing the version of the local machine."
61 "SPARCstation")
62
63
64
65 ;;; FIXUP-CODE-OBJECT -- Interface
66 ;;;
67 (defun fixup-code-object (code offset fixup kind)
68 (declare (type index offset))
69 (unless (zerop (rem offset vm:word-bytes))
70 (error "Unaligned instruction? offset=#x~X." offset))
71 (system:without-gcing
72 (let ((sap (truly-the system-area-pointer
73 (%primitive c::code-instructions code))))
74 (ecase kind
75 (:call
76 (error "Can't deal with CALL fixups, yet."))
77 (:sethi
78 (setf (ldb (byte 22 0) (sap-ref-32 sap offset))
79 (ldb (byte 22 10) fixup)))
80 (:add
81 (setf (ldb (byte 10 0) (sap-ref-32 sap offset))
82 (ldb (byte 10 0) fixup)))))))
83
84
85
86 ;;;; Internal-error-arguments.
87
88 ;;; INTERNAL-ERROR-ARGUMENTS -- interface.
89 ;;;
90 ;;; Given the sigcontext, extract the internal error arguments from the
91 ;;; instruction stream.
92 ;;;
93 (defun internal-error-arguments (scp)
94 (declare (type (alien (* sigcontext)) scp))
95 (let* ((pc (with-alien ((scp (* sigcontext) scp))
96 (slot scp 'sc-pc)))
97 (bad-inst (sap-ref-32 pc 0))
98 (op (ldb (byte 2 30) bad-inst))
99 (op2 (ldb (byte 3 22) bad-inst))
100 (op3 (ldb (byte 6 19) bad-inst)))
101 (declare (type system-area-pointer pc))
102 (cond ((and (= op #b00) (= op2 #b000))
103 (args-for-unimp-inst scp))
104 ((and (= op #b10) (= (ldb (byte 4 2) op3) #b1000))
105 (args-for-tagged-add-inst scp bad-inst))
106 ((and (= op #b10) (= op3 #b111010))
107 (args-for-tcc-inst bad-inst))
108 (t
109 (values #.(error-number-or-lose 'unknown-error) nil)))))
110
111 (defun args-for-unimp-inst (scp)
112 (declare (type (alien (* sigcontext)) scp))
113 (let* ((pc (with-alien ((scp (* sigcontext) scp))
114 (slot scp 'sc-pc)))
115 (length (sap-ref-8 pc 4))
116 (vector (make-array length :element-type '(unsigned-byte 8))))
117 (declare (type system-area-pointer pc)
118 (type (unsigned-byte 8) length)
119 (type (simple-array (unsigned-byte 8) (*)) vector))
120 (copy-from-system-area pc (* sparc:byte-bits 5)
121 vector (* sparc:word-bits
122 sparc:vector-data-offset)
123 (* length sparc:byte-bits))
124 (let* ((index 0)
125 (error-number (c::read-var-integer vector index)))
126 (collect ((sc-offsets))
127 (loop
128 (when (>= index length)
129 (return))
130 (sc-offsets (c::read-var-integer vector index)))
131 (values error-number (sc-offsets))))))
132
133 (defun args-for-tagged-add-inst (scp bad-inst)
134 (declare (type (alien (* sigcontext)) scp))
135 (let* ((rs1 (ldb (byte 5 14) bad-inst))
136 (op1 (di::make-lisp-obj (sigcontext-register scp rs1))))
137 (if (fixnump op1)
138 (if (zerop (ldb (byte 1 13) bad-inst))
139 (let* ((rs2 (ldb (byte 5 0) bad-inst))
140 (op2 (di::make-lisp-obj (sigcontext-register scp rs2))))
141 (if (fixnump op2)
142 (values #.(error-number-or-lose 'unknown-error) nil)
143 (values #.(error-number-or-lose 'object-not-fixnum-error)
144 (list (c::make-sc-offset
145 sparc:descriptor-reg-sc-number
146 rs2)))))
147 (values #.(error-number-or-lose 'unknown-error) nil))
148 (values #.(error-number-or-lose 'object-not-fixnum-error)
149 (list (c::make-sc-offset sparc:descriptor-reg-sc-number
150 rs1))))))
151
152 (defun args-for-tcc-inst (bad-inst)
153 (let* ((trap-number (ldb (byte 8 0) bad-inst))
154 (reg (ldb (byte 5 8) bad-inst)))
155 (values (case trap-number
156 (#.sparc:object-not-list-trap
157 #.(error-number-or-lose 'object-not-list-error))
158 (#.sparc:object-not-instance-trap
159 #.(error-number-or-lose 'object-not-instance-error))
160 (t
161 #.(error-number-or-lose 'unknown-error)))
162 (list (c::make-sc-offset sparc:descriptor-reg-sc-number reg)))))
163
164
165 ;;;; Sigcontext access functions.
166
167 ;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface.
168 ;;;
169 (defun sigcontext-program-counter (scp)
170 (declare (type (alien (* sigcontext)) scp))
171 (with-alien ((scp (* sigcontext) scp))
172 (slot scp 'sc-pc)))
173
174 ;;; SIGCONTEXT-REGISTER -- Interface.
175 ;;;
176 ;;; An escape register saves the value of a register for a frame that someone
177 ;;; interrupts.
178 ;;;
179 (defun sigcontext-register (scp index)
180 (declare (type (alien (* sigcontext)) scp))
181 (with-alien ((scp (* sigcontext) scp))
182 (deref (slot (slot scp 'sc-g1) 'regs) index)))
183
184 (defun %set-sigcontext-register (scp index new)
185 (declare (type (alien (* sigcontext)) scp))
186 (with-alien ((scp (* sigcontext) scp))
187 (setf (deref (slot (slot scp 'sc-g1) 'regs) index) new)
188 new))
189
190 (defsetf sigcontext-register %set-sigcontext-register)
191
192
193 ;;; SIGCONTEXT-FLOAT-REGISTER -- Interface
194 ;;;
195 ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.
196 ;;; Format is the type of float to return.
197 ;;;
198 (defun sigcontext-float-register (scp index format)
199 (declare (type (alien (* sigcontext)) scp))
200 (with-alien ((scp (* sigcontext) scp))
201 (let ((sap (alien-sap (slot (slot scp 'sc-g1) 'fpregs))))
202 (ecase format
203 (single-float (system:sap-ref-single sap (* index vm:word-bytes)))
204 (double-float (system:sap-ref-double sap (* index vm:word-bytes)))))))
205 ;;;
206 (defun %set-sigcontext-float-register (scp index format new-value)
207 (declare (type (alien (* sigcontext)) scp))
208 (with-alien ((scp (* sigcontext) scp))
209 (let ((sap (alien-sap (slot (slot scp 'sc-g1) 'fpregs))))
210 (ecase format
211 (single-float
212 (setf (sap-ref-single sap (* index vm:word-bytes)) new-value))
213 (double-float
214 (setf (sap-ref-double sap (* index vm:word-bytes)) new-value))))))
215 ;;;
216 (defsetf sigcontext-float-register %set-sigcontext-float-register)
217
218
219 ;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface
220 ;;;
221 ;;; Given a sigcontext pointer, return the floating point modes word in the
222 ;;; same format as returned by FLOATING-POINT-MODES.
223 ;;;
224 (defun sigcontext-floating-point-modes (scp)
225 (declare (type (alien (* sigcontext)) scp))
226 (with-alien ((scp (* sigcontext) scp))
227 (slot (slot scp 'sc-g1) 'fsr)))
228
229
230
231 ;;; EXTERN-ALIEN-NAME -- interface.
232 ;;;
233 ;;; The loader uses this to convert alien names to the form they occure in
234 ;;; the symbol table (for example, prepending an underscore). On the SPARC,
235 ;;; we prepend an underscore.
236 ;;;
237 (defun extern-alien-name (name)
238 (declare (type simple-base-string name))
239 (concatenate 'string "_" name))
240
241
242
243 ;;; SANCTIFY-FOR-EXECUTION -- Interface.
244 ;;;
245 ;;; Do whatever is necessary to make the given code component executable.
246 ;;; On the sparc, we don't need to do anything, because the i and d caches
247 ;;; are unified.
248 ;;;
249 (defun sanctify-for-execution (component)
250 (declare (ignore component))
251 nil)

  ViewVC Help
Powered by ViewVC 1.1.5