src/code/ppc-vm.lisp

   1 ;;; This file contains the PPC specific runtime stuff.
   2 ;;;
   3 (in-package "SB!VM")
   4
   5 (defvar *number-of-signals* 64)
   6 (defvar *bits-per-word* 32)
   7
   8 (define-alien-type os-context-t (struct os-context-t-struct))
   9
  10 \f
  11 ;;;; MACHINE-TYPE and MACHINE-VERSION
  12
  13 (defun machine-type ()
  14   "Returns a string describing the type of the local machine."
  15   "PowerPC")
  16
  17 (defun machine-version ()
  18   "Returns a string describing the version of the local machine."
  19   "who-knows?")
  20
  21
  22 \f
  23 ;;;; FIXUP-CODE-OBJECT
  24
  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   (sb!sys:without-gcing
  30    (let ((sap (truly-the system-area-pointer
  31                          (%primitive sb!kernel::code-instructions code))))
  32      (ecase kind
  33        (:b
  34         (error "Can't deal with CALL fixups, yet."))
  35        (:ba
  36         (setf (ldb (byte 24 2) (sap-ref-32 sap offset))
  37               (ash fixup -2)))
  38        (:ha
  39         (let* ((h (ldb (byte 16 16) fixup))
  40                (l (ldb (byte 16 0) fixup)))
  41           ; Compensate for possible sign-extension when the low half
  42           ; is added to the high.  We could avoid this by ORI-ing
  43           ; the low half in 32-bit absolute loads, but it'd be
  44           ; nice to be able to do:
  45           ;  lis rX,foo@ha
  46           ;  lwz rY,foo@l(rX)
  47           ; and lwz/stw and friends all use a signed 16-bit offset.
  48           (setf (ldb (byte 16 0) (sap-ref-32 sap offset))
  49                  (if (logbitp 15 l) (ldb (byte 16 0) (1+ h)) h))))
  50        (:l
  51         (setf (ldb (byte 16 0) (sap-ref-32 sap offset))
  52               (ldb (byte 16 0) fixup)))))))
  53
  54
  55 ;;;; "Sigcontext" access functions, cut & pasted from x86-vm.lisp then
  56 ;;;; hacked for types.
  57
  58 (define-alien-routine ("os_context_pc_addr" context-pc-addr) (* unsigned-long)
  59   (context (* os-context-t)))
  60
  61 (defun context-pc (context)
  62   (declare (type (alien (* os-context-t)) context))
  63   (int-sap (deref (context-pc-addr context))))
  64
  65 (define-alien-routine ("os_context_register_addr" context-register-addr)
  66   (* unsigned-long)
  67   (context (* os-context-t))
  68   (index int))
  69
  70 (defun context-register (context index)
  71   (declare (type (alien (* os-context-t)) context))
  72   (deref (context-register-addr context index)))
  73
  74 (defun %set-context-register (context index new)
  75 (declare (type (alien (* os-context-t)) context))
  76 (setf (deref (context-register-addr context index))
  77       new))
  78 ;;; This is like CONTEXT-REGISTER, but returns the value of a float
  79 ;;; register. FORMAT is the type of float to return.
  80
  81 ;;; FIXME: Whether COERCE actually knows how to make a float out of a
  82 ;;; long is another question. This stuff still needs testing.
  83 #+nil
  84 (define-alien-routine ("os_context_fpregister_addr" context-float-register-addr)
  85   (* long)
  86   (context (* os-context-t))
  87   (index int))
  88 #+nil
  89 (defun context-float-register (context index format)
  90   (declare (type (alien (* os-context-t)) context))
  91   (coerce (deref (context-float-register-addr context index)) format))
  92 #+nil
  93 (defun %set-context-float-register (context index format new)
  94   (declare (type (alien (* os-context-t)) context))
  95   (setf (deref (context-float-register-addr context index))
  96         (coerce new format)))
  97
  98 ;;; Given a signal context, return the floating point modes word in
  99 ;;; the same format as returned by FLOATING-POINT-MODES.
 100 (define-alien-routine ("os_context_fp_control" context-floating-point-modes)
 101     (sb!alien:unsigned 32)
 102   (context (* os-context-t)))
 103
 104 \f
 105 ;;;; INTERNAL-ERROR-ARGS.
 106
 107 ;;; GIVEN a (POSIX) signal context, extract the internal error
 108 ;;; arguments from the instruction stream.  This is e.g.
 109
 110 ;;; INTERNAL-ERROR-ARGS -- interface.
 111 ;;;
 112 ;;; Given the sigcontext, extract the internal error arguments from the
 113 ;;; instruction stream.
 114 ;;;
 115 (defun internal-error-args (context)
 116   (declare (type (alien (* os-context-t)) context))
 117   (let* ((pc (context-pc context))
 118          (bad-inst (sap-ref-32 pc 0))
 119          (op (ldb (byte 16 16) bad-inst)))
 120     (declare (type system-area-pointer pc))
 121     (cond ((= op (logior (ash 3 10) (ash 6 5)))
 122            (args-for-unimp-inst context))
 123           ((and (= (ldb (byte 6 10) op) 3)
 124                 (= (ldb (byte 5 5) op) 24))
 125            (let* ((regnum (ldb (byte 5 0) op))
 126                   (prev (sap-ref-32 (int-sap (- (sap-int pc) 4)) 0)))
 127              (if (and (= (ldb (byte 6 26) prev) 3)
 128                       (= (ldb (byte 5 21) prev) 0))
 129                  (values (ldb (byte 16 0) prev)
 130                          (list (sb!c::make-sc-offset sb!vm:any-reg-sc-number
 131                                                      (ldb (byte 5 16) prev))))
 132                  (values #.(sb!kernel:error-number-or-lose
 133                             'sb!kernel:invalid-arg-count-error)
 134                          (list (sb!c::make-sc-offset sb!vm:any-reg-sc-number regnum))))))
 135
 136           (t
 137            (values #.(error-number-or-lose 'unknown-error) nil)))))
 138
 139 (defun args-for-unimp-inst (context)
 140   (declare (type (alien (* os-context-t)) context))
 141   (let* ((pc (context-pc context))
 142          (length (sap-ref-8 pc 4))
 143          (vector (make-array length :element-type '(unsigned-byte 8))))
 144     (declare (type system-area-pointer pc)
 145              (type (unsigned-byte 8) length)
 146              (type (simple-array (unsigned-byte 8) (*)) vector))
 147     (copy-from-system-area pc (* sb!vm:n-byte-bits 5)
 148                            vector (* sb!vm:n-word-bits
 149                                      sb!vm:vector-data-offset)
 150                            (* length sb!vm:n-byte-bits))
 151     (let* ((index 0)
 152            (error-number (sb!c:read-var-integer vector index)))
 153       (collect ((sc-offsets))
 154                (loop
 155                 (when (>= index length)
 156                   (return))
 157                 (sc-offsets (sb!c:read-var-integer vector index)))
 158                (values error-number (sc-offsets))))))
 159
 160
 161