/[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.3 - (hide annotations)
Fri Mar 19 15:18:59 2010 UTC (4 years, 1 month ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.2: +3 -2 lines
Merge intl-branch 2010-03-18 to HEAD.  To build, you need to use
boot-2010-02-1 as the bootstrap file.  You should probably also use
the new -P option for build.sh to generate and update the po files
while building.
1 hallgren 1.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 rtoy 1.3 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/sgi-vm.lisp,v 1.3 2010/03/19 15:18:59 rtoy Rel $")
9 hallgren 1.1 ;;;
10     ;;; **********************************************************************
11     ;;;
12 rtoy 1.3 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/code/sgi-vm.lisp,v 1.3 2010/03/19 15:18:59 rtoy Rel $
13 hallgren 1.1 ;;;
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 rtoy 1.3 (intl:textdomain "cmucl")
22 hallgren 1.1
23     (export '(fixup-code-object internal-error-arguments
24     sigcontext-program-counter sigcontext-register
25     sigcontext-float-register sigcontext-floating-point-modes
26     extern-alien-name sanctify-for-execution))
27    
28    
29     ;;;; The sigcontext structure.
30    
31     (def-alien-type sigcontext
32     (struct nil
33     (sc-regmask unsigned-int)
34     (sc-status unsigned-int)
35     (sc-pc-high unsigned-int)
36     (sc-pc system-area-pointer)
37     (sc-regs (array unsigned-int 64)) ; 64 bit slots, so deref (* 2)+1
38     (sc-fpregs (array unsigned-int 64))
39     (sc-ownedfp unsigned-int)
40     (sc-fpc-csr unsigned-int)
41     (sc-fpc-eir unsigned-int)
42     (sc-ssflags unsigned-int)
43     (sc-mdhi-high unsigned-int)
44     (sc-mdhi unsigned-int)
45     (sc-mdlo-high unsigned-int)
46     (sc-mdlo unsigned-int)
47     (sc-cause-high unsigned-int)
48     (sc-cause unsigned-int)
49     (sc-badvaddr-high unsigned-int)
50     (sc-badvaddr system-area-pointer)
51     (sc-triggersave-high unsigned-int)
52     (sc-triggersave unsigned-int)
53     (sc-sigset (array unsigned-int 4))
54     (sc-pad (array unsigned-int 64))))
55    
56    
57     ;;;; Add machine specific features to *features*
58    
59     (pushnew :sgi *features*)
60    
61    
62    
63     ;;;; MACHINE-TYPE and MACHINE-VERSION
64    
65     (defun machine-type ()
66     "Returns a string describing the type of the local machine."
67     "SGI")
68    
69     (defun machine-version ()
70     "Returns a string describing the version of the local machine."
71     "SGI")
72    
73    
74    
75     ;;; FIXUP-CODE-OBJECT -- Interface
76     ;;;
77     (defun fixup-code-object (code offset fixup kind)
78     (unless (zerop (rem offset word-bytes))
79     (error "Unaligned instruction? offset=#x~X." offset))
80     (system:without-gcing
81     (let ((sap (truly-the system-area-pointer
82     (%primitive c::code-instructions code))))
83     (ecase kind
84     (:jump
85     (assert (zerop (ash fixup -28)))
86     (setf (ldb (byte 26 0) (system:sap-ref-32 sap offset))
87     (ash fixup -2)))
88     (:lui
89     (setf (sap-ref-16 sap (+ offset 2))
90     (+ (ash fixup -16)
91     (if (logbitp 15 fixup) 1 0))))
92     (:addi
93     (setf (sap-ref-16 sap (+ offset 2))
94     (ldb (byte 16 0) fixup)))))))
95    
96    
97     ;;;; Internal-error-arguments.
98    
99     ;;; INTERNAL-ERROR-ARGUMENTS -- interface.
100     ;;;
101     ;;; Given the sigcontext, extract the internal error arguments from the
102     ;;; instruction stream.
103     ;;;
104     (defun internal-error-arguments (scp)
105     (declare (type (alien (* sigcontext)) scp))
106     (with-alien ((scp (* sigcontext) scp))
107     (let ((pc (slot scp 'sc-pc)))
108     (declare (type system-area-pointer pc))
109     (when (logbitp 31 (slot scp 'sc-cause))
110     (setf pc (sap+ pc 4)))
111     (when (= (sap-ref-8 pc 4) 255)
112     (setf pc (sap+ pc 1)))
113     (let* ((length (sap-ref-8 pc 4))
114     (vector (make-array length :element-type '(unsigned-byte 8))))
115     (declare (type (unsigned-byte 8) length)
116     (type (simple-array (unsigned-byte 8) (*)) vector))
117     (copy-from-system-area pc (* vm:byte-bits 5)
118     vector (* vm:word-bits
119     vm:vector-data-offset)
120     (* length vm:byte-bits))
121     (let* ((index 0)
122     (error-number (c::read-var-integer vector index)))
123     (collect ((sc-offsets))
124     (loop
125     (when (>= index length)
126     (return))
127     (sc-offsets (c::read-var-integer vector index)))
128     (values error-number (sc-offsets))))))))
129    
130    
131     ;;;; Sigcontext access functions.
132    
133     ;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface.
134     ;;;
135     (defun sigcontext-program-counter (scp)
136     (declare (type (alien (* sigcontext)) scp))
137     (with-alien ((scp (* sigcontext) scp))
138     (slot scp 'sc-pc)))
139    
140     ;;; SIGCONTEXT-REGISTER -- Interface.
141     ;;;
142     ;;; An escape register saves the value of a register for a frame that someone
143     ;;; interrupts.
144     ;;;
145     (defun sigcontext-register (scp index)
146     (declare (type (alien (* sigcontext)) scp))
147     (with-alien ((scp (* sigcontext) scp))
148     (deref (slot scp 'sc-regs) (1+ (* index 2)))))
149    
150     (defun %set-sigcontext-register (scp index new)
151     (declare (type (alien (* sigcontext)) scp))
152     (with-alien ((scp (* sigcontext) scp))
153     (setf (deref (slot scp 'sc-regs) (1+ (* index 2))) new)
154     new))
155    
156     (defsetf sigcontext-register %set-sigcontext-register)
157    
158    
159     ;;; SIGCONTEXT-FLOAT-REGISTER -- Interface.
160     ;;;
161     ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.
162     ;;; Format is the type of float to return.
163     ;;;
164     (defun sigcontext-float-register (scp index format)
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 (system:sap-ref-single sap (+ 4 (* index vm:word-bytes
170     2))))
171     (double-float (system:sap-ref-double sap (+ 4 (* index vm:word-bytes
172     2))))))))
173     ;;;
174     (defun %set-sigcontext-float-register (scp index format new-value)
175     (declare (type (alien (* sigcontext)) scp))
176     (with-alien ((scp (* sigcontext) scp))
177     (let ((sap (alien-sap (slot scp 'sc-fpregs))))
178     (ecase format
179     (single-float
180     (setf (sap-ref-single sap (+ 4 (* index vm:word-bytes 2))) new-value))
181     (double-float
182     (setf (sap-ref-double sap (+ 4 (* index vm:word-bytes 2)))
183     new-value))))))
184     ;;;
185     (defsetf sigcontext-float-register %set-sigcontext-float-register)
186    
187    
188     ;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface
189     ;;;
190     ;;; Given a sigcontext pointer, return the floating point modes word in the
191     ;;; same format as returned by FLOATING-POINT-MODES.
192     ;;;
193     (defun sigcontext-floating-point-modes (scp)
194     (declare (type (alien (* sigcontext)) scp))
195     (with-alien ((scp (* sigcontext) scp))
196     (slot scp 'sc-fpc-csr)))
197    
198    
199    
200     ;;; EXTERN-ALIEN-NAME -- interface.
201     ;;;
202     ;;; The loader uses this to convert alien names to the form they occure in
203     ;;; the symbol table (for example, prepending an underscore). On the MIPS,
204     ;;; we don't do anything.
205     ;;;
206     (defun extern-alien-name (name)
207     (declare (type simple-base-string name))
208     name)
209    
210    
211    
212     ;;; SANCTIFY-FOR-EXECUTION -- Interface.
213     ;;;
214     ;;; Do whatever is necessary to make the given code component executable.
215     ;;;
216     (defun sanctify-for-execution (component)
217     (without-gcing
218     (alien-funcall (extern-alien "sanctify_for_execution"
219     (function void
220     system-area-pointer
221     unsigned-long))
222     (code-instructions component)
223     (* (code-header-ref component code-code-size-slot)
224     word-bytes)))
225     nil)
226    

  ViewVC Help
Powered by ViewVC 1.1.5