/[cmucl]/src/code/sgi-vm.lisp
ViewVC logotype

Contents of /src/code/sgi-vm.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Fri Mar 19 15:18:59 2010 UTC (4 years ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.2: +3 -2 lines
Merge intl-branch 2010-03-18 to HEAD.  To build, you need to use
boot-2010-02-1 as the bootstrap file.  You should probably also use
the new -P option for build.sh to generate and update the po files
while building.
1 ;;; -*- Package: MIPS -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; 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 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/sgi-vm.lisp,v 1.3 2010/03/19 15:18:59 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/code/sgi-vm.lisp,v 1.3 2010/03/19 15:18:59 rtoy Rel $
13 ;;;
14 ;;; This file contains the SGI specific runtime stuff.
15 ;;;
16 (in-package "MIPS")
17 (use-package "SYSTEM")
18 (use-package "ALIEN")
19 (use-package "C-CALL")
20 (use-package "UNIX")
21 (intl:textdomain "cmucl")
22
23 (export '(fixup-code-object internal-error-arguments
24 sigcontext-program-counter sigcontext-register
25 sigcontext-float-register sigcontext-floating-point-modes
26 extern-alien-name sanctify-for-execution))
27
28
29 ;;;; The sigcontext structure.
30
31 (def-alien-type sigcontext
32 (struct nil
33 (sc-regmask unsigned-int)
34 (sc-status unsigned-int)
35 (sc-pc-high unsigned-int)
36 (sc-pc system-area-pointer)
37 (sc-regs (array unsigned-int 64)) ; 64 bit slots, so deref (* 2)+1
38 (sc-fpregs (array unsigned-int 64))
39 (sc-ownedfp unsigned-int)
40 (sc-fpc-csr unsigned-int)
41 (sc-fpc-eir unsigned-int)
42 (sc-ssflags unsigned-int)
43 (sc-mdhi-high unsigned-int)
44 (sc-mdhi unsigned-int)
45 (sc-mdlo-high unsigned-int)
46 (sc-mdlo unsigned-int)
47 (sc-cause-high unsigned-int)
48 (sc-cause unsigned-int)
49 (sc-badvaddr-high unsigned-int)
50 (sc-badvaddr system-area-pointer)
51 (sc-triggersave-high unsigned-int)
52 (sc-triggersave unsigned-int)
53 (sc-sigset (array unsigned-int 4))
54 (sc-pad (array unsigned-int 64))))
55
56
57 ;;;; Add machine specific features to *features*
58
59 (pushnew :sgi *features*)
60
61
62
63 ;;;; MACHINE-TYPE and MACHINE-VERSION
64
65 (defun machine-type ()
66 "Returns a string describing the type of the local machine."
67 "SGI")
68
69 (defun machine-version ()
70 "Returns a string describing the version of the local machine."
71 "SGI")
72
73
74
75 ;;; FIXUP-CODE-OBJECT -- Interface
76 ;;;
77 (defun fixup-code-object (code offset fixup kind)
78 (unless (zerop (rem offset word-bytes))
79 (error "Unaligned instruction? offset=#x~X." offset))
80 (system:without-gcing
81 (let ((sap (truly-the system-area-pointer
82 (%primitive c::code-instructions code))))
83 (ecase kind
84 (:jump
85 (assert (zerop (ash fixup -28)))
86 (setf (ldb (byte 26 0) (system:sap-ref-32 sap offset))
87 (ash fixup -2)))
88 (:lui
89 (setf (sap-ref-16 sap (+ offset 2))
90 (+ (ash fixup -16)
91 (if (logbitp 15 fixup) 1 0))))
92 (:addi
93 (setf (sap-ref-16 sap (+ offset 2))
94 (ldb (byte 16 0) fixup)))))))
95
96
97 ;;;; Internal-error-arguments.
98
99 ;;; INTERNAL-ERROR-ARGUMENTS -- interface.
100 ;;;
101 ;;; Given the sigcontext, extract the internal error arguments from the
102 ;;; instruction stream.
103 ;;;
104 (defun internal-error-arguments (scp)
105 (declare (type (alien (* sigcontext)) scp))
106 (with-alien ((scp (* sigcontext) scp))
107 (let ((pc (slot scp 'sc-pc)))
108 (declare (type system-area-pointer pc))
109 (when (logbitp 31 (slot scp 'sc-cause))
110 (setf pc (sap+ pc 4)))
111 (when (= (sap-ref-8 pc 4) 255)
112 (setf pc (sap+ pc 1)))
113 (let* ((length (sap-ref-8 pc 4))
114 (vector (make-array length :element-type '(unsigned-byte 8))))
115 (declare (type (unsigned-byte 8) length)
116 (type (simple-array (unsigned-byte 8) (*)) vector))
117 (copy-from-system-area pc (* vm:byte-bits 5)
118 vector (* vm:word-bits
119 vm:vector-data-offset)
120 (* length vm:byte-bits))
121 (let* ((index 0)
122 (error-number (c::read-var-integer vector index)))
123 (collect ((sc-offsets))
124 (loop
125 (when (>= index length)
126 (return))
127 (sc-offsets (c::read-var-integer vector index)))
128 (values error-number (sc-offsets))))))))
129
130
131 ;;;; Sigcontext access functions.
132
133 ;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface.
134 ;;;
135 (defun sigcontext-program-counter (scp)
136 (declare (type (alien (* sigcontext)) scp))
137 (with-alien ((scp (* sigcontext) scp))
138 (slot scp 'sc-pc)))
139
140 ;;; SIGCONTEXT-REGISTER -- Interface.
141 ;;;
142 ;;; An escape register saves the value of a register for a frame that someone
143 ;;; interrupts.
144 ;;;
145 (defun sigcontext-register (scp index)
146 (declare (type (alien (* sigcontext)) scp))
147 (with-alien ((scp (* sigcontext) scp))
148 (deref (slot scp 'sc-regs) (1+ (* index 2)))))
149
150 (defun %set-sigcontext-register (scp index new)
151 (declare (type (alien (* sigcontext)) scp))
152 (with-alien ((scp (* sigcontext) scp))
153 (setf (deref (slot scp 'sc-regs) (1+ (* index 2))) new)
154 new))
155
156 (defsetf sigcontext-register %set-sigcontext-register)
157
158
159 ;;; SIGCONTEXT-FLOAT-REGISTER -- Interface.
160 ;;;
161 ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.
162 ;;; Format is the type of float to return.
163 ;;;
164 (defun sigcontext-float-register (scp index format)
165 (declare (type (alien (* sigcontext)) scp))
166 (with-alien ((scp (* sigcontext) scp))
167 (let ((sap (alien-sap (slot scp 'sc-fpregs))))
168 (ecase format
169 (single-float (system:sap-ref-single sap (+ 4 (* index vm:word-bytes
170 2))))
171 (double-float (system:sap-ref-double sap (+ 4 (* index vm:word-bytes
172 2))))))))
173 ;;;
174 (defun %set-sigcontext-float-register (scp index format new-value)
175 (declare (type (alien (* sigcontext)) scp))
176 (with-alien ((scp (* sigcontext) scp))
177 (let ((sap (alien-sap (slot scp 'sc-fpregs))))
178 (ecase format
179 (single-float
180 (setf (sap-ref-single sap (+ 4 (* index vm:word-bytes 2))) new-value))
181 (double-float
182 (setf (sap-ref-double sap (+ 4 (* index vm:word-bytes 2)))
183 new-value))))))
184 ;;;
185 (defsetf sigcontext-float-register %set-sigcontext-float-register)
186
187
188 ;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface
189 ;;;
190 ;;; Given a sigcontext pointer, return the floating point modes word in the
191 ;;; same format as returned by FLOATING-POINT-MODES.
192 ;;;
193 (defun sigcontext-floating-point-modes (scp)
194 (declare (type (alien (* sigcontext)) scp))
195 (with-alien ((scp (* sigcontext) scp))
196 (slot scp 'sc-fpc-csr)))
197
198
199
200 ;;; EXTERN-ALIEN-NAME -- interface.
201 ;;;
202 ;;; The loader uses this to convert alien names to the form they occure in
203 ;;; the symbol table (for example, prepending an underscore). On the MIPS,
204 ;;; we don't do anything.
205 ;;;
206 (defun extern-alien-name (name)
207 (declare (type simple-base-string name))
208 name)
209
210
211
212 ;;; SANCTIFY-FOR-EXECUTION -- Interface.
213 ;;;
214 ;;; Do whatever is necessary to make the given code component executable.
215 ;;;
216 (defun sanctify-for-execution (component)
217 (without-gcing
218 (alien-funcall (extern-alien "sanctify_for_execution"
219 (function void
220 system-area-pointer
221 unsigned-long))
222 (code-instructions component)
223 (* (code-header-ref component code-code-size-slot)
224 word-bytes)))
225 nil)
226

  ViewVC Help
Powered by ViewVC 1.1.5