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