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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Mon Oct 31 04:11:27 1994 UTC (19 years, 5 months ago) by ram
Branch: MAIN
CVS Tags: double-double-array-base, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, unicode-string-buffer-base, RELEASE_18d, sse2-packed-base, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, RELEASE_18a, RELEASE_18b, RELEASE_18c, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2007-06, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, double-double-init-x86, sse2-checkpoint-2008-10-01, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, RELENG_18, unicode-string-buffer-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.1: +2 -4 lines
Fix headed boilerplate.
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/sgi-vm.lisp,v 1.2 1994/10/31 04:11:27 ram Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/code/sgi-vm.lisp,v 1.2 1994/10/31 04:11:27 ram Rel $
13 ;;;
14 ;;; This file contains the SGI 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 (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-regmask unsigned-int)
33 (sc-status unsigned-int)
34 (sc-pc-high unsigned-int)
35 (sc-pc system-area-pointer)
36 (sc-regs (array unsigned-int 64)) ; 64 bit slots, so deref (* 2)+1
37 (sc-fpregs (array unsigned-int 64))
38 (sc-ownedfp unsigned-int)
39 (sc-fpc-csr unsigned-int)
40 (sc-fpc-eir unsigned-int)
41 (sc-ssflags unsigned-int)
42 (sc-mdhi-high unsigned-int)
43 (sc-mdhi unsigned-int)
44 (sc-mdlo-high unsigned-int)
45 (sc-mdlo unsigned-int)
46 (sc-cause-high unsigned-int)
47 (sc-cause unsigned-int)
48 (sc-badvaddr-high unsigned-int)
49 (sc-badvaddr system-area-pointer)
50 (sc-triggersave-high unsigned-int)
51 (sc-triggersave unsigned-int)
52 (sc-sigset (array unsigned-int 4))
53 (sc-pad (array unsigned-int 64))))
54
55
56 ;;;; Add machine specific features to *features*
57
58 (pushnew :sgi *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 "SGI")
67
68 (defun machine-version ()
69 "Returns a string describing the version of the local machine."
70 "SGI")
71
72
73
74 ;;; FIXUP-CODE-OBJECT -- Interface
75 ;;;
76 (defun fixup-code-object (code offset fixup 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 (:jump
84 (assert (zerop (ash fixup -28)))
85 (setf (ldb (byte 26 0) (system:sap-ref-32 sap offset))
86 (ash fixup -2)))
87 (:lui
88 (setf (sap-ref-16 sap (+ offset 2))
89 (+ (ash fixup -16)
90 (if (logbitp 15 fixup) 1 0))))
91 (:addi
92 (setf (sap-ref-16 sap (+ offset 2))
93 (ldb (byte 16 0) fixup)))))))
94
95
96 ;;;; Internal-error-arguments.
97
98 ;;; INTERNAL-ERROR-ARGUMENTS -- interface.
99 ;;;
100 ;;; Given the sigcontext, extract the internal error arguments from the
101 ;;; instruction stream.
102 ;;;
103 (defun internal-error-arguments (scp)
104 (declare (type (alien (* sigcontext)) scp))
105 (with-alien ((scp (* sigcontext) scp))
106 (let ((pc (slot scp 'sc-pc)))
107 (declare (type system-area-pointer pc))
108 (when (logbitp 31 (slot scp 'sc-cause))
109 (setf pc (sap+ pc 4)))
110 (when (= (sap-ref-8 pc 4) 255)
111 (setf pc (sap+ pc 1)))
112 (let* ((length (sap-ref-8 pc 4))
113 (vector (make-array length :element-type '(unsigned-byte 8))))
114 (declare (type (unsigned-byte 8) length)
115 (type (simple-array (unsigned-byte 8) (*)) vector))
116 (copy-from-system-area pc (* vm:byte-bits 5)
117 vector (* vm:word-bits
118 vm:vector-data-offset)
119 (* length vm:byte-bits))
120 (let* ((index 0)
121 (error-number (c::read-var-integer vector index)))
122 (collect ((sc-offsets))
123 (loop
124 (when (>= index length)
125 (return))
126 (sc-offsets (c::read-var-integer vector index)))
127 (values error-number (sc-offsets))))))))
128
129
130 ;;;; Sigcontext access functions.
131
132 ;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface.
133 ;;;
134 (defun sigcontext-program-counter (scp)
135 (declare (type (alien (* sigcontext)) scp))
136 (with-alien ((scp (* sigcontext) scp))
137 (slot scp 'sc-pc)))
138
139 ;;; SIGCONTEXT-REGISTER -- Interface.
140 ;;;
141 ;;; An escape register saves the value of a register for a frame that someone
142 ;;; interrupts.
143 ;;;
144 (defun sigcontext-register (scp index)
145 (declare (type (alien (* sigcontext)) scp))
146 (with-alien ((scp (* sigcontext) scp))
147 (deref (slot scp 'sc-regs) (1+ (* index 2)))))
148
149 (defun %set-sigcontext-register (scp index new)
150 (declare (type (alien (* sigcontext)) scp))
151 (with-alien ((scp (* sigcontext) scp))
152 (setf (deref (slot scp 'sc-regs) (1+ (* index 2))) new)
153 new))
154
155 (defsetf sigcontext-register %set-sigcontext-register)
156
157
158 ;;; SIGCONTEXT-FLOAT-REGISTER -- Interface.
159 ;;;
160 ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.
161 ;;; Format is the type of float to return.
162 ;;;
163 (defun sigcontext-float-register (scp index format)
164 (declare (type (alien (* sigcontext)) scp))
165 (with-alien ((scp (* sigcontext) scp))
166 (let ((sap (alien-sap (slot scp 'sc-fpregs))))
167 (ecase format
168 (single-float (system:sap-ref-single sap (+ 4 (* index vm:word-bytes
169 2))))
170 (double-float (system:sap-ref-double sap (+ 4 (* index vm:word-bytes
171 2))))))))
172 ;;;
173 (defun %set-sigcontext-float-register (scp index format new-value)
174 (declare (type (alien (* sigcontext)) scp))
175 (with-alien ((scp (* sigcontext) scp))
176 (let ((sap (alien-sap (slot scp 'sc-fpregs))))
177 (ecase format
178 (single-float
179 (setf (sap-ref-single sap (+ 4 (* index vm:word-bytes 2))) new-value))
180 (double-float
181 (setf (sap-ref-double sap (+ 4 (* index vm:word-bytes 2)))
182 new-value))))))
183 ;;;
184 (defsetf sigcontext-float-register %set-sigcontext-float-register)
185
186
187 ;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface
188 ;;;
189 ;;; Given a sigcontext pointer, return the floating point modes word in the
190 ;;; same format as returned by FLOATING-POINT-MODES.
191 ;;;
192 (defun sigcontext-floating-point-modes (scp)
193 (declare (type (alien (* sigcontext)) scp))
194 (with-alien ((scp (* sigcontext) scp))
195 (slot scp 'sc-fpc-csr)))
196
197
198
199 ;;; EXTERN-ALIEN-NAME -- interface.
200 ;;;
201 ;;; The loader uses this to convert alien names to the form they occure in
202 ;;; the symbol table (for example, prepending an underscore). On the MIPS,
203 ;;; we don't do anything.
204 ;;;
205 (defun extern-alien-name (name)
206 (declare (type simple-base-string name))
207 name)
208
209
210
211 ;;; SANCTIFY-FOR-EXECUTION -- Interface.
212 ;;;
213 ;;; Do whatever is necessary to make the given code component executable.
214 ;;;
215 (defun sanctify-for-execution (component)
216 (without-gcing
217 (alien-funcall (extern-alien "sanctify_for_execution"
218 (function void
219 system-area-pointer
220 unsigned-long))
221 (code-instructions component)
222 (* (code-header-ref component code-code-size-slot)
223 word-bytes)))
224 nil)
225

  ViewVC Help
Powered by ViewVC 1.1.5