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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (show annotations)
Tue Apr 20 17:57:43 2010 UTC (4 years ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, 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-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.7: +4 -4 lines
Change uses of _"foo" to (intl:gettext "foo").  This is because slime
may get confused with source locations if the reader macros are
installed.
1 ;;; -*- Package: ALPHA -*-
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/alpha-vm.lisp,v 1.8 2010/04/20 17:57:43 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/code/alpha-vm.lisp,v 1.8 2010/04/20 17:57:43 rtoy Rel $
13 ;;;
14 ;;; This file contains the Alpha specific runtime stuff.
15 ;;;
16 (in-package "ALPHA")
17 (use-package "SYSTEM")
18 (use-package "ALIEN")
19 (use-package "C-CALL")
20 (use-package "UNIX")
21
22 (intl:textdomain "cmucl")
23
24 (export '(fixup-code-object internal-error-arguments
25 sigcontext-program-counter sigcontext-register
26 sigcontext-float-register sigcontext-floating-point-modes
27 extern-alien-name sanctify-for-execution))
28
29
30 ;;;; The sigcontext structure.
31
32 (def-alien-type sigcontext
33 (struct nil
34 (sc-onstack unsigned-long)
35 (sc-mask unsigned-long)
36 (sc-pc system-area-pointer)
37 (sc-ps unsigned-long)
38 (sc-regs (array unsigned-long 32))
39 (sc-ownedfp unsigned-long)
40 (sc-fpregs (array unsigned-long 32))
41 (sc-fpcr unsigned-long)
42 (sc-fp-control unsigned-long)
43 (sc-reserved1 unsigned-long)
44 (sc-reserved2 unsigned-long)
45 (sc-reserved3 unsigned-long)
46 (sc-reserved4 unsigned-long)
47 (sc-traparg-a0 unsigned-long)
48 (sc-traparg-a1 unsigned-long)
49 (sc-traparg-a2 unsigned-long)
50 (sc-fp-trap-pc unsigned-long) ; imprecise pc
51 (sc-fp-trigger-sum unsigned-long)
52 (sc-fp-trigger-inst unsigned-long)))
53
54
55
56 ;;;; Add machine specific features to *features*
57
58 (pushnew :alpha *features*)
59
60
61
62 ;;;; MACHINE-TYPE and MACHINE-VERSION
63
64 (defun machine-type ()
65 "Returns a string describing the type of the local machine."
66 "DECstation")
67
68 (defun machine-version ()
69 "Returns a string describing the version of the local machine."
70 "DECstation")
71
72
73
74 ;;; FIXUP-CODE-OBJECT -- Interface
75 ;;;
76 (defun fixup-code-object (code offset value kind)
77 (unless (zerop (rem offset word-bytes))
78 (error (intl:gettext "Unaligned instruction? offset=#x~X.") offset))
79 (system:without-gcing
80 (let ((sap (truly-the system-area-pointer
81 (%primitive c::code-instructions code))))
82 (ecase kind
83 (:jmp-hint
84 (assert (zerop (ldb (byte 2 0) value)))
85 #+nil
86 (setf (sap-ref-16 sap offset)
87 (logior (sap-ref-16 sap offset) (ldb (byte 14 0) (ash value -2)))))
88 (:bits-63-48
89 (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))
90 (value (if (logbitp 31 value) (+ value (ash 1 32)) value))
91 (value (if (logbitp 47 value) (+ value (ash 1 48)) value)))
92 (setf (sap-ref-8 sap offset) (ldb (byte 8 48) value))
93 (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 56) value))))
94 (:bits-47-32
95 (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))
96 (value (if (logbitp 31 value) (+ value (ash 1 32)) value)))
97 (setf (sap-ref-8 sap offset) (ldb (byte 8 32) value))
98 (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 40) value))))
99 (:ldah
100 (let ((value (if (logbitp 15 value) (+ value (ash 1 16)) value)))
101 (setf (sap-ref-8 sap offset) (ldb (byte 8 16) value))
102 (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 24) value))))
103 (:lda
104 (setf (sap-ref-8 sap offset) (ldb (byte 8 0) value))
105 (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 8) value)))))))
106
107
108
109 ;;;; Internal-error-arguments.
110
111 ;;; INTERNAL-ERROR-ARGUMENTS -- interface.
112 ;;;
113 ;;; Given the sigcontext, extract the internal error arguments from the
114 ;;; instruction stream.
115 ;;;
116 (defun internal-error-arguments (scp)
117 (declare (type (alien (* sigcontext)) scp))
118 (with-alien ((scp (* sigcontext) scp))
119 (let ((pc (slot scp 'sc-pc)))
120 (declare (type system-area-pointer pc))
121 (let* ((length (sap-ref-8 pc 4))
122 (vector (make-array length :element-type '(unsigned-byte 8))))
123 (declare (type (unsigned-byte 8) length)
124 (type (simple-array (unsigned-byte 8) (*)) vector))
125 (copy-from-system-area pc (* vm:byte-bits 5)
126 vector (* vm:word-bits
127 vm:vector-data-offset)
128 (* length vm:byte-bits))
129 (let* ((index 0)
130 (error-number (c::read-var-integer vector index)))
131 (collect ((sc-offsets))
132 (loop
133 (when (>= index length)
134 (return))
135 (sc-offsets (c::read-var-integer vector index)))
136 (values error-number (sc-offsets))))))))
137
138
139 ;;;; Sigcontext access functions.
140
141 ;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface.
142 ;;;
143 (defun sigcontext-program-counter (scp)
144 (declare (type (alien (* sigcontext)) scp))
145 (with-alien ((scp (* sigcontext) scp))
146 (slot scp 'sc-pc)))
147
148 ;;; SIGCONTEXT-REGISTER -- Interface.
149 ;;;
150 ;;; An escape register saves the value of a register for a frame that someone
151 ;;; interrupts.
152 ;;;
153 (defun sigcontext-register (scp index)
154 (declare (type (alien (* sigcontext)) scp))
155 (with-alien ((scp (* sigcontext) scp))
156 (deref (slot scp 'sc-regs) index)))
157
158 (defun %set-sigcontext-register (scp index new)
159 (declare (type (alien (* sigcontext)) scp))
160 (with-alien ((scp (* sigcontext) scp))
161 (setf (deref (slot scp 'sc-regs) index) new)
162 new))
163
164 (defsetf sigcontext-register %set-sigcontext-register)
165
166
167 ;;; SIGCONTEXT-FLOAT-REGISTER -- Interface.
168 ;;;
169 ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.
170 ;;; Format is the type of float to return.
171 ;;;
172 (defun sigcontext-float-register (scp index format)
173 (declare (type (alien (* sigcontext)) scp))
174 (with-alien ((scp (* sigcontext) scp))
175 (let ((sap (alien-sap (slot scp 'sc-fpregs))))
176 (ecase format
177 (single-float (system:sap-ref-single sap (* index vm:word-bytes)))
178 (double-float (system:sap-ref-double sap (* index vm:word-bytes)))))))
179 ;;;
180 (defun %set-sigcontext-float-register (scp index format new-value)
181 (declare (type (alien (* sigcontext)) scp))
182 (with-alien ((scp (* sigcontext) scp))
183 (let ((sap (alien-sap (slot scp 'sc-fpregs))))
184 (ecase format
185 (single-float
186 (setf (sap-ref-single sap (* index vm:word-bytes)) new-value))
187 (double-float
188 (setf (sap-ref-double sap (* index vm:word-bytes)) new-value))))))
189 ;;;
190 (defsetf sigcontext-float-register %set-sigcontext-float-register)
191
192
193 ;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface
194 ;;;
195 ;;; Given a sigcontext pointer, return the floating point modes word in the
196 ;;; same format as returned by FLOATING-POINT-MODES.
197 ;;;
198 (defun sigcontext-floating-point-modes (scp)
199 (declare (type (alien (* sigcontext)) scp))
200 (with-alien ((scp (* sigcontext) scp))
201 (slot scp 'sc-fpcr)))
202
203
204
205 ;;; EXTERN-ALIEN-NAME -- interface.
206 ;;;
207 ;;; The loader uses this to convert alien names to the form they occur in
208 ;;; the symbol table (for example, prepending an underscore). On the MIPS,
209 ;;; we don't do anything.
210 ;;;
211 (defun extern-alien-name (name)
212 (declare (type simple-base-string name))
213 name)
214
215 #+(and (or linux (and freebsd elf)) (not linkage-table))
216 (defun lisp::foreign-symbol-address-aux (name flavor)
217 (declare (ignore flavor))
218 (multiple-value-bind (value found)
219 (gethash name lisp::*foreign-symbols* 0)
220 (if found
221 value
222 (multiple-value-bind (value found)
223 (gethash
224 (concatenate 'string "PVE_stub_" name)
225 lisp::*foreign-symbols* 0)
226 (if found
227 value
228 (let ((value (system:alternate-get-global-address name)))
229 (when (zerop value)
230 (error (intl:gettext "Unknown foreign symbol: ~S") name))
231 value))))))
232
233
234
235 ;;; SANCTIFY-FOR-EXECUTION -- Interface.
236 ;;;
237 ;;; Do whatever is necessary to make the given code component executable.
238 ;;;
239 (defun sanctify-for-execution (component)
240 (declare (ignore component))
241 (%primitive istream-memory-barrier))

  ViewVC Help
Powered by ViewVC 1.1.5