/[cmucl]/src/code/pmax-vm.lisp
ViewVC logotype

Contents of /src/code/pmax-vm.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Thu Dec 6 17:39:33 1990 UTC (23 years, 4 months ago) by ram
Branch: MAIN
Changes since 1.4: +14 -1 lines
Added SIGCONTEXT-FLOATING-POINT-MODES for finding the floating-point
hardware state when there is a floating-point error.
1 ;;; -*- Package: MIPS -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the Spice 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 Spice Lisp, please contact
7 ;;; Scott Fahlman (FAHLMAN@CMUC).
8 ;;; **********************************************************************
9 ;;;
10 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/code/pmax-vm.lisp,v 1.5 1990/12/06 17:39:33 ram Exp $
11 ;;;
12 ;;; This file contains the PMAX specific runtime stuff.
13 ;;;
14 (in-package "MIPS")
15 (use-package "SYSTEM")
16
17 (export '(fixup-code-object internal-error-arguments))
18
19
20 ;;;; Add machine specific features to *features*
21
22 (pushnew :decstation-3100 *features*)
23 (pushnew :pmax *features*)
24
25
26
27 ;;; FIXUP-CODE-OBJECT -- Interface
28 ;;;
29 (defun fixup-code-object (code offset fixup kind)
30 (multiple-value-bind (word-offset rem) (truncate offset word-bytes)
31 (unless (zerop rem)
32 (error "Unaligned instruction? offset=#x~X." offset))
33 (system:without-gcing
34 (let ((sap (truly-the system-area-pointer
35 (%primitive c::code-instructions code))))
36 (ecase kind
37 (:jump
38 (assert (zerop (ash fixup -26)))
39 (setf (ldb (byte 26 0)
40 (system:sap-ref-32 sap word-offset))
41 (ash fixup -2)))
42 (:lui
43 (setf (sap-ref-16 sap (* word-offset 2))
44 (+ (ash fixup -16)
45 (if (logbitp 15 fixup) 1 0))))
46 (:addi
47 (setf (sap-ref-16 sap (* word-offset 2))
48 (ldb (byte 16 0) fixup))))))))
49
50
51
52
53 ;;;; Internal-error-arguments.
54
55 ;;; INTERNAL-ERROR-ARGUMENTS -- interface.
56 ;;;
57 ;;; Given the sigcontext, extract the internal error arguments from the
58 ;;; instruction stream.
59 ;;;
60 (defun internal-error-arguments (sc)
61 (alien-bind ((sc sc mach:sigcontext t))
62 (let ((pc (alien-access (mach:sigcontext-pc (alien-value sc)))))
63 (declare (type system-area-pointer pc))
64 (when (logbitp 31
65 (alien-access (mach:sigcontext-cause (alien-value sc))))
66 (setf pc (sap+ pc 4)))
67 (when (= (sap-ref-8 pc 4) 255)
68 (setf pc (sap+ pc 1)))
69 (let* ((length (sap-ref-8 pc 4))
70 (vector (make-array length :element-type '(unsigned-byte 8))))
71 (declare (type (unsigned-byte 8) length)
72 (type (simple-array (unsigned-byte 8) (*)) vector))
73 (copy-from-system-area pc (* vm:byte-bits 5)
74 vector (* vm:word-bits
75 vm:vector-data-offset)
76 (* length vm:byte-bits))
77 (let* ((index 0)
78 (error-number (c::read-var-integer vector index)))
79 (collect ((sc-offsets))
80 (loop
81 (when (>= index length)
82 (return))
83 (sc-offsets (c::read-var-integer vector index)))
84 (values error-number (sc-offsets))))))))
85
86
87 ;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface
88 ;;;
89 ;;; Given a sigcontext pointer, return the floating point modes word in the
90 ;;; same format as returned by FLOATING-POINT-MODES.
91 ;;;
92 (defun sigcontext-floating-point-modes (scp)
93 (alien-bind ((sc (make-alien 'mach:sigcontext
94 #.(ext:c-sizeof 'mach:sigcontext)
95 scp)
96 mach:sigcontext
97 t))
98 (alien-access (mach:sigcontext-fpc_csr (alien-value sc)))))

  ViewVC Help
Powered by ViewVC 1.1.5