/[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 - (hide 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 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 ram 1.17 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/sparc-vm.lisp,v 1.17 1994/10/31 04:11:27 ram 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 wlott 1.10 (export '(fixup-code-object internal-error-arguments
19 wlott 1.13 sigcontext-program-counter sigcontext-register
20     sigcontext-float-register sigcontext-floating-point-modes
21 wlott 1.15 extern-alien-name sanctify-for-execution))
22 wlott 1.1
23    
24 wlott 1.10 ;;;; The sigcontext structure.
25    
26 wlott 1.14 (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 wlott 1.10 (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 wlott 1.14 (sc-g1 (* sigcontext-regs))
42     (sc-o0 unsigned-long)))
43 wlott 1.10
44    
45 wlott 1.1 ;;;; Add machine specific features to *features*
46    
47     (pushnew :SPARCstation *features*)
48     (pushnew :sparc *features*)
49     (pushnew :sun4 *features*)
50 wlott 1.7
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 wlott 1.1
63    
64    
65     ;;; FIXUP-CODE-OBJECT -- Interface
66     ;;;
67     (defun fixup-code-object (code offset fixup kind)
68 wlott 1.9 (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 wlott 1.2
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 wlott 1.10 (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 wlott 1.12 (values #.(error-number-or-lose 'unknown-error) nil)))))
110 wlott 1.6
111 wlott 1.10 (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 wlott 1.6
133 wlott 1.10 (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 wlott 1.12 (values #.(error-number-or-lose 'unknown-error) nil)
143     (values #.(error-number-or-lose 'object-not-fixnum-error)
144 wlott 1.10 (list (c::make-sc-offset
145     sparc:descriptor-reg-sc-number
146     rs2)))))
147 wlott 1.12 (values #.(error-number-or-lose 'unknown-error) nil))
148     (values #.(error-number-or-lose 'object-not-fixnum-error)
149 wlott 1.10 (list (c::make-sc-offset sparc:descriptor-reg-sc-number
150     rs1))))))
151 wlott 1.6
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 wlott 1.12 #.(error-number-or-lose 'object-not-list-error))
158 wlott 1.16 (#.sparc:object-not-instance-trap
159     #.(error-number-or-lose 'object-not-instance-error))
160 wlott 1.6 (t
161 wlott 1.12 #.(error-number-or-lose 'unknown-error)))
162 wlott 1.6 (list (c::make-sc-offset sparc:descriptor-reg-sc-number reg)))))
163 ram 1.5
164    
165 wlott 1.10 ;;;; Sigcontext access functions.
166    
167 wlott 1.13 ;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface.
168 wlott 1.10 ;;;
169 wlott 1.13 (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 wlott 1.10 ;;; 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 wlott 1.14 (deref (slot (slot scp 'sc-g1) 'regs) index)))
183 wlott 1.10
184     (defun %set-sigcontext-register (scp index new)
185     (declare (type (alien (* sigcontext)) scp))
186     (with-alien ((scp (* sigcontext) scp))
187 wlott 1.14 (setf (deref (slot (slot scp 'sc-g1) 'regs) index) new)
188 wlott 1.10 new))
189    
190     (defsetf sigcontext-register %set-sigcontext-register)
191    
192    
193 wlott 1.13 ;;; SIGCONTEXT-FLOAT-REGISTER -- Interface
194 wlott 1.10 ;;;
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 wlott 1.14 (let ((sap (alien-sap (slot (slot scp 'sc-g1) 'fpregs))))
202 wlott 1.10 (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 wlott 1.14 (let ((sap (alien-sap (slot (slot scp 'sc-g1) 'fpregs))))
210 wlott 1.10 (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 ram 1.5 ;;; 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 wlott 1.10 (declare (type (alien (* sigcontext)) scp))
226     (with-alien ((scp (* sigcontext) scp))
227 wlott 1.14 (slot (slot scp 'sc-g1) 'fsr)))
228 wlott 1.10
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 wlott 1.15
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