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

  ViewVC Help
Powered by ViewVC 1.1.5