/[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.56.1 - (hide annotations)
Mon Feb 8 17:15:48 2010 UTC (4 years, 2 months ago) by rtoy
Branch: intl-branch
CVS Tags: intl-branch-working-2010-02-19-1000, intl-branch-working-2010-02-11-1000, intl-branch-2010-03-18-1300
Changes since 1.15: +4 -2 lines
Add (intl:textdomain "cmucl") to the files to set the textdomain.
1 wlott 1.3 ;;; -*- Package: MIPS -*-
2 wlott 1.1 ;;;
3     ;;; **********************************************************************
4 ram 1.7 ;;; 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.15.56.1 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/pmax-vm.lisp,v 1.15.56.1 2010/02/08 17:15:48 rtoy Exp $")
9 ram 1.7 ;;;
10 wlott 1.1 ;;; **********************************************************************
11     ;;;
12 rtoy 1.15.56.1 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/code/pmax-vm.lisp,v 1.15.56.1 2010/02/08 17:15:48 rtoy Exp $
13 wlott 1.1 ;;;
14     ;;; This file contains the PMAX specific runtime stuff.
15     ;;;
16 wlott 1.3 (in-package "MIPS")
17 wlott 1.2 (use-package "SYSTEM")
18 wlott 1.8 (use-package "ALIEN")
19     (use-package "C-CALL")
20     (use-package "UNIX")
21 wlott 1.1
22 rtoy 1.15.56.1 (intl:textdomain "cmucl")
23    
24 wlott 1.8 (export '(fixup-code-object internal-error-arguments
25 wlott 1.11 sigcontext-program-counter sigcontext-register
26     sigcontext-float-register sigcontext-floating-point-modes
27 wlott 1.12 extern-alien-name sanctify-for-execution))
28 wlott 1.1
29 wlott 1.2
30 wlott 1.8 ;;;; 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 wlott 1.2 ;;;; Add machine specific features to *features*
51    
52     (pushnew :decstation-3100 *features*)
53     (pushnew :pmax *features*)
54 wlott 1.6
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 wlott 1.2
67    
68    
69     ;;; FIXUP-CODE-OBJECT -- Interface
70     ;;;
71 wlott 1.1 (defun fixup-code-object (code offset fixup kind)
72 wlott 1.9 (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 wlott 1.3
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 wlott 1.8 (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 wlott 1.4 (declare (type system-area-pointer pc))
103 wlott 1.8 (when (logbitp 31 (slot scp 'sc-cause))
104 wlott 1.4 (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 wlott 1.3
124 ram 1.5
125 wlott 1.8 ;;;; Sigcontext access functions.
126    
127 wlott 1.11 ;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface.
128 wlott 1.8 ;;;
129 wlott 1.11 (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 wlott 1.8 ;;; 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 wlott 1.11 ;;; SIGCONTEXT-FLOAT-REGISTER -- Interface.
154 wlott 1.8 ;;;
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 wlott 1.9 (single-float (system:sap-ref-single sap (* index vm:word-bytes)))
164     (double-float (system:sap-ref-double sap (* index vm:word-bytes)))))))
165 wlott 1.8 ;;;
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 wlott 1.9 (setf (sap-ref-single sap (* index vm:word-bytes)) new-value))
173 wlott 1.8 (double-float
174 wlott 1.9 (setf (sap-ref-double sap (* index vm:word-bytes)) new-value))))))
175 wlott 1.8 ;;;
176     (defsetf sigcontext-float-register %set-sigcontext-float-register)
177    
178    
179 ram 1.5 ;;; 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 wlott 1.8 (declare (type (alien (* sigcontext)) scp))
186     (with-alien ((scp (* sigcontext) scp))
187     (slot scp 'sc-fpc-csr)))
188 wlott 1.10
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 wlott 1.12
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