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

  ViewVC Help
Powered by ViewVC 1.1.5