/[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.18.56.1 - (show annotations)
Thu Feb 25 20:34:52 2010 UTC (4 years, 1 month ago) by rtoy
Branch: intl-2-branch
Changes since 1.18: +3 -1 lines
Restart internalization work.  This new branch starts with code from
the intl-branch on date 2010-02-12 18:00:00+0500.  This version works
and

LANG=en@piglatin bin/lisp

works (once the piglatin translation is added).
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.18.56.1 2010/02/25 20:34:52 rtoy 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 (intl:textdomain "cmucl")
19
20 (export '(fixup-code-object internal-error-arguments
21 sigcontext-program-counter sigcontext-register
22 sigcontext-float-register sigcontext-floating-point-modes
23 extern-alien-name sanctify-for-execution))
24
25
26 ;;;; The sigcontext structure.
27
28 (def-alien-type sigcontext-regs
29 (struct nil
30 (regs (array unsigned-long 32))
31 (fpregs (array unsigned-long 32))
32 (y unsigned-long)
33 (fsr unsigned-long)))
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-pc system-area-pointer)
41 (sc-npc system-area-pointer)
42 (sc-psr unsigned-long)
43 (sc-g1 (* sigcontext-regs))
44 (sc-o0 unsigned-long)))
45
46
47 ;;;; Add machine specific features to *features*
48
49 (pushnew :SPARCstation *features*)
50 (pushnew :sparc *features*)
51 (pushnew :sun4 *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 "SPARCstation")
60
61 (defun machine-version ()
62 "Returns a string describing the version of the local machine."
63 "SPARCstation")
64
65
66
67 ;;; FIXUP-CODE-OBJECT -- Interface
68 ;;;
69 (defun fixup-code-object (code offset fixup kind)
70 (declare (type index offset))
71 (unless (zerop (rem offset vm: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 (ecase kind
77 (:call
78 (error "Can't deal with CALL fixups, yet."))
79 (:sethi
80 (setf (ldb (byte 22 0) (sap-ref-32 sap offset))
81 (ldb (byte 22 10) fixup)))
82 (:add
83 (setf (ldb (byte 10 0) (sap-ref-32 sap offset))
84 (ldb (byte 10 0) fixup)))))))
85
86
87
88 ;;;; Internal-error-arguments.
89
90 ;;; INTERNAL-ERROR-ARGUMENTS -- interface.
91 ;;;
92 ;;; Given the sigcontext, extract the internal error arguments from the
93 ;;; instruction stream.
94 ;;;
95 (defun internal-error-arguments (scp)
96 (declare (type (alien (* sigcontext)) scp))
97 (let* ((pc (with-alien ((scp (* sigcontext) scp))
98 (slot scp 'sc-pc)))
99 (bad-inst (sap-ref-32 pc 0))
100 (op (ldb (byte 2 30) bad-inst))
101 (op2 (ldb (byte 3 22) bad-inst))
102 (op3 (ldb (byte 6 19) bad-inst)))
103 (declare (type system-area-pointer pc))
104 (cond ((and (= op #b00) (= op2 #b000))
105 (args-for-unimp-inst scp))
106 ((and (= op #b10) (= (ldb (byte 4 2) op3) #b1000))
107 (args-for-tagged-add-inst scp bad-inst))
108 ((and (= op #b10) (= op3 #b111010))
109 (args-for-tcc-inst bad-inst))
110 (t
111 (values #.(error-number-or-lose 'unknown-error) 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) nil)
145 (values #.(error-number-or-lose 'object-not-fixnum-error)
146 (list (c::make-sc-offset
147 sparc:descriptor-reg-sc-number
148 rs2)))))
149 (values #.(error-number-or-lose 'unknown-error) nil))
150 (values #.(error-number-or-lose 'object-not-fixnum-error)
151 (list (c::make-sc-offset sparc:descriptor-reg-sc-number
152 rs1))))))
153
154 (defun args-for-tcc-inst (bad-inst)
155 (let* ((trap-number (ldb (byte 8 0) bad-inst))
156 (reg (ldb (byte 5 8) bad-inst)))
157 (values (case trap-number
158 (#.sparc:object-not-list-trap
159 #.(error-number-or-lose 'object-not-list-error))
160 (#.sparc:object-not-instance-trap
161 #.(error-number-or-lose 'object-not-instance-error))
162 (t
163 #.(error-number-or-lose 'unknown-error)))
164 (list (c::make-sc-offset sparc:descriptor-reg-sc-number reg)))))
165
166
167 ;;;; Sigcontext access functions.
168
169 ;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface.
170 ;;;
171 (defun sigcontext-program-counter (scp)
172 (declare (type (alien (* sigcontext)) scp))
173 (with-alien ((scp (* sigcontext) scp))
174 (slot scp 'sc-pc)))
175
176 ;;; SIGCONTEXT-REGISTER -- Interface.
177 ;;;
178 ;;; An escape register saves the value of a register for a frame that someone
179 ;;; interrupts.
180 ;;;
181 (defun sigcontext-register (scp index)
182 (declare (type (alien (* sigcontext)) scp))
183 (with-alien ((scp (* sigcontext) scp))
184 (deref (slot (slot scp 'sc-g1) 'regs) index)))
185
186 (defun %set-sigcontext-register (scp index new)
187 (declare (type (alien (* sigcontext)) scp))
188 (with-alien ((scp (* sigcontext) scp))
189 (setf (deref (slot (slot scp 'sc-g1) 'regs) index) new)
190 new))
191
192 (defsetf sigcontext-register %set-sigcontext-register)
193
194
195 ;;; SIGCONTEXT-FLOAT-REGISTER -- Interface
196 ;;;
197 ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.
198 ;;; Format is the type of float to return.
199 ;;;
200 (defun sigcontext-float-register (scp index format)
201 (declare (type (alien (* sigcontext)) scp))
202 (with-alien ((scp (* sigcontext) scp))
203 (let ((sap (alien-sap (slot (slot scp 'sc-g1) 'fpregs))))
204 (ecase format
205 (single-float (system:sap-ref-single sap (* index vm:word-bytes)))
206 (double-float (system:sap-ref-double sap (* index vm:word-bytes)))
207 #+long-float
208 (long-float (system:sap-ref-long sap (* index vm:word-bytes)))))))
209 ;;;
210 (defun %set-sigcontext-float-register (scp index format new-value)
211 (declare (type (alien (* sigcontext)) scp))
212 (with-alien ((scp (* sigcontext) scp))
213 (let ((sap (alien-sap (slot (slot scp 'sc-g1) 'fpregs))))
214 (ecase format
215 (single-float
216 (setf (sap-ref-single sap (* index vm:word-bytes)) new-value))
217 (double-float
218 (setf (sap-ref-double sap (* index vm:word-bytes)) new-value))
219 #+long-float
220 (long-float
221 (setf (sap-ref-long sap (* index vm:word-bytes)) new-value))))))
222 ;;;
223 (defsetf sigcontext-float-register %set-sigcontext-float-register)
224
225
226 ;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface
227 ;;;
228 ;;; Given a sigcontext pointer, return the floating point modes word in the
229 ;;; same format as returned by FLOATING-POINT-MODES.
230 ;;;
231 (defun sigcontext-floating-point-modes (scp)
232 (declare (type (alien (* sigcontext)) scp))
233 (with-alien ((scp (* sigcontext) scp))
234 (slot (slot scp 'sc-g1) 'fsr)))
235
236
237
238 ;;; EXTERN-ALIEN-NAME -- interface.
239 ;;;
240 ;;; The loader uses this to convert alien names to the form they occure in
241 ;;; the symbol table (for example, prepending an underscore). On the SPARC,
242 ;;; we prepend an underscore.
243 ;;;
244 (defun extern-alien-name (name)
245 (declare (type simple-base-string name))
246 (concatenate 'string "_" name))
247
248
249
250 ;;; SANCTIFY-FOR-EXECUTION -- Interface.
251 ;;;
252 ;;; Do whatever is necessary to make the given code component executable.
253 ;;; On the sparc, we don't need to do anything, because the i and d caches
254 ;;; are unified.
255 ;;;
256 (defun sanctify-for-execution (component)
257 (declare (ignore component))
258 nil)

  ViewVC Help
Powered by ViewVC 1.1.5