/[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 - (hide 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 wlott 1.6 ;;; -*- Package: SPARC -*-
2 wlott 1.1 ;;;
3     ;;; **********************************************************************
4 ram 1.8 ;;; 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 rtoy 1.18.56.1 "$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 ram 1.8 ;;;
10 wlott 1.1 ;;; **********************************************************************
11     ;;;
12     ;;; This file contains the SPARC specific runtime stuff.
13     ;;;
14     (in-package "SPARC")
15     (use-package "SYSTEM")
16 wlott 1.11 (use-package "UNIX")
17 wlott 1.1
18 rtoy 1.18.56.1 (intl:textdomain "cmucl")
19    
20 wlott 1.10 (export '(fixup-code-object internal-error-arguments
21 wlott 1.13 sigcontext-program-counter sigcontext-register
22     sigcontext-float-register sigcontext-floating-point-modes
23 wlott 1.15 extern-alien-name sanctify-for-execution))
24 wlott 1.1
25    
26 wlott 1.10 ;;;; The sigcontext structure.
27    
28 wlott 1.14 (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 wlott 1.10 (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 wlott 1.14 (sc-g1 (* sigcontext-regs))
44     (sc-o0 unsigned-long)))
45 wlott 1.10
46    
47 wlott 1.1 ;;;; Add machine specific features to *features*
48    
49     (pushnew :SPARCstation *features*)
50     (pushnew :sparc *features*)
51     (pushnew :sun4 *features*)
52 wlott 1.7
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 wlott 1.1
65    
66    
67     ;;; FIXUP-CODE-OBJECT -- Interface
68     ;;;
69     (defun fixup-code-object (code offset fixup kind)
70 wlott 1.9 (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 wlott 1.2
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 wlott 1.10 (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 wlott 1.12 (values #.(error-number-or-lose 'unknown-error) nil)))))
112 wlott 1.6
113 wlott 1.10 (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 wlott 1.6
135 wlott 1.10 (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 wlott 1.12 (values #.(error-number-or-lose 'unknown-error) nil)
145     (values #.(error-number-or-lose 'object-not-fixnum-error)
146 wlott 1.10 (list (c::make-sc-offset
147     sparc:descriptor-reg-sc-number
148     rs2)))))
149 wlott 1.12 (values #.(error-number-or-lose 'unknown-error) nil))
150     (values #.(error-number-or-lose 'object-not-fixnum-error)
151 wlott 1.10 (list (c::make-sc-offset sparc:descriptor-reg-sc-number
152     rs1))))))
153 wlott 1.6
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 wlott 1.12 #.(error-number-or-lose 'object-not-list-error))
160 wlott 1.16 (#.sparc:object-not-instance-trap
161     #.(error-number-or-lose 'object-not-instance-error))
162 wlott 1.6 (t
163 wlott 1.12 #.(error-number-or-lose 'unknown-error)))
164 wlott 1.6 (list (c::make-sc-offset sparc:descriptor-reg-sc-number reg)))))
165 ram 1.5
166    
167 wlott 1.10 ;;;; Sigcontext access functions.
168    
169 wlott 1.13 ;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface.
170 wlott 1.10 ;;;
171 wlott 1.13 (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 wlott 1.10 ;;; 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 wlott 1.14 (deref (slot (slot scp 'sc-g1) 'regs) index)))
185 wlott 1.10
186     (defun %set-sigcontext-register (scp index new)
187     (declare (type (alien (* sigcontext)) scp))
188     (with-alien ((scp (* sigcontext) scp))
189 wlott 1.14 (setf (deref (slot (slot scp 'sc-g1) 'regs) index) new)
190 wlott 1.10 new))
191    
192     (defsetf sigcontext-register %set-sigcontext-register)
193    
194    
195 wlott 1.13 ;;; SIGCONTEXT-FLOAT-REGISTER -- Interface
196 wlott 1.10 ;;;
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 wlott 1.14 (let ((sap (alien-sap (slot (slot scp 'sc-g1) 'fpregs))))
204 wlott 1.10 (ecase format
205     (single-float (system:sap-ref-single sap (* index vm:word-bytes)))
206 dtc 1.18 (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 wlott 1.10 ;;;
210     (defun %set-sigcontext-float-register (scp index format new-value)
211     (declare (type (alien (* sigcontext)) scp))
212     (with-alien ((scp (* sigcontext) scp))
213 wlott 1.14 (let ((sap (alien-sap (slot (slot scp 'sc-g1) 'fpregs))))
214 wlott 1.10 (ecase format
215     (single-float
216     (setf (sap-ref-single sap (* index vm:word-bytes)) new-value))
217     (double-float
218 dtc 1.18 (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 wlott 1.10 ;;;
223     (defsetf sigcontext-float-register %set-sigcontext-float-register)
224    
225    
226 ram 1.5 ;;; 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 wlott 1.10 (declare (type (alien (* sigcontext)) scp))
233     (with-alien ((scp (* sigcontext) scp))
234 wlott 1.14 (slot (slot scp 'sc-g1) 'fsr)))
235 wlott 1.10
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 wlott 1.15
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