/[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 - (show 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 ;;; -*- 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 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/rt-vm.lisp,v 1.8 2010/03/19 15:18:59 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This file contains the RT specific runtime stuff.
13 ;;;
14 (in-package "RT")
15 (use-package "SYSTEM")
16 (use-package "ALIEN")
17 (use-package "C-CALL")
18 (use-package "UNIX")
19
20 (intl:textdomain "cmucl")
21
22 (export '(fixup-code-object internal-error-arguments
23 sigcontext-register sigcontext-float-register
24 sigcontext-floating-point-modes extern-alien-name))
25
26
27 ;;;; 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 ;;;; 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 (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 (setf (sap-ref-16 sap 2)
73 (ldb (byte 16 0) fixup)))
74 (:cau
75 (let ((high (ldb (byte 16 16) fixup)))
76 (setf (sap-ref-16 sap 2)
77 (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 (setf (sap-ref-16 sap 2)
84 (ldb (byte 16 0) fixup)))))))
85
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 (defun internal-error-arguments (scp)
96 (with-alien ((scp (* sigcontext) scp))
97 (let ((pc (slot scp 'sc-pc)))
98 (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
117
118 ;;;; 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 ;;; 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 (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