/[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.10 - (hide annotations)
Sat Feb 22 00:04:21 1992 UTC (22 years, 2 months ago) by wlott
Branch: MAIN
Changes since 1.9: +15 -3 lines
Added EXTERN-ALIEN-NAME.
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     ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7     ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8     ;;;
9     (ext:file-comment
10 wlott 1.10 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/pmax-vm.lisp,v 1.10 1992/02/22 00:04:21 wlott Exp $")
11 ram 1.7 ;;;
12 wlott 1.1 ;;; **********************************************************************
13     ;;;
14 wlott 1.10 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/code/pmax-vm.lisp,v 1.10 1992/02/22 00:04:21 wlott Exp $
15 wlott 1.1 ;;;
16     ;;; This file contains the PMAX specific runtime stuff.
17     ;;;
18 wlott 1.3 (in-package "MIPS")
19 wlott 1.2 (use-package "SYSTEM")
20 wlott 1.8 (use-package "ALIEN")
21     (use-package "C-CALL")
22     (use-package "UNIX")
23 wlott 1.1
24 wlott 1.8 (export '(fixup-code-object internal-error-arguments
25     sigcontext-register sigcontext-float-register
26 wlott 1.10 sigcontext-floating-point-modes extern-alien-name))
27 wlott 1.1
28 wlott 1.2
29 wlott 1.8 ;;;; The sigcontext structure.
30    
31     (def-alien-type sigcontext
32     (struct nil
33     (sc-onstack unsigned-long)
34     (sc-mask unsigned-long)
35     (sc-pc system-area-pointer)
36     (sc-regs (array unsigned-long 32))
37     (sc-mdlo unsigned-long)
38     (sc-mdhi unsigned-long)
39     (sc-ownedfp unsigned-long)
40     (sc-fpregs (array unsigned-long 32))
41     (sc-fpc-csr unsigned-long)
42     (sc-fpc-eir unsigned-long)
43     (sc-cause unsigned-long)
44     (sc-badvaddr system-area-pointer)
45     (sc-badpaddr system-area-pointer)))
46    
47    
48    
49 wlott 1.2 ;;;; Add machine specific features to *features*
50    
51     (pushnew :decstation-3100 *features*)
52     (pushnew :pmax *features*)
53 wlott 1.6
54    
55    
56     ;;;; MACHINE-TYPE and MACHINE-VERSION
57    
58     (defun machine-type ()
59     "Returns a string describing the type of the local machine."
60     "DECstation")
61    
62     (defun machine-version ()
63     "Returns a string describing the version of the local machine."
64     "DECstation")
65 wlott 1.2
66    
67    
68     ;;; FIXUP-CODE-OBJECT -- Interface
69     ;;;
70 wlott 1.1 (defun fixup-code-object (code offset fixup kind)
71 wlott 1.9 (unless (zerop (rem offset word-bytes))
72     (error "Unaligned instruction? offset=#x~X." offset))
73     (system:without-gcing
74     (let ((sap (truly-the system-area-pointer
75     (%primitive c::code-instructions code))))
76     (ecase kind
77     (:jump
78     (assert (zerop (ash fixup -26)))
79     (setf (ldb (byte 26 0) (system:sap-ref-32 sap offset))
80     (ash fixup -2)))
81     (:lui
82     (setf (sap-ref-16 sap offset)
83     (+ (ash fixup -16)
84     (if (logbitp 15 fixup) 1 0))))
85     (:addi
86     (setf (sap-ref-16 sap offset)
87     (ldb (byte 16 0) fixup)))))))
88 wlott 1.3
89    
90     ;;;; Internal-error-arguments.
91    
92     ;;; INTERNAL-ERROR-ARGUMENTS -- interface.
93     ;;;
94     ;;; Given the sigcontext, extract the internal error arguments from the
95     ;;; instruction stream.
96     ;;;
97 wlott 1.8 (defun internal-error-arguments (scp)
98     (declare (type (alien (* sigcontext)) scp))
99     (with-alien ((scp (* sigcontext) scp))
100     (let ((pc (slot scp 'sc-pc)))
101 wlott 1.4 (declare (type system-area-pointer pc))
102 wlott 1.8 (when (logbitp 31 (slot scp 'sc-cause))
103 wlott 1.4 (setf pc (sap+ pc 4)))
104     (when (= (sap-ref-8 pc 4) 255)
105     (setf pc (sap+ pc 1)))
106     (let* ((length (sap-ref-8 pc 4))
107     (vector (make-array length :element-type '(unsigned-byte 8))))
108     (declare (type (unsigned-byte 8) length)
109     (type (simple-array (unsigned-byte 8) (*)) vector))
110     (copy-from-system-area pc (* vm:byte-bits 5)
111     vector (* vm:word-bits
112     vm:vector-data-offset)
113     (* length vm:byte-bits))
114     (let* ((index 0)
115     (error-number (c::read-var-integer vector index)))
116     (collect ((sc-offsets))
117     (loop
118     (when (>= index length)
119     (return))
120     (sc-offsets (c::read-var-integer vector index)))
121     (values error-number (sc-offsets))))))))
122 wlott 1.3
123 ram 1.5
124 wlott 1.8 ;;;; Sigcontext access functions.
125    
126     ;;; SIGCONTEXT-REGISTER -- Internal.
127     ;;;
128     ;;; An escape register saves the value of a register for a frame that someone
129     ;;; interrupts.
130     ;;;
131     (defun sigcontext-register (scp index)
132     (declare (type (alien (* sigcontext)) scp))
133     (with-alien ((scp (* sigcontext) scp))
134     (deref (slot scp 'sc-regs) index)))
135    
136     (defun %set-sigcontext-register (scp index new)
137     (declare (type (alien (* sigcontext)) scp))
138     (with-alien ((scp (* sigcontext) scp))
139     (setf (deref (slot scp 'sc-regs) index) new)
140     new))
141    
142     (defsetf sigcontext-register %set-sigcontext-register)
143    
144    
145     ;;; SIGCONTEXT-FLOAT-REGISTER -- Internal
146     ;;;
147     ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.
148     ;;; Format is the type of float to return.
149     ;;;
150     (defun sigcontext-float-register (scp index format)
151     (declare (type (alien (* sigcontext)) scp))
152     (with-alien ((scp (* sigcontext) scp))
153     (let ((sap (alien-sap (slot scp 'sc-fpregs))))
154     (ecase format
155 wlott 1.9 (single-float (system:sap-ref-single sap (* index vm:word-bytes)))
156     (double-float (system:sap-ref-double sap (* index vm:word-bytes)))))))
157 wlott 1.8 ;;;
158     (defun %set-sigcontext-float-register (scp index format new-value)
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
164 wlott 1.9 (setf (sap-ref-single sap (* index vm:word-bytes)) new-value))
165 wlott 1.8 (double-float
166 wlott 1.9 (setf (sap-ref-double sap (* index vm:word-bytes)) new-value))))))
167 wlott 1.8 ;;;
168     (defsetf sigcontext-float-register %set-sigcontext-float-register)
169    
170    
171 ram 1.5 ;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface
172     ;;;
173     ;;; Given a sigcontext pointer, return the floating point modes word in the
174     ;;; same format as returned by FLOATING-POINT-MODES.
175     ;;;
176     (defun sigcontext-floating-point-modes (scp)
177 wlott 1.8 (declare (type (alien (* sigcontext)) scp))
178     (with-alien ((scp (* sigcontext) scp))
179     (slot scp 'sc-fpc-csr)))
180 wlott 1.10
181    
182    
183     ;;; EXTERN-ALIEN-NAME -- interface.
184     ;;;
185     ;;; The loader uses this to convert alien names to the form they occure in
186     ;;; the symbol table (for example, prepending an underscore). On the MIPS,
187     ;;; we don't do anything.
188     ;;;
189     (defun extern-alien-name (name)
190     (declare (type simple-base-string name))
191     name)

  ViewVC Help
Powered by ViewVC 1.1.5