src/code/sparc-vm.lisp

   1 ;;;; SPARC-specific runtime stuff
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11 (in-package "SB!VM")
  12 \f
  13 ;;; See x86-vm.lisp for a description of this.
  14 #-sb-xc-host (progn
  15 (define-alien-type os-context-t (struct os-context-t-struct))
  16 \f
  17 ;;;; MACHINE-TYPE
  18
  19 (defun machine-type ()
  20   "Returns a string describing the type of the local machine."
  21   "SPARC")
  22 ) ; end PROGN
  23 \f
  24 (!with-bigvec-or-sap
  25 (defun fixup-code-object (code offset fixup kind)
  26   (declare (type index offset))
  27   (unless (zerop (rem offset n-word-bytes))
  28     (error "Unaligned instruction?  offset=#x~X." offset))
  29   (without-gcing
  30    (let ((sap (code-instructions code)))
  31      (ecase kind
  32        (:call
  33         (error "Can't deal with CALL fixups, yet."))
  34        (:sethi
  35         (setf (ldb (byte 22 0) (sap-ref-32 sap offset))
  36               (ldb (byte 22 10) fixup)))
  37        (:add
  38         (setf (ldb (byte 10 0) (sap-ref-32 sap offset))
  39               (ldb (byte 10 0) fixup)))
  40        (:absolute
  41         (setf (sap-ref-32 sap offset)
  42               fixup)))))))
  43
  44 \f
  45 ;;;; "Sigcontext" access functions, cut & pasted from alpha-vm.lisp.
  46 ;;;;
  47 ;;;; See also x86-vm for commentary on signed vs unsigned.
  48
  49 #-sb-xc-host (progn
  50 (define-alien-routine ("os_context_pc_addr" context-pc-addr) (* unsigned-int)
  51   (context (* os-context-t)))
  52
  53 (defun context-pc (context)
  54   (declare (type (alien (* os-context-t)) context))
  55   (int-sap (deref (context-pc-addr context))))
  56
  57 (define-alien-routine ("os_context_register_addr" context-register-addr)
  58   (* unsigned-int)
  59   (context (* os-context-t))
  60   (index int))
  61
  62 ;;; FIXME: Should this and CONTEXT-PC be INLINE to reduce consing?
  63 ;;; (Are they used in anything time-critical, or just the debugger?)
  64 (defun context-register (context index)
  65   (declare (type (alien (* os-context-t)) context))
  66   (deref (context-register-addr context index)))
  67
  68 (defun %set-context-register (context index new)
  69 (declare (type (alien (* os-context-t)) context))
  70 (setf (deref (context-register-addr context index))
  71       new))
  72
  73 ;;; This is like CONTEXT-REGISTER, but returns the value of a float
  74 ;;; register. FORMAT is the type of float to return.
  75
  76 ;;; FIXME: Whether COERCE actually knows how to make a float out of a
  77 ;;; long is another question. This stuff still needs testing.
  78 #+nil
  79 (define-alien-routine ("os_context_float_register_addr" context-float-register-addr)
  80   (* long)
  81   (context (* os-context-t))
  82   (index int))
  83 #+nil
  84 (defun context-float-register (context index format)
  85   (declare (type (alien (* os-context-t)) context))
  86   (coerce (deref (context-float-register-addr context index)) format))
  87 #+nil
  88 (defun %set-context-float-register (context index format new)
  89   (declare (type (alien (* os-context-t)) context))
  90   (setf (deref (context-float-register-addr context index))
  91         (coerce new format)))
  92
  93 ;;; Given a signal context, return the floating point modes word in
  94 ;;; the same format as returned by FLOATING-POINT-MODES.
  95
  96 ;;; Under SunOS, we have a straightforward implementation in C:
  97 #!+sunos
  98 (define-alien-routine ("os_context_fp_control" context-floating-point-modes)
  99     (unsigned 32)
 100   (context (* os-context-t)))
 101
 102 ;;; Under Linux, we have to contend with utterly broken signal handling.
 103 #!+linux
 104 (defun context-floating-point-modes (context)
 105   (declare (ignore context))
 106   (warn "stub CONTEXT-FLOATING-POINT-MODES")
 107   0)
 108 \f
 109 ;;;; INTERNAL-ERROR-ARGS.
 110
 111 ;;; Given a (POSIX) signal context, extract the internal error
 112 ;;; arguments from the instruction stream.  This is e.g.
 113 ;;; 4       23      254     240     2       0       0       0
 114 ;;; |       ~~~~~~~~~~~~~~~~~~~~~~~~~
 115 ;;; length         data              (everything is an octet)
 116 ;;;  (pc)
 117 (defun internal-error-args (context)
 118   (declare (type (alien (* os-context-t)) context))
 119   (/show0 "entering INTERNAL-ERROR-ARGS")
 120   (let* ((pc (context-pc context))
 121          (error-number (sap-ref-8 pc 4)))
 122     (declare (type system-area-pointer pc))
 123     (values error-number
 124             (sb!kernel::decode-internal-error-args (sap+ pc 5) error-number))))
 125 ) ; end PROGN