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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.15.58.1 - (show annotations)
Thu Feb 25 20:34:50 2010 UTC (4 years, 1 month ago) by rtoy
Branch: intl-2-branch
Changes since 1.15: +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 ;;; -*- 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/pmax-vm.lisp,v 1.15.58.1 2010/02/25 20:34:50 rtoy Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/code/pmax-vm.lisp,v 1.15.58.1 2010/02/25 20:34:50 rtoy Exp $
13 ;;;
14 ;;; This file contains the PMAX 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
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-regs (array unsigned-long 32))
38 (sc-mdlo unsigned-long)
39 (sc-mdhi unsigned-long)
40 (sc-ownedfp unsigned-long)
41 (sc-fpregs (array unsigned-long 32))
42 (sc-fpc-csr unsigned-long)
43 (sc-fpc-eir unsigned-long)
44 (sc-cause unsigned-long)
45 (sc-badvaddr system-area-pointer)
46 (sc-badpaddr system-area-pointer)))
47
48
49
50 ;;;; Add machine specific features to *features*
51
52 (pushnew :decstation-3100 *features*)
53 (pushnew :pmax *features*)
54
55
56
57 ;;;; MACHINE-TYPE and MACHINE-VERSION
58
59 (defun machine-type ()
60 "Returns a string describing the type of the local machine."
61 "DECstation")
62
63 (defun machine-version ()
64 "Returns a string describing the version of the local machine."
65 "DECstation")
66
67
68
69 ;;; FIXUP-CODE-OBJECT -- Interface
70 ;;;
71 (defun fixup-code-object (code offset fixup kind)
72 (unless (zerop (rem offset word-bytes))
73 (error "Unaligned instruction? offset=#x~X." offset))
74 (system:without-gcing
75 (let ((sap (truly-the system-area-pointer
76 (%primitive c::code-instructions code))))
77 (ecase kind
78 (:jump
79 (assert (zerop (ash fixup -26)))
80 (setf (ldb (byte 26 0) (system:sap-ref-32 sap offset))
81 (ash fixup -2)))
82 (:lui
83 (setf (sap-ref-16 sap offset)
84 (+ (ash fixup -16)
85 (if (logbitp 15 fixup) 1 0))))
86 (:addi
87 (setf (sap-ref-16 sap offset)
88 (ldb (byte 16 0) fixup)))))))
89
90
91 ;;;; Internal-error-arguments.
92
93 ;;; INTERNAL-ERROR-ARGUMENTS -- interface.
94 ;;;
95 ;;; Given the sigcontext, extract the internal error arguments from the
96 ;;; instruction stream.
97 ;;;
98 (defun internal-error-arguments (scp)
99 (declare (type (alien (* sigcontext)) scp))
100 (with-alien ((scp (* sigcontext) scp))
101 (let ((pc (slot scp 'sc-pc)))
102 (declare (type system-area-pointer pc))
103 (when (logbitp 31 (slot scp 'sc-cause))
104 (setf pc (sap+ pc 4)))
105 (when (= (sap-ref-8 pc 4) 255)
106 (setf pc (sap+ pc 1)))
107 (let* ((length (sap-ref-8 pc 4))
108 (vector (make-array length :element-type '(unsigned-byte 8))))
109 (declare (type (unsigned-byte 8) length)
110 (type (simple-array (unsigned-byte 8) (*)) vector))
111 (copy-from-system-area pc (* vm:byte-bits 5)
112 vector (* vm:word-bits
113 vm:vector-data-offset)
114 (* length vm:byte-bits))
115 (let* ((index 0)
116 (error-number (c::read-var-integer vector index)))
117 (collect ((sc-offsets))
118 (loop
119 (when (>= index length)
120 (return))
121 (sc-offsets (c::read-var-integer vector index)))
122 (values error-number (sc-offsets))))))))
123
124
125 ;;;; Sigcontext access functions.
126
127 ;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface.
128 ;;;
129 (defun sigcontext-program-counter (scp)
130 (declare (type (alien (* sigcontext)) scp))
131 (with-alien ((scp (* sigcontext) scp))
132 (slot scp 'sc-pc)))
133
134 ;;; SIGCONTEXT-REGISTER -- Interface.
135 ;;;
136 ;;; An escape register saves the value of a register for a frame that someone
137 ;;; interrupts.
138 ;;;
139 (defun sigcontext-register (scp index)
140 (declare (type (alien (* sigcontext)) scp))
141 (with-alien ((scp (* sigcontext) scp))
142 (deref (slot scp 'sc-regs) index)))
143
144 (defun %set-sigcontext-register (scp index new)
145 (declare (type (alien (* sigcontext)) scp))
146 (with-alien ((scp (* sigcontext) scp))
147 (setf (deref (slot scp 'sc-regs) index) new)
148 new))
149
150 (defsetf sigcontext-register %set-sigcontext-register)
151
152
153 ;;; SIGCONTEXT-FLOAT-REGISTER -- Interface.
154 ;;;
155 ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.
156 ;;; Format is the type of float to return.
157 ;;;
158 (defun sigcontext-float-register (scp index format)
159 (declare (type (alien (* sigcontext)) scp))
160 (with-alien ((scp (* sigcontext) scp))
161 (let ((sap (alien-sap (slot scp 'sc-fpregs))))
162 (ecase format
163 (single-float (system:sap-ref-single sap (* index vm:word-bytes)))
164 (double-float (system:sap-ref-double sap (* index vm:word-bytes)))))))
165 ;;;
166 (defun %set-sigcontext-float-register (scp index format new-value)
167 (declare (type (alien (* sigcontext)) scp))
168 (with-alien ((scp (* sigcontext) scp))
169 (let ((sap (alien-sap (slot scp 'sc-fpregs))))
170 (ecase format
171 (single-float
172 (setf (sap-ref-single sap (* index vm:word-bytes)) new-value))
173 (double-float
174 (setf (sap-ref-double sap (* index vm:word-bytes)) new-value))))))
175 ;;;
176 (defsetf sigcontext-float-register %set-sigcontext-float-register)
177
178
179 ;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface
180 ;;;
181 ;;; Given a sigcontext pointer, return the floating point modes word in the
182 ;;; same format as returned by FLOATING-POINT-MODES.
183 ;;;
184 (defun sigcontext-floating-point-modes (scp)
185 (declare (type (alien (* sigcontext)) scp))
186 (with-alien ((scp (* sigcontext) scp))
187 (slot scp 'sc-fpc-csr)))
188
189
190
191 ;;; EXTERN-ALIEN-NAME -- interface.
192 ;;;
193 ;;; The loader uses this to convert alien names to the form they occure in
194 ;;; the symbol table (for example, prepending an underscore). On the MIPS,
195 ;;; we don't do anything.
196 ;;;
197 (defun extern-alien-name (name)
198 (declare (type simple-base-string name))
199 name)
200
201
202
203 ;;; SANCTIFY-FOR-EXECUTION -- Interface.
204 ;;;
205 ;;; Do whatever is necessary to make the given code component executable.
206 ;;;
207 (defun sanctify-for-execution (component)
208 (declare (ignore component))
209 nil)

  ViewVC Help
Powered by ViewVC 1.1.5