/[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.3 - (hide annotations)
Tue Nov 19 13:17:13 2002 UTC (11 years, 5 months ago) by toy
Branch: MAIN
Changes since 1.2: +20 -2 lines
Alpha Linux support from Brian.
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 toy 1.3 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/alpha-vm.lisp,v 1.3 2002/11/19 13:17:13 toy Exp $")
9 hallgren 1.1 ;;;
10     ;;; **********************************************************************
11     ;;;
12 toy 1.3 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/code/alpha-vm.lisp,v 1.3 2002/11/19 13:17:13 toy 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     (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 occure 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 toy 1.3
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 hallgren 1.1
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     nil)

  ViewVC Help
Powered by ViewVC 1.1.5