/[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.13 - (hide annotations)
Thu Jul 9 16:43:44 1992 UTC (21 years, 9 months ago) by wlott
Branch: MAIN
Changes since 1.12: +14 -6 lines
Added SIGCONTEXT-PROGRAM-COUNTER.
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.13 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/sparc-vm.lisp,v 1.13 1992/07/09 16:43:44 wlott Exp $")
11 ram 1.8 ;;;
12 wlott 1.1 ;;; **********************************************************************
13     ;;;
14 wlott 1.13 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/code/sparc-vm.lisp,v 1.13 1992/07/09 16:43:44 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 wlott 1.13 sigcontext-program-counter sigcontext-register
24     sigcontext-float-register sigcontext-floating-point-modes
25     extern-alien-name))
26 wlott 1.1
27    
28 wlott 1.10 ;;;; The sigcontext structure.
29    
30     (def-alien-type sigcontext
31     (struct nil
32     (sc-onstack unsigned-long)
33     (sc-mask unsigned-long)
34     (sc-sp system-area-pointer)
35     (sc-pc system-area-pointer)
36     (sc-npc system-area-pointer)
37     (sc-psr unsigned-long)
38     (sc-g1 unsigned-long)
39     (sc-o0 unsigned-long)
40     (sc-regs (array unsigned-long 32))
41     (sc-fpregs (array unsigned-long 32))
42     (sc-y unsigned-long)
43     (sc-fsr unsigned-long)))
44    
45    
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.6 (#.sparc:object-not-structure-trap
161 wlott 1.12 #.(error-number-or-lose 'object-not-structure-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     (deref (slot scp 'sc-regs) index)))
185    
186     (defun %set-sigcontext-register (scp index new)
187     (declare (type (alien (* sigcontext)) scp))
188     (with-alien ((scp (* sigcontext) scp))
189     (setf (deref (slot scp 'sc-regs) index) new)
190     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     (let ((sap (alien-sap (slot scp 'sc-fpregs))))
204     (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     (defun %set-sigcontext-float-register (scp index format new-value)
209     (declare (type (alien (* sigcontext)) scp))
210     (with-alien ((scp (* sigcontext) scp))
211     (let ((sap (alien-sap (slot scp 'sc-fpregs))))
212     (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     (defsetf sigcontext-float-register %set-sigcontext-float-register)
219    
220    
221 ram 1.5 ;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface
222     ;;;
223     ;;; Given a sigcontext pointer, return the floating point modes word in the
224     ;;; same format as returned by FLOATING-POINT-MODES.
225     ;;;
226     (defun sigcontext-floating-point-modes (scp)
227 wlott 1.10 (declare (type (alien (* sigcontext)) scp))
228     (with-alien ((scp (* sigcontext) scp))
229     (slot scp 'sc-fsr)))
230    
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))

  ViewVC Help
Powered by ViewVC 1.1.5