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