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

  ViewVC Help
Powered by ViewVC 1.1.5