/[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 - (show 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 ;;; -*- 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 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/rt-vm.lisp,v 1.4 1992/01/02 22:49:20 ram Exp $")
11 ;;;
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 (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
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 (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
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 0
103 #+nil
104 (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