/[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.12 - (hide annotations)
Thu Mar 26 03:08:37 1992 UTC (22 years ago) by wlott
Branch: MAIN
Changes since 1.11: +10 -13 lines
Added #.'s in front of calls to ERROR-NUMBER-OR-LOSE so the lookup is
done at compile-time and hard wired into the core.
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.12 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/sparc-vm.lisp,v 1.12 1992/03/26 03:08:37 wlott Exp $")
11 ram 1.8 ;;;
12 wlott 1.1 ;;; **********************************************************************
13     ;;;
14 wlott 1.12 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/code/sparc-vm.lisp,v 1.12 1992/03/26 03:08:37 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 wlott 1.12 (values #.(error-number-or-lose 'unknown-error) nil)))))
111 wlott 1.6
112 wlott 1.10 (defun args-for-unimp-inst (scp)
113     (declare (type (alien (* sigcontext)) scp))
114     (let* ((pc (with-alien ((scp (* sigcontext) scp))
115     (slot scp 'sc-pc)))
116     (length (sap-ref-8 pc 4))
117     (vector (make-array length :element-type '(unsigned-byte 8))))
118     (declare (type system-area-pointer pc)
119     (type (unsigned-byte 8) length)
120     (type (simple-array (unsigned-byte 8) (*)) vector))
121     (copy-from-system-area pc (* sparc:byte-bits 5)
122     vector (* sparc:word-bits
123     sparc:vector-data-offset)
124     (* length sparc:byte-bits))
125     (let* ((index 0)
126     (error-number (c::read-var-integer vector index)))
127     (collect ((sc-offsets))
128     (loop
129     (when (>= index length)
130     (return))
131     (sc-offsets (c::read-var-integer vector index)))
132     (values error-number (sc-offsets))))))
133 wlott 1.6
134 wlott 1.10 (defun args-for-tagged-add-inst (scp bad-inst)
135     (declare (type (alien (* sigcontext)) scp))
136     (let* ((rs1 (ldb (byte 5 14) bad-inst))
137     (op1 (di::make-lisp-obj (sigcontext-register scp rs1))))
138     (if (fixnump op1)
139     (if (zerop (ldb (byte 1 13) bad-inst))
140     (let* ((rs2 (ldb (byte 5 0) bad-inst))
141     (op2 (di::make-lisp-obj (sigcontext-register scp rs2))))
142     (if (fixnump op2)
143 wlott 1.12 (values #.(error-number-or-lose 'unknown-error) nil)
144     (values #.(error-number-or-lose 'object-not-fixnum-error)
145 wlott 1.10 (list (c::make-sc-offset
146     sparc:descriptor-reg-sc-number
147     rs2)))))
148 wlott 1.12 (values #.(error-number-or-lose 'unknown-error) nil))
149     (values #.(error-number-or-lose 'object-not-fixnum-error)
150 wlott 1.10 (list (c::make-sc-offset sparc:descriptor-reg-sc-number
151     rs1))))))
152 wlott 1.6
153     (defun args-for-tcc-inst (bad-inst)
154     (let* ((trap-number (ldb (byte 8 0) bad-inst))
155     (reg (ldb (byte 5 8) bad-inst)))
156     (values (case trap-number
157     (#.sparc:object-not-list-trap
158 wlott 1.12 #.(error-number-or-lose 'object-not-list-error))
159 wlott 1.6 (#.sparc:object-not-structure-trap
160 wlott 1.12 #.(error-number-or-lose 'object-not-structure-error))
161 wlott 1.6 (t
162 wlott 1.12 #.(error-number-or-lose 'unknown-error)))
163 wlott 1.6 (list (c::make-sc-offset sparc:descriptor-reg-sc-number reg)))))
164 ram 1.5
165    
166 wlott 1.10 ;;;; Sigcontext access functions.
167    
168     ;;; SIGCONTEXT-REGISTER -- Internal.
169     ;;;
170     ;;; An escape register saves the value of a register for a frame that someone
171     ;;; interrupts.
172     ;;;
173     (defun sigcontext-register (scp index)
174     (declare (type (alien (* sigcontext)) scp))
175     (with-alien ((scp (* sigcontext) scp))
176     (deref (slot scp 'sc-regs) index)))
177    
178     (defun %set-sigcontext-register (scp index new)
179     (declare (type (alien (* sigcontext)) scp))
180     (with-alien ((scp (* sigcontext) scp))
181     (setf (deref (slot scp 'sc-regs) index) new)
182     new))
183    
184     (defsetf sigcontext-register %set-sigcontext-register)
185    
186    
187     ;;; SIGCONTEXT-FLOAT-REGISTER -- Internal
188     ;;;
189     ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.
190     ;;; Format is the type of float to return.
191     ;;;
192     (defun sigcontext-float-register (scp index format)
193     (declare (type (alien (* sigcontext)) scp))
194     (with-alien ((scp (* sigcontext) scp))
195     (let ((sap (alien-sap (slot scp 'sc-fpregs))))
196     (ecase format
197     (single-float (system:sap-ref-single sap (* index vm:word-bytes)))
198     (double-float (system:sap-ref-double sap (* index vm:word-bytes)))))))
199     ;;;
200     (defun %set-sigcontext-float-register (scp index format new-value)
201     (declare (type (alien (* sigcontext)) scp))
202     (with-alien ((scp (* sigcontext) scp))
203     (let ((sap (alien-sap (slot scp 'sc-fpregs))))
204     (ecase format
205     (single-float
206     (setf (sap-ref-single sap (* index vm:word-bytes)) new-value))
207     (double-float
208     (setf (sap-ref-double sap (* index vm:word-bytes)) new-value))))))
209     ;;;
210     (defsetf sigcontext-float-register %set-sigcontext-float-register)
211    
212    
213 ram 1.5 ;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface
214     ;;;
215     ;;; Given a sigcontext pointer, return the floating point modes word in the
216     ;;; same format as returned by FLOATING-POINT-MODES.
217     ;;;
218     (defun sigcontext-floating-point-modes (scp)
219 wlott 1.10 (declare (type (alien (* sigcontext)) scp))
220     (with-alien ((scp (* sigcontext) scp))
221     (slot scp 'sc-fsr)))
222    
223    
224    
225     ;;; EXTERN-ALIEN-NAME -- interface.
226     ;;;
227     ;;; The loader uses this to convert alien names to the form they occure in
228     ;;; the symbol table (for example, prepending an underscore). On the SPARC,
229     ;;; we prepend an underscore.
230     ;;;
231     (defun extern-alien-name (name)
232     (declare (type simple-base-string name))
233     (concatenate 'string "_" name))

  ViewVC Help
Powered by ViewVC 1.1.5