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

  ViewVC Help
Powered by ViewVC 1.1.5