src/code/hppa-vm.lisp

   1 (in-package "SB!VM")
   2 \f
   3 #-sb-xc-host
   4 (defun machine-type ()
   5   "Returns a string describing the type of the local machine."
   6   "HPPA")
   7 \f
   8 ;;;; FIXUP-CODE-OBJECT
   9 (!with-bigvec-or-sap
  10 (defun fixup-code-object (code offset value kind)
  11   (unless (zerop (rem offset n-word-bytes))
  12     (error "Unaligned instruction?  offset=#x~X." offset))
  13   (without-gcing
  14    (let* ((sap (code-instructions code))
  15           (inst (sap-ref-32 sap offset)))
  16      (setf (sap-ref-32 sap offset)
  17            (ecase kind
  18              (:absolute
  19               value)
  20              (:load
  21               (logior (mask-field (byte 18 14) value)
  22                       (if (< value 0)
  23                         (1+ (ash (ldb (byte 13 0) value) 1))
  24                         (ash (ldb (byte 13 0) value) 1))))
  25              (:load11u
  26               (logior (if (< value 0)
  27                           (1+ (ash (ldb (byte 10 0) value) 1))
  28                           (ash (ldb (byte 11 0) value) 1))
  29                       (mask-field (byte 18 14) inst)))
  30              (:load-short
  31               (let ((low-bits (ldb (byte 11 0) value)))
  32                 (aver (<= 0 low-bits (1- (ash 1 4))))
  33                 (logior (ash (dpb (ldb (byte 4 0) value)
  34                                   (byte 4 1)
  35                                   (ldb (byte 1 4) value)) 17)
  36                         (logand inst #xffe0ffff))))
  37              (:hi
  38               (logior (ash (ldb (byte 5 13) value) 16)
  39                       (ash (ldb (byte 2 18) value) 14)
  40                       (ash (ldb (byte 2 11) value) 12)
  41                       (ash (ldb (byte 11 20) value) 1)
  42                       (ldb (byte 1 31) value)
  43                       (logand inst #xffe00000)))
  44              (:branch
  45               (let ((bits (ldb (byte 9 2) value)))
  46                 (aver (zerop (ldb (byte 2 0) value)))
  47                 (logior (ash bits 3)
  48                         (mask-field (byte 1 1) inst)
  49                         (mask-field (byte 3 13) inst)
  50                         (mask-field (byte 11 21) inst))))))))))
  51 \f
  52 #-sb-xc-host (progn
  53
  54 ;;; For now.
  55 (defun context-floating-point-modes (context)
  56   (declare (ignore context))
  57   (warn "stub CONTEXT-FLOATING-POINT-MODES")
  58   0)
  59
  60 ;;;; Internal-error-arguments.
  61
  62 ;;; INTERNAL-ERROR-ARGUMENTS -- interface.
  63 ;;;
  64 ;;; Given the sigcontext, extract the internal error arguments from the
  65 ;;; instruction stream.
  66 ;;;
  67 (defun internal-error-args (context)
  68   (declare (type (alien (* os-context-t)) context))
  69   (let* ((pc (context-pc context))
  70          (error-number (sap-ref-8 pc 4)))
  71     (declare (type system-area-pointer pc))
  72     (values error-number
  73             (sb!kernel::decode-internal-error-args (sap+ pc 5) error-number))))
  74 ) ; end PROGN