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

  ViewVC Help
Powered by ViewVC 1.1.5