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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (show annotations)
Fri Feb 8 13:35:51 1991 UTC (23 years, 2 months ago) by ram
Branch: MAIN
Changes since 1.7: +9 -5 lines
New file header with RCS header FILE-COMMENT.
1 ;;; -*- Package: SPARC -*-
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/sparc-vm.lisp,v 1.8 1991/02/08 13:35:51 ram Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/code/sparc-vm.lisp,v 1.8 1991/02/08 13:35:51 ram Exp $
15 ;;;
16 ;;; This file contains the SPARC specific runtime stuff.
17 ;;;
18 (in-package "SPARC")
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 :SPARCstation *features*)
27 (pushnew :sparc *features*)
28 (pushnew :sun4 *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 "SPARCstation")
37
38 (defun machine-version ()
39 "Returns a string describing the version of the local machine."
40 "SPARCstation")
41
42
43
44 ;;; FIXUP-CODE-OBJECT -- Interface
45 ;;;
46 (defun fixup-code-object (code offset fixup kind)
47 (multiple-value-bind (word-offset rem) (truncate offset word-bytes)
48 (unless (zerop rem)
49 (error "Unaligned instruction? offset=#x~X." offset))
50 (system:without-gcing
51 (let ((sap (truly-the system-area-pointer
52 (%primitive c::code-instructions code))))
53 (ecase kind
54 (:call
55 (error "Can't deal with CALL fixups, yet."))
56 (:sethi
57 (setf (ldb (byte 22 0) (sap-ref-32 sap word-offset))
58 (ldb (byte 22 10) fixup)))
59 (:add
60 (setf (ldb (byte 10 0) (sap-ref-32 sap word-offset))
61 (ldb (byte 10 0) fixup))))))))
62
63
64
65 ;;;; Internal-error-arguments.
66
67 ;;; INTERNAL-ERROR-ARGUMENTS -- interface.
68 ;;;
69 ;;; Given the sigcontext, extract the internal error arguments from the
70 ;;; instruction stream.
71 ;;;
72 (defun internal-error-arguments (sc)
73 (alien-bind ((sc sc mach:sigcontext t))
74 (let* ((pc (alien-access (mach:sigcontext-pc (alien-value sc))))
75 (bad-inst (sap-ref-32 pc 0))
76 (op (ldb (byte 2 30) bad-inst))
77 (op2 (ldb (byte 3 22) bad-inst))
78 (op3 (ldb (byte 6 19) bad-inst)))
79 (cond ((and (= op #b00) (= op2 #b000))
80 (args-for-unimp-inst sc))
81 ((and (= op #b10) (= (ldb (byte 4 2) op3) #b1000))
82 (args-for-tagged-add-inst sc bad-inst))
83 ((and (= op #b10) (= op3 #b111010))
84 (args-for-tcc-inst bad-inst))
85 (t
86 (values (error-number-or-lose 'unknown-error)
87 nil))))))
88
89 (defun args-for-unimp-inst (sc)
90 (alien-bind ((sc sc mach:sigcontext t))
91 (let* ((pc (alien-access (mach:sigcontext-pc (alien-value sc))))
92 (length (sap-ref-8 pc 4))
93 (vector (make-array length :element-type '(unsigned-byte 8))))
94 (declare (type system-area-pointer pc)
95 (type (unsigned-byte 8) length)
96 (type (simple-array (unsigned-byte 8) (*)) vector))
97 (copy-from-system-area pc (* sparc:byte-bits 5)
98 vector (* sparc:word-bits
99 sparc:vector-data-offset)
100 (* length sparc:byte-bits))
101 (let* ((index 0)
102 (error-number (c::read-var-integer vector index)))
103 (collect ((sc-offsets))
104 (loop
105 (when (>= index length)
106 (return))
107 (sc-offsets (c::read-var-integer vector index)))
108 (values error-number (sc-offsets)))))))
109
110 (defun args-for-tagged-add-inst (sc bad-inst)
111 (alien-bind ((sc sc mach:sigcontext t)
112 (regs (mach:sigcontext-regs (alien-value sc)) mach:int-array t))
113 (let* ((rs1 (ldb (byte 5 14) bad-inst))
114 (op1 (di::make-lisp-obj
115 (alien-access
116 (mach:int-array-ref (alien-value regs)
117 rs1)))))
118 (if (fixnump op1)
119 (if (zerop (ldb (byte 1 13) bad-inst))
120 (let* ((rs2 (ldb (byte 5 0) bad-inst))
121 (op2 (di::make-lisp-obj
122 (alien-access
123 (mach:int-array-ref (alien-value regs)
124 rs2)))))
125 (if (fixnump op2)
126 (values (error-number-or-lose 'unknown-error)
127 nil)
128 (values (error-number-or-lose 'object-not-fixnum-error)
129 (list (c::make-sc-offset
130 sparc:descriptor-reg-sc-number
131 rs2)))))
132 (values (error-number-or-lose 'unknown-error)
133 nil))
134 (values (error-number-or-lose 'object-not-fixnum-error)
135 (list (c::make-sc-offset sparc:descriptor-reg-sc-number
136 rs1)))))))
137
138 (defun args-for-tcc-inst (bad-inst)
139 (let* ((trap-number (ldb (byte 8 0) bad-inst))
140 (reg (ldb (byte 5 8) bad-inst)))
141 (values (case trap-number
142 (#.sparc:object-not-list-trap
143 (error-number-or-lose 'object-not-list-error))
144 (#.sparc:object-not-structure-trap
145 (error-number-or-lose 'object-not-structure-error))
146 (t
147 (error-number-or-lose 'unknown-error)))
148 (list (c::make-sc-offset sparc:descriptor-reg-sc-number reg)))))
149
150
151 ;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface
152 ;;;
153 ;;; Given a sigcontext pointer, return the floating point modes word in the
154 ;;; same format as returned by FLOATING-POINT-MODES.
155 ;;;
156 (defun sigcontext-floating-point-modes (scp)
157 (alien-bind ((sc (make-alien 'mach:sigcontext
158 #.(ext:c-sizeof 'mach:sigcontext)
159 scp)
160 mach:sigcontext
161 t))
162 (alien-access (mach:sigcontext-fsr (alien-value sc)))))

  ViewVC Help
Powered by ViewVC 1.1.5