src/code/hppa-vm.lisp

   1 (in-package "SB!VM")
   2 \f
   3 (define-alien-type os-context-t (struct os-context-t-struct))
   4 \f
   5 ;;;; MACHINE-TYPE and MACHINE-VERSION
   6
   7 (defun machine-type ()
   8   "Returns a string describing the type of the local machine."
   9   "HPPA")
  10
  11 (defun machine-version ()
  12   "Returns a string describing the version of the local machine."
  13   "HPPA")
  14
  15 \f
  16 ;;;; FIXUP-CODE-OBJECT
  17
  18 (defun fixup-code-object (code offset value kind)
  19   (unless (zerop (rem offset n-word-bytes))
  20     (error "Unaligned instruction?  offset=#x~X." offset))
  21   (sb!sys:without-gcing
  22    (let* ((sap (truly-the system-area-pointer
  23                           (%primitive sb!kernel::code-instructions code)))
  24           (inst (sap-ref-32 sap offset)))
  25      (setf (sap-ref-32 sap offset)
  26            (ecase kind
  27              (:load
  28               (logior (ash (ldb (byte 11 0) value) 1)
  29                       (logand inst #xffffc000)))
  30              (:load-short
  31               (let ((low-bits (ldb (byte 11 0) value)))
  32                 (assert (<= 0 low-bits (1- (ash 1 4))))
  33                 (logior (ash low-bits 17)
  34                         (logand inst #xffe0ffff))))
  35              (:hi
  36               (logior (ash (ldb (byte 5 13) value) 16)
  37                       (ash (ldb (byte 2 18) value) 14)
  38                       (ash (ldb (byte 2 11) value) 12)
  39                       (ash (ldb (byte 11 20) value) 1)
  40                       (ldb (byte 1 31) value)
  41                       (logand inst #xffe00000)))
  42              (:branch
  43               (let ((bits (ldb (byte 9 2) value)))
  44                 (assert (zerop (ldb (byte 2 0) value)))
  45                 (logior (ash bits 3)
  46                         (logand inst #xffe0e002)))))))))
  47 \f
  48 (define-alien-routine ("os_context_pc_addr" context-pc-addr) (* unsigned-int)
  49   (context (* os-context-t)))
  50
  51 (defun context-pc (context)
  52   (declare (type (alien (* os-context-t)) context))
  53   (int-sap (logandc2 (deref (context-pc-addr context)) 3)))
  54
  55 (define-alien-routine ("os_context_register_addr" context-register-addr)
  56   (* unsigned-int)
  57   (context (* os-context-t))
  58   (index int))
  59
  60 ;;; FIXME: Should this and CONTEXT-PC be INLINE to reduce consing?
  61 ;;; (Are they used in anything time-critical, or just the debugger?)
  62 (defun context-register (context index)
  63   (declare (type (alien (* os-context-t)) context))
  64   (deref (context-register-addr context index)))
  65
  66 (defun %set-context-register (context index new)
  67 (declare (type (alien (* os-context-t)) context))
  68 (setf (deref (context-register-addr context index))
  69       new))
  70
  71 #!+linux
  72 ;;; For now.
  73 (defun context-floating-point-modes (context)
  74   (warn "stub CONTEXT-FLOATING-POINT-MODES")
  75   0)
  76
  77 ;;;; Internal-error-arguments.
  78
  79 ;;; INTERNAL-ERROR-ARGUMENTS -- interface.
  80 ;;;
  81 ;;; Given the sigcontext, extract the internal error arguments from the
  82 ;;; instruction stream.
  83 ;;;
  84 (defun internal-error-args (context)
  85   (declare (type (alien (* os-context-t)) context))
  86   (let ((pc (context-pc context)))
  87     (declare (type system-area-pointer pc))
  88     (let* ((length (sap-ref-8 pc 4))
  89            (vector (make-array length :element-type '(unsigned-byte 8))))
  90       (declare (type (unsigned-byte 8) length)
  91                (type (simple-array (unsigned-byte 8) (*)) vector))
  92       (copy-from-system-area pc (* n-byte-bits 5)
  93                              vector (* n-word-bits
  94                                        vector-data-offset)
  95                              (* length n-byte-bits))
  96       (let* ((index 0)
  97              (error-number (sb!c:read-var-integer vector index)))
  98         (collect ((sc-offsets))
  99          (loop
 100           (when (>= index length)
 101             (return))
 102           (sc-offsets (sb!c:read-var-integer vector index)))
 103          (values error-number (sc-offsets)))))))