/[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.16.1.1 - (hide annotations) (vendor branch)
Wed Oct 19 23:25:47 1994 UTC (19 years, 6 months ago) by ram
Branch: solaris_patch
Changes since 1.16: +42 -42 lines
Solaris patches.
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     ;;; 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 ram 1.16.1.1 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/sparc-vm.lisp,v 1.16.1.1 1994/10/19 23:25:47 ram Exp $")
11 ram 1.8 ;;;
12 wlott 1.1 ;;; **********************************************************************
13     ;;;
14     ;;; This file contains the SPARC specific runtime stuff.
15     ;;;
16     (in-package "SPARC")
17     (use-package "SYSTEM")
18 wlott 1.11 (use-package "UNIX")
19 wlott 1.1
20 wlott 1.10 (export '(fixup-code-object internal-error-arguments
21 ram 1.16.1.1 s-context-program-counter s-context-register
22     s-context-float-register s-context-floating-point-modes
23 wlott 1.15 extern-alien-name sanctify-for-execution))
24 wlott 1.1
25    
26 ram 1.16.1.1 ;;;; The s-context structure.
27 wlott 1.10
28 ram 1.16.1.1 (def-alien-type s-context-regs
29 wlott 1.14 (struct nil
30     (regs (array unsigned-long 32))
31     (fpregs (array unsigned-long 32))
32     (y unsigned-long)
33     (fsr unsigned-long)))
34    
35 ram 1.16.1.1 (def-alien-type s-context
36 wlott 1.10 (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 ram 1.16.1.1 (sc-g1 (* s-context-regs))
44 wlott 1.14 (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 ram 1.16.1.1 ;;; Given the s-context, extract the internal error arguments from the
93 wlott 1.2 ;;; instruction stream.
94     ;;;
95 wlott 1.10 (defun internal-error-arguments (scp)
96 ram 1.16.1.1 (declare (type (alien (* s-context)) scp))
97     (let* ((pc (with-alien ((scp (* s-context) scp))
98 wlott 1.10 (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 ram 1.16.1.1 (declare (type (alien (* s-context)) scp))
115     (let* ((pc (with-alien ((scp (* s-context) scp))
116 wlott 1.10 (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 ram 1.16.1.1 (declare (type (alien (* s-context)) scp))
137 wlott 1.10 (let* ((rs1 (ldb (byte 5 14) bad-inst))
138 ram 1.16.1.1 (op1 (di::make-lisp-obj (s-context-register scp rs1))))
139 wlott 1.10 (if (fixnump op1)
140     (if (zerop (ldb (byte 1 13) bad-inst))
141     (let* ((rs2 (ldb (byte 5 0) bad-inst))
142 ram 1.16.1.1 (op2 (di::make-lisp-obj (s-context-register scp rs2))))
143 wlott 1.10 (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 ram 1.16.1.1 ;;;; s-context access functions.
168 wlott 1.10
169 ram 1.16.1.1 ;;; s-context-PROGRAM-COUNTER -- Interface.
170 wlott 1.10 ;;;
171 ram 1.16.1.1 (defun s-context-program-counter (scp)
172     (declare (type (alien (* s-context)) scp))
173     (with-alien ((scp (* s-context) scp))
174 wlott 1.13 (slot scp 'sc-pc)))
175    
176 ram 1.16.1.1 ;;; s-context-REGISTER -- Interface.
177 wlott 1.13 ;;;
178 wlott 1.10 ;;; An escape register saves the value of a register for a frame that someone
179     ;;; interrupts.
180     ;;;
181 ram 1.16.1.1 (defun s-context-register (scp index)
182     (declare (type (alien (* s-context)) scp))
183     (with-alien ((scp (* s-context) scp))
184 wlott 1.14 (deref (slot (slot scp 'sc-g1) 'regs) index)))
185 wlott 1.10
186 ram 1.16.1.1 (defun %set-s-context-register (scp index new)
187     (declare (type (alien (* s-context)) scp))
188     (with-alien ((scp (* s-context) scp))
189 wlott 1.14 (setf (deref (slot (slot scp 'sc-g1) 'regs) index) new)
190 wlott 1.10 new))
191    
192 ram 1.16.1.1 (defsetf s-context-register %set-s-context-register)
193 wlott 1.10
194    
195 ram 1.16.1.1 ;;; s-context-FLOAT-REGISTER -- Interface
196 wlott 1.10 ;;;
197 ram 1.16.1.1 ;;; Like s-context-REGISTER, but returns the value of a float register.
198 wlott 1.10 ;;; Format is the type of float to return.
199     ;;;
200 ram 1.16.1.1 (defun s-context-float-register (scp index format)
201     (declare (type (alien (* s-context)) scp))
202     (with-alien ((scp (* s-context) 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     (double-float (system:sap-ref-double sap (* index vm:word-bytes)))))))
207     ;;;
208 ram 1.16.1.1 (defun %set-s-context-float-register (scp index format new-value)
209     (declare (type (alien (* s-context)) scp))
210     (with-alien ((scp (* s-context) scp))
211 wlott 1.14 (let ((sap (alien-sap (slot (slot scp 'sc-g1) 'fpregs))))
212 wlott 1.10 (ecase format
213     (single-float
214     (setf (sap-ref-single sap (* index vm:word-bytes)) new-value))
215     (double-float
216     (setf (sap-ref-double sap (* index vm:word-bytes)) new-value))))))
217     ;;;
218 ram 1.16.1.1 (defsetf s-context-float-register %set-s-context-float-register)
219 wlott 1.10
220    
221 ram 1.16.1.1 ;;; s-context-FLOATING-POINT-MODES -- Interface
222 ram 1.5 ;;;
223 ram 1.16.1.1 ;;; Given a s-context pointer, return the floating point modes word in the
224 ram 1.5 ;;; same format as returned by FLOATING-POINT-MODES.
225     ;;;
226 ram 1.16.1.1 (defun s-context-floating-point-modes (scp)
227     (declare (type (alien (* s-context)) scp))
228     (with-alien ((scp (* s-context) scp))
229 wlott 1.14 (slot (slot scp 'sc-g1) 'fsr)))
230 wlott 1.10
231    
232    
233     ;;; EXTERN-ALIEN-NAME -- interface.
234     ;;;
235     ;;; The loader uses this to convert alien names to the form they occure in
236     ;;; the symbol table (for example, prepending an underscore). On the SPARC,
237     ;;; we prepend an underscore.
238     ;;;
239     (defun extern-alien-name (name)
240     (declare (type simple-base-string name))
241     (concatenate 'string "_" name))
242 wlott 1.15
243    
244    
245     ;;; SANCTIFY-FOR-EXECUTION -- Interface.
246     ;;;
247     ;;; Do whatever is necessary to make the given code component executable.
248     ;;; On the sparc, we don't need to do anything, because the i and d caches
249     ;;; are unified.
250     ;;;
251     (defun sanctify-for-execution (component)
252     (declare (ignore component))
253     nil)

  ViewVC Help
Powered by ViewVC 1.1.5