/[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 - (hide 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 wlott 1.6 ;;; -*- Package: SPARC -*-
2 wlott 1.1 ;;;
3     ;;; **********************************************************************
4 ram 1.8 ;;; 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 wlott 1.1 ;;; **********************************************************************
13     ;;;
14 ram 1.8 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/code/sparc-vm.lisp,v 1.8 1991/02/08 13:35:51 ram Exp $
15 wlott 1.1 ;;;
16     ;;; This file contains the SPARC specific runtime stuff.
17     ;;;
18     (in-package "SPARC")
19     (use-package "SYSTEM")
20    
21 wlott 1.2 (export '(fixup-code-object internal-error-arguments))
22 wlott 1.1
23    
24     ;;;; Add machine specific features to *features*
25    
26     (pushnew :SPARCstation *features*)
27     (pushnew :sparc *features*)
28     (pushnew :sun4 *features*)
29 wlott 1.7
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 wlott 1.1
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 wlott 1.2
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 wlott 1.3 (defun internal-error-arguments (sc)
73     (alien-bind ((sc sc mach:sigcontext t))
74 wlott 1.2 (let* ((pc (alien-access (mach:sigcontext-pc (alien-value sc))))
75 wlott 1.6 (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 wlott 1.2 (length (sap-ref-8 pc 4))
93     (vector (make-array length :element-type '(unsigned-byte 8))))
94 wlott 1.3 (declare (type system-area-pointer pc)
95     (type (unsigned-byte 8) length)
96 wlott 1.4 (type (simple-array (unsigned-byte 8) (*)) vector))
97 wlott 1.6 (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 wlott 1.2 (let* ((index 0)
102     (error-number (c::read-var-integer vector index)))
103     (collect ((sc-offsets))
104 wlott 1.6 (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 ram 1.5
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