insts.lisp

开源跨平台Lisp编译器

;;;; the instruction set definition for the PPC

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.

(in-package "SB!VM")

;;; needs a little more work in the assembler, to realise that the
;;; delays requested here are not mandatory, so that the assembler
;;; shouldn't fill gaps with NOPs but with real instructions.  -- CSR,
;;; 2003-09-08
#+nil
(eval-when (:compile-toplevel :load-toplevel :execute)
  (setf sb!assem:*assem-scheduler-p* t)
  (setf sb!assem:*assem-max-locations* 70))

;;;; Constants, types, conversion functions, some disassembler stuff.

(defun reg-tn-encoding (tn)
  (declare (type tn tn))
  (sc-case tn
    (zero zero-offset)
    (null null-offset)
    (t
     (if (eq (sb-name (sc-sb (tn-sc tn))) 'registers)
         (tn-offset tn)
         (error "~S isn't a register." tn)))))

(defun fp-reg-tn-encoding (tn)
  (declare (type tn tn))
  (unless (eq (sb-name (sc-sb (tn-sc tn))) 'float-registers)
    (error "~S isn't a floating-point register." tn))
  (tn-offset tn))

;(sb!disassem:set-disassem-params :instruction-alignment 32)

(defvar *disassem-use-lisp-reg-names* t)

(!def-vm-support-routine location-number (loc)
  (etypecase loc
    (null)
    (number)
    (label)
    (fixup)
    (tn
     (ecase (sb-name (sc-sb (tn-sc loc)))
       (immediate-constant
        ;; Can happen if $ZERO or $NULL are passed in.
        nil)
       (registers
        (unless (zerop (tn-offset loc))
          (tn-offset loc)))
       (float-registers
        (+ (tn-offset loc) 32))))
    (symbol
     (ecase loc
       (:memory 0)
       (:ccr 64)
       (:xer 65)
       (:lr 66)
       (:ctr 67)
       (:fpscr 68)))))

(defparameter reg-symbols
  (map 'vector
       #'(lambda (name)
           (cond ((null name) nil)
                 (t (make-symbol (concatenate 'string "$" name)))))
       *register-names*))

(defun maybe-add-notes (regno dstate)
  (let* ((inst (sb!disassem::sap-ref-int
                (sb!disassem::dstate-segment-sap dstate)
                (sb!disassem::dstate-cur-offs dstate)
                n-word-bytes
                (sb!disassem::dstate-byte-order dstate)))
         (op (ldb (byte 6 26) inst)))
    (case op
      ;; lwz
      (32
       (when (= regno (ldb (byte 5 16) inst)) ; only for the second
         (case (ldb (byte 5 16) inst)
           ;; reg_CODE
           (19
            (sb!disassem:note-code-constant (ldb (byte 16 0) inst) dstate)))))
      ;; addi
      (14
       (when (= regno null-offset)
         (sb!disassem:maybe-note-nil-indexed-object
          (ldb (byte 16 0) inst) dstate))))))

(sb!disassem:define-arg-type reg
  :printer
  (lambda (value stream dstate)
    (declare (type stream stream) (fixnum value))
    (let ((regname (aref reg-symbols value)))
      (princ regname stream)
      (sb!disassem:maybe-note-associated-storage-ref
       value 'registers regname dstate)
      (maybe-add-notes value dstate))))

(defparameter float-reg-symbols
  #.(coerce
     (loop for n from 0 to 31 collect (make-symbol (format nil "$F~d" n)))
     'vector))

(sb!disassem:define-arg-type fp-reg
  :printer #'(lambda (value stream dstate)
               (declare (type stream stream) (fixnum value))
               (let ((regname (aref float-reg-symbols value)))
                 (princ regname stream)
                 (sb!disassem:maybe-note-associated-storage-ref
                  value
                  'float-registers
                  regname
                  dstate))))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defparameter bo-kind-names
    #(:bo-dnzf :bo-dnzfp :bo-dzf :bo-dzfp :bo-f :bo-fp nil nil
      :bo-dnzt :bo-dnztp :bo-dzt :bo-dztp :bo-t :bo-tp nil nil
      :bo-dnz :bo-dnzp :bo-dz :bo-dzp :bo-u nil nil nil
      nil nil nil nil nil nil nil nil)))

(sb!disassem:define-arg-type bo-field
  :printer #'(lambda (value stream dstate)
               (declare (ignore dstate)
                        (type stream stream)
                        (type fixnum value))
               (princ (svref bo-kind-names value) stream)))

(eval-when (:compile-toplevel :load-toplevel :execute)
(defun valid-bo-encoding (enc)
  (or (if (integerp enc)
        (and (= enc (logand #x1f enc))
             (not (null (svref bo-kind-names enc)))
             enc)
        (and enc (position enc bo-kind-names)))
      (error "Invalid BO field spec: ~s" enc)))
)


(defparameter cr-bit-names #(:lt :gt :eq :so))
(defparameter cr-bit-inverse-names #(:ge :le :ne :ns))

(defparameter cr-field-names #(:cr0 :cr1 :cr2 :cr3 :cr4 :cr5 :cr6 :cr7))

(defun valid-cr-bit-encoding (enc &optional error-p)
  (or (if (integerp enc)
        (and (= enc (logand 3 enc))
             enc))
      (position enc cr-bit-names)
      (if error-p (error "Invalid condition bit specifier : ~s" enc))))

(defun valid-cr-field-encoding (enc)
  (let* ((field (if (integerp enc)
                  (and (= enc (logand #x7 enc)))
                  (position enc cr-field-names))))
    (if field
      (ash field 2)
      (error "Invalid condition register field specifier : ~s" enc))))

(defun valid-bi-encoding (enc)
  (or
   (if (atom enc)
     (if (integerp enc)
       (and (= enc (logand 31 enc)) enc)
       (position enc cr-bit-names))
     (+ (valid-cr-field-encoding (car enc))
        (valid-cr-bit-encoding (cadr enc))))
   (error "Invalid BI field spec : ~s" enc)))

(sb!disassem:define-arg-type bi-field
  :printer #'(lambda (value stream dstate)
               (declare (ignore dstate)
                        (type stream stream)
                        (type (unsigned-byte 5) value))
               (let* ((bitname (svref cr-bit-names (logand 3 value)))
                      (crfield (ash value -2)))
                 (declare (type (unsigned-byte 3) crfield))
                 (if (= crfield 0)
                   (princ bitname stream)
                   (princ (list (svref cr-field-names crfield) bitname) stream)))))

(sb!disassem:define-arg-type crf
  :printer #'(lambda (value stream dstate)
               (declare (ignore dstate)
                        (type stream stream)
                        (type (unsigned-byte 3) value))
               (princ (svref cr-field-names value) stream)))

(sb!disassem:define-arg-type relative-label
  :sign-extend t
  :use-label #'(lambda (value dstate)
                 (declare (type (signed-byte 14) value)
                          (type sb!disassem:disassem-state dstate))
                 (+ (ash value 2) (sb!disassem:dstate-cur-addr dstate))))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defparameter trap-values-alist '((:t . 31) (:lt . 16) (:le . 20) (:eq . 4) (:lng . 6)
                                   (:ge .12) (:ne . 24) (:ng . 20) (:llt . 2) (:f . 0)
                                   (:lle . 6) (:lge . 5) (:lgt . 1) (:lnl . 5))))


(defun valid-tcond-encoding (enc)
  (or (and (if (integerp enc) (= (logand 31 enc) enc)) enc)
      (cdr (assoc enc trap-values-alist))
      (error "Unknown trap condition: ~s" enc)))

(sb!disassem:define-arg-type to-field
  :sign-extend nil
  :printer #'(lambda (value stream dstate)
               (declare (ignore dstate)
                        (type stream stream)
                        (type fixnum value))
               (princ (or (car (rassoc value trap-values-alist))
                          value)
                      stream)))

(defun snarf-error-junk (sap offset &optional length-only)
  (let* ((length (sb!sys:sap-ref-8 sap offset))
         (vector (make-array length :element-type '(unsigned-byte 8))))
    (declare (type sb!sys:system-area-pointer sap)
             (type (unsigned-byte 8) length)
             (type (simple-array (unsigned-byte 8) (*)) vector))
    (cond (length-only
           (values 0 (1+ length) nil nil))
          (t
           (sb!kernel:copy-ub8-from-system-area sap (1+ offset)
                                                vector 0 length)
           (collect ((sc-offsets)
                     (lengths))
             (lengths 1)                ; the length byte
             (let* ((index 0)
                    (error-number (sb!c:read-var-integer vector index)))
               (lengths index)
               (loop
                 (when (>= index length)
                   (return))
                 (let ((old-index index))
                   (sc-offsets (sb!c:read-var-integer vector index))
                   (lengths (- index old-index))))
               (values error-number
                       (1+ length)
                       (sc-offsets)
                       (lengths))))))))

(defun emit-conditional-branch (segment bo bi target &optional aa-p lk-p)
  (declare (type boolean aa-p lk-p))
  (let* ((bo (valid-bo-encoding bo))
         (bi (valid-bi-encoding bi))
         (aa-bit (if aa-p 1 0))
         (lk-bit (if lk-p 1 0)))
    (if aa-p                            ; Not bloody likely, bwth.
      (emit-b-form-inst segment 16 bo bi target aa-bit lk-bit)
      ;; the target may be >32k away, in which case we have to invert the
      ;; test and do an absolute branch
      (emit-chooser
       ;; We emit either 4 or 8 bytes, so I think we declare this as
       ;; preserving 4 byte alignment.  If this gives us no joy, we can
       ;; stick a nop in the long branch and then we will be
       ;; preserving 8 byte alignment
       segment 8 2 ; 2^2 is 4 byte alignment.  I think
       #'(lambda (segment posn magic-value)
           (let ((delta (ash (- (label-position target posn magic-value) posn)
                             -2)))
             (when (typep delta '(signed-byte 14))
               (emit-back-patch segment 4
                                #'(lambda (segment posn)
                                    (emit-b-form-inst
                                     segment 16 bo bi
                                     (ash (- (label-position target) posn) -2)
                                     aa-bit lk-bit)))
               t)))
       #'(lambda (segment posn)
           (declare (ignore posn))
           (let ((bo (logxor 8 bo))) ;; invert the test
             (emit-b-form-inst segment 16 bo bi
                               2 ; skip over next instruction
                               0 0)
             (emit-back-patch segment 4
                              #'(lambda (segment posn)
                                  (declare (ignore posn))
                                  (emit-i-form-branch segment target lk-p)))))
       ))))



; non-absolute I-form: B, BL.
(defun emit-i-form-branch (segment target &optional lk-p)
  (let* ((lk-bit (if lk-p 1 0)))
    (etypecase target
      (fixup
       (note-fixup segment :b target)
       (emit-i-form-inst segment 18 0 0 lk-bit))
      (label
       (emit-back-patch segment 4
                        #'(lambda (segment posn)
                            (emit-i-form-inst
                             segment
                             18
                             (ash (- (label-position target) posn) -2)
                             0
                             lk-bit)))))))

(eval-when (:compile-toplevel :execute :load-toplevel)
(defparameter *spr-numbers-alist* '((:xer 1) (:lr 8) (:ctr 9))))

(sb!disassem:define-arg-type spr
  :printer #'(lambda (value stream dstate)
               (declare (ignore dstate)
                        (type (unsigned-byte 10) value))
               (let* ((name (car (rassoc value *spr-numbers-alist*))))
                   (if name
                     (princ name stream)
                     (princ value stream)))))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defparameter jump-printer
    #'(lambda (value stream dstate)
        (let ((addr (ash value 2)))
          (sb!disassem:maybe-note-assembler-routine addr t dstate)
          (write addr :base 16 :radix t :stream stream)))))



;;;; dissassem:define-instruction-formats

(eval-when (:compile-toplevel :execute)
  (defmacro ppc-byte (startbit &optional (endbit startbit))