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