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 -- Interface
  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 (defun context-floating-point-modes (context)
 101   ;; FIXME: As of sbcl-0.6.7 and the big rewrite of signal handling
 102   ;; for POSIXness and (at the Lisp level) opaque signal contexts,
 103   ;; this is needs to be rewritten as an alien function.
 104   (warn "stub CONTEXT-FLOATING-POINT-MODES")
 105   0)
 106
 107
 108 \f
 109 ;;;; INTERNAL-ERROR-ARGS.
 110
 111 ;;; GIVEN a (POSIX) signal context, extract the internal error
 112 ;;; arguments from the instruction stream.  This is e.g.
 113
 114 ;;; INTERNAL-ERROR-ARGS -- interface.
 115 ;;;
 116 ;;; Given the sigcontext, extract the internal error arguments from the
 117 ;;; instruction stream.
 118 ;;;
 119 (defun internal-error-args (context)
 120   (declare (type (alien (* os-context-t)) context))
 121   (let* ((pc (context-pc context))
 122          (bad-inst (sap-ref-32 pc 0))
 123          (op (ldb (byte 16 16) bad-inst)))
 124     (declare (type system-area-pointer pc))
 125     (cond ((= op (logior (ash 3 10) (ash 6 5)))
 126            (args-for-unimp-inst context))
 127           ((and (= (ldb (byte 6 10) op) 3)
 128                 (= (ldb (byte 5 5) op) 24))
 129            (let* ((regnum (ldb (byte 5 0) op))
 130                   (prev (sap-ref-32 (int-sap (- (sap-int pc) 4)) 0)))
 131              (if (and (= (ldb (byte 6 26) prev) 3)
 132                       (= (ldb (byte 5 21) prev) 0))
 133                  (values (ldb (byte 16 0) prev)
 134                          (list (sb!c::make-sc-offset sb!vm:any-reg-sc-number
 135                                                      (ldb (byte 5 16) prev))))
 136                  (values #.(sb!kernel:error-number-or-lose
 137                             'sb!kernel:invalid-arg-count-error)
 138                          (list (sb!c::make-sc-offset sb!vm:any-reg-sc-number regnum))))))
 139
 140           (t
 141            (values #.(error-number-or-lose 'unknown-error) nil)))))
 142
 143 (defun args-for-unimp-inst (context)
 144   (declare (type (alien (* os-context-t)) context))
 145   (let* ((pc (context-pc context))
 146          (length (sap-ref-8 pc 4))
 147          (vector (make-array length :element-type '(unsigned-byte 8))))
 148     (declare (type system-area-pointer pc)
 149              (type (unsigned-byte 8) length)
 150              (type (simple-array (unsigned-byte 8) (*)) vector))
 151     (copy-from-system-area pc (* sb!vm:n-byte-bits 5)
 152                            vector (* sb!vm:n-word-bits
 153                                      sb!vm:vector-data-offset)
 154                            (* length sb!vm:n-byte-bits))
 155     (let* ((index 0)
 156            (error-number (sb!c::read-var-integer vector index)))
 157       (collect ((sc-offsets))
 158                (loop
 159                 (when (>= index length)
 160                   (return))
 161                 (sc-offsets (sb!c::read-var-integer vector index)))
 162                (values error-number (sc-offsets))))))
 163
 164
 165 \f
 166 ;;; The loader uses this to convert alien names to the form they
 167 ;;; occur in the symbol table.  This is ELF, so do nothing
 168
 169 (defun extern-alien-name (name)
 170   (declare (type simple-base-string name))
 171   name)
 172