/[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.2 - (show annotations)
Mon Nov 26 15:16:18 1990 UTC (23 years, 4 months ago) by wlott
Branch: MAIN
Changes since 1.1: +37 -2 lines
Added defun for internal-error-arguments.
1 ;;; -*- Package: VM -*-
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/sparc-vm.lisp,v 1.2 1990/11/26 15:16:18 wlott Exp $
11 ;;;
12 ;;; This file contains the SPARC specific runtime stuff.
13 ;;;
14 (in-package "SPARC")
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 :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
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 (defun internal-error-arguments (scp)
57 (alien-bind ((sc (make-alien 'mach:sigcontext
58 #.(c-sizeof 'mach:sigcontext)
59 scp)
60 mach:sigcontext
61 t)
62 (regs (mach:sigcontext-regs (alien-value sc)) mach:int-array t))
63 (let* ((pc (alien-access (mach:sigcontext-pc (alien-value sc))))
64 (length (sap-ref-8 pc 4))
65 (vector (make-array length :element-type '(unsigned-byte 8))))
66 (copy-from-system-area pc (* vm:byte-bits 5)
67 vector (* vm:word-bits
68 vm:vector-data-offset)
69 (* length vm:byte-bits))
70 (let* ((index 0)
71 (error-number (c::read-var-integer vector index)))
72 (collect ((sc-offsets))
73 (loop
74 (when (>= index length)
75 (return))
76 (sc-offsets (c::read-var-integer vector index)))
77 (values error-number (sc-offsets)))))))
78
79
80

  ViewVC Help
Powered by ViewVC 1.1.5