/[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 - (hide 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 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 wlott 1.11 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/sparc-vm.lisp,v 1.11 1992/03/02 00:05:30 wlott Exp $")
11 ram 1.8 ;;;
12 wlott 1.1 ;;; **********************************************************************
13     ;;;
14 wlott 1.11 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/code/sparc-vm.lisp,v 1.11 1992/03/02 00:05:30 wlott Exp $
15 wlott 1.1 ;;;
16     ;;; This file contains the SPARC specific runtime stuff.
17     ;;;
18     (in-package "SPARC")
19     (use-package "SYSTEM")
20 wlott 1.11 (use-package "UNIX")
21 wlott 1.1
22 wlott 1.10 (export '(fixup-code-object internal-error-arguments
23     sigcontext-register sigcontext-float-register
24     sigcontext-floating-point-modes extern-alien-name))
25 wlott 1.1
26    
27 wlott 1.10 ;;;; 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 wlott 1.1 ;;;; Add machine specific features to *features*
47    
48     (pushnew :SPARCstation *features*)
49     (pushnew :sparc *features*)
50     (pushnew :sun4 *features*)
51 wlott 1.7
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 wlott 1.1
64    
65    
66     ;;; FIXUP-CODE-OBJECT -- Interface
67     ;;;
68     (defun fixup-code-object (code offset fixup kind)
69 wlott 1.9 (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 wlott 1.2
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 wlott 1.10 (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 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     (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 wlott 1.6
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 ram 1.5
168    
169 wlott 1.10 ;;;; 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 ram 1.5 ;;; 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 wlott 1.10 (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