/[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.4 - (hide annotations)
Thu Jan 2 22:49:20 1992 UTC (22 years, 3 months ago) by ram
Branch: MAIN
Changes since 1.3: +3 -3 lines
Made sigcontext-floating-point-modes always return 0 (instead of getting
a read error.)
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     ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7     ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8     ;;;
9     (ext:file-comment
10 ram 1.4 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/rt-vm.lisp,v 1.4 1992/01/02 22:49:20 ram Exp $")
11 wlott 1.1 ;;;
12     ;;; **********************************************************************
13     ;;;
14     ;;; This file contains the RT specific runtime stuff.
15     ;;;
16     (in-package "RT")
17     (use-package "SYSTEM")
18    
19     (export '(fixup-code-object internal-error-arguments))
20    
21    
22     ;;;; Add machine specific features to *features*
23    
24     (pushnew :ibm-pc-rt *features*)
25     (pushnew :ibmrt *features*)
26     (pushnew :rt *features*)
27    
28    
29    
30     ;;;; MACHINE-TYPE and MACHINE-VERSION
31    
32     (defun machine-type ()
33     "Returns a string describing the type of the local machine."
34     "IBM PC/RT")
35    
36     (defun machine-version ()
37     "Returns a string describing the version of the local machine."
38     "IBM PC/RT")
39    
40    
41    
42     ;;; FIXUP-CODE-OBJECT -- Interface
43     ;;;
44     (defun fixup-code-object (code offset fixup kind)
45 wlott 1.2 (declare (type index offset) (type (unsigned-byte 32) fixup))
46     (system:without-gcing
47     (let ((sap (sap+ (kernel:code-instructions code) offset)))
48     (ecase kind
49     (:cal
50     (setf (sap-ref-16 sap 1)
51     (ldb (byte 16 0) fixup)))
52     (:cau
53     (let ((high (ldb (byte 16 16) fixup)))
54     (setf (sap-ref-16 sap 1)
55     (if (logbitp 15 fixup) (1+ high) high))))
56     (:ba
57     (unless (zerop (ash fixup -24))
58     (warn "#x~8,'0X out of range for branch-absolute." fixup))
59     (setf (sap-ref-8 sap 1)
60     (ldb (byte 8 16) fixup))
61     (setf (sap-ref-16 sap 1)
62     (ldb (byte 16 0) fixup)))))))
63 wlott 1.1
64    
65    
66     ;;;; Internal-error-arguments.
67    
68     ;;; INTERNAL-ERROR-ARGUMENTS -- interface.
69     ;;;
70     ;;; Given the sigcontext, extract the internal error arguments from the
71     ;;; instruction stream.
72     ;;;
73     (defun internal-error-arguments (sc)
74     (alien-bind ((sc sc mach:sigcontext t))
75 wlott 1.3 (let ((pc (alien-access (mach:sigcontext-iar (alien-value sc)))))
76     (declare (type system-area-pointer pc))
77     (let* ((length (sap-ref-8 pc 4))
78     (vector (make-array length :element-type '(unsigned-byte 8))))
79     (declare (type (unsigned-byte 8) length)
80     (type (simple-array (unsigned-byte 8) (*)) vector))
81     (copy-from-system-area pc (* vm:byte-bits 5)
82     vector (* vm:word-bits
83     vm:vector-data-offset)
84     (* length vm:byte-bits))
85     (let* ((index 0)
86     (error-number (c::read-var-integer vector index)))
87     (collect ((sc-offsets))
88     (loop
89     (when (>= index length)
90     (return))
91     (sc-offsets (c::read-var-integer vector index)))
92     (values error-number (sc-offsets))))))))
93    
94 wlott 1.1
95    
96     ;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface
97     ;;;
98     ;;; Given a sigcontext pointer, return the floating point modes word in the
99     ;;; same format as returned by FLOATING-POINT-MODES.
100     ;;;
101     (defun sigcontext-floating-point-modes (scp)
102 ram 1.4 0
103     #+nil
104 wlott 1.1 (alien-bind ((sc (make-alien 'mach:sigcontext
105     #.(ext:c-sizeof 'mach:sigcontext)
106     scp)
107     mach:sigcontext
108     t))
109     (alien-access (mach:sigcontext-fsr (alien-value sc)))))

  ViewVC Help
Powered by ViewVC 1.1.5