/[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.14.1 - (hide annotations)
Thu Feb 25 20:34:48 2010 UTC (4 years, 1 month ago) by rtoy
Branch: intl-2-branch
Changes since 1.5: +4 -2 lines
Restart internalization work.  This new branch starts with code from
the intl-branch on date 2010-02-12 18:00:00+0500.  This version works
and

LANG=en@piglatin bin/lisp

works (once the piglatin translation is added).
1 hallgren 1.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 rtoy 1.5.14.1 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/alpha-vm.lisp,v 1.5.14.1 2010/02/25 20:34:48 rtoy Exp $")
9 hallgren 1.1 ;;;
10     ;;; **********************************************************************
11     ;;;
12 rtoy 1.5.14.1 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/code/alpha-vm.lisp,v 1.5.14.1 2010/02/25 20:34:48 rtoy Exp $
13 hallgren 1.1 ;;;
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 rtoy 1.5.14.1 (intl:textdomain "cmucl")
23    
24 hallgren 1.1 (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 "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 rtoy 1.5 ;;; The loader uses this to convert alien names to the form they occur in
208 hallgren 1.1 ;;; 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 toy 1.3
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 "Unknown foreign symbol: ~S" name))
231     value))))))
232 hallgren 1.1
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 pmai 1.4 (%primitive istream-memory-barrier))

  ViewVC Help
Powered by ViewVC 1.1.5