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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (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.7: +3 -1 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 wlott 1.1 ;;; -*- Package: RT -*-
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.8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/rt-vm.lisp,v 1.8 2010/03/19 15:18:59 rtoy Rel $")
9 wlott 1.1 ;;;
10     ;;; **********************************************************************
11     ;;;
12     ;;; This file contains the RT specific runtime stuff.
13     ;;;
14     (in-package "RT")
15     (use-package "SYSTEM")
16 wlott 1.6 (use-package "ALIEN")
17     (use-package "C-CALL")
18     (use-package "UNIX")
19 wlott 1.1
20 rtoy 1.8 (intl:textdomain "cmucl")
21    
22 wlott 1.6 (export '(fixup-code-object internal-error-arguments
23     sigcontext-register sigcontext-float-register
24     sigcontext-floating-point-modes extern-alien-name))
25 wlott 1.1
26    
27 wlott 1.6 ;;;; The sigcontext structure.
28    
29     (def-alien-type sigcontext
30     (struct nil
31     (sc-onstack unsigned-long)
32     (sc-mask unsigned-long)
33     (sc-floatsave system-area-pointer)
34     (sc-sp system-area-pointer)
35     (sc-fp system-area-pointer)
36     (sc-ap system-area-pointer)
37     (sc-pc system-area-pointer) ; IBM calls it the iar.
38     (sc-icscs unsigned-long)
39     (sc-saveiar system-area-pointer)
40     (sc-regs (array unsigned-long 16))))
41    
42    
43    
44 wlott 1.1 ;;;; Add machine specific features to *features*
45    
46     (pushnew :ibm-pc-rt *features*)
47     (pushnew :ibmrt *features*)
48     (pushnew :rt *features*)
49    
50    
51    
52     ;;;; MACHINE-TYPE and MACHINE-VERSION
53    
54     (defun machine-type ()
55     "Returns a string describing the type of the local machine."
56     "IBM PC/RT")
57    
58     (defun machine-version ()
59     "Returns a string describing the version of the local machine."
60     "IBM PC/RT")
61    
62    
63    
64     ;;; FIXUP-CODE-OBJECT -- Interface
65     ;;;
66     (defun fixup-code-object (code offset fixup kind)
67 wlott 1.2 (declare (type index offset) (type (unsigned-byte 32) fixup))
68     (system:without-gcing
69     (let ((sap (sap+ (kernel:code-instructions code) offset)))
70     (ecase kind
71     (:cal
72 wlott 1.5 (setf (sap-ref-16 sap 2)
73 wlott 1.2 (ldb (byte 16 0) fixup)))
74     (:cau
75     (let ((high (ldb (byte 16 16) fixup)))
76 wlott 1.5 (setf (sap-ref-16 sap 2)
77 wlott 1.2 (if (logbitp 15 fixup) (1+ high) high))))
78     (:ba
79     (unless (zerop (ash fixup -24))
80     (warn "#x~8,'0X out of range for branch-absolute." fixup))
81     (setf (sap-ref-8 sap 1)
82     (ldb (byte 8 16) fixup))
83 wlott 1.5 (setf (sap-ref-16 sap 2)
84 wlott 1.2 (ldb (byte 16 0) fixup)))))))
85 wlott 1.1
86    
87    
88     ;;;; Internal-error-arguments.
89    
90     ;;; INTERNAL-ERROR-ARGUMENTS -- interface.
91     ;;;
92     ;;; Given the sigcontext, extract the internal error arguments from the
93     ;;; instruction stream.
94     ;;;
95 wlott 1.6 (defun internal-error-arguments (scp)
96     (with-alien ((scp (* sigcontext) scp))
97     (let ((pc (slot scp 'sc-pc)))
98 wlott 1.3 (declare (type system-area-pointer pc))
99     (let* ((length (sap-ref-8 pc 4))
100     (vector (make-array length :element-type '(unsigned-byte 8))))
101     (declare (type (unsigned-byte 8) length)
102     (type (simple-array (unsigned-byte 8) (*)) vector))
103     (copy-from-system-area pc (* vm:byte-bits 5)
104     vector (* vm:word-bits
105     vm:vector-data-offset)
106     (* length vm:byte-bits))
107     (let* ((index 0)
108     (error-number (c::read-var-integer vector index)))
109     (collect ((sc-offsets))
110     (loop
111     (when (>= index length)
112     (return))
113     (sc-offsets (c::read-var-integer vector index)))
114     (values error-number (sc-offsets))))))))
115    
116 wlott 1.1
117    
118 wlott 1.6 ;;;; Sigcontext accessing stuff.
119    
120     ;;; SIGCONTEXT-REGISTER -- Internal.
121     ;;;
122     ;;; An escape register saves the value of a register for a frame that someone
123     ;;; interrupts.
124     ;;;
125     (defun sigcontext-register (scp index)
126     (declare (type (alien (* sigcontext)) scp))
127     (with-alien ((scp (* sigcontext) scp))
128     (deref (slot scp 'sc-regs) index)))
129    
130     (defun %set-sigcontext-register (scp index new)
131     (declare (type (alien (* sigcontext)) scp))
132     (with-alien ((scp (* sigcontext) scp))
133     (setf (deref (slot scp 'sc-regs) index) new)
134     new))
135    
136     (defsetf sigcontext-register %set-sigcontext-register)
137    
138    
139     ;;; SIGCONTEXT-FLOAT-REGISTER -- Internal
140     ;;;
141     ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.
142     ;;; Format is the type of float to return.
143     ;;;
144     (defun sigcontext-float-register (scp index format)
145     (declare (type (alien (* sigcontext)) scp)
146     (ignore scp index))
147     ;; ### Some day we should figure out how to do this right.
148     (ecase format
149     (single-float 0.0s0)
150     (double-float 0.0d0)))
151     ;;;
152     (defun %set-sigcontext-float-register (scp index format new-value)
153     (declare (type (alien (* sigcontext)) scp)
154     (ignore scp index format))
155     ;; ### Some day we should figure out how to do this right.
156     new-value)
157     ;;;
158     (defsetf sigcontext-float-register %set-sigcontext-float-register)
159    
160    
161 wlott 1.1 ;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface
162     ;;;
163     ;;; Given a sigcontext pointer, return the floating point modes word in the
164     ;;; same format as returned by FLOATING-POINT-MODES.
165     ;;;
166     (defun sigcontext-floating-point-modes (scp)
167 wlott 1.6 (declare (ignore scp))
168     ;; ### Some day we should figure out how to do this right.
169     0)
170    
171    
172    
173    
174     ;;; EXTERN-ALIEN-NAME -- interface.
175     ;;;
176     ;;; The loader uses this to convert alien names to the form they occure in
177     ;;; the symbol table (for example, prepending an underscore). On the RT,
178     ;;; we prepend an underscore.
179     ;;;
180     (defun extern-alien-name (name)
181     (declare (type simple-base-string name))
182     (concatenate 'string "_" name))
183    

  ViewVC Help
Powered by ViewVC 1.1.5