insts.lisp

开源跨平台Lisp编译器

  (op2    :field (byte 3 10))
  (cp     :field (byte 5 5) :type 'cp)
  (t/clen :field (byte 5 0) :type 'clen))

(sb!disassem:define-instruction-format
    (break 32 :default-printer '(:name :tab im13 "," im5))
  (op1  :field (byte 6 26) :value 0)
  (im13 :field (byte 13 13))
  (q2   :field (byte 8 5) :value 0)
  (im5  :field (byte 5 0)))

(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 break-control (chunk inst stream dstate)
  (declare (ignore inst))
  (flet ((nt (x) (if stream (sb!disassem:note x dstate))))
    (case (break-im5 chunk dstate)
      (#.error-trap
       (nt "Error trap")
       (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
      (#.cerror-trap
       (nt "Cerror trap")
       (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
      (#.breakpoint-trap
       (nt "Breakpoint trap"))
      (#.pending-interrupt-trap
       (nt "Pending interrupt trap"))
      (#.halt-trap
       (nt "Halt trap"))
      (#.fun-end-breakpoint-trap
       (nt "Function end breakpoint trap"))
    )))

(sb!disassem:define-instruction-format
    (system-inst 32)
  (op1 :field (byte 6 26) :value 0)
  (r1  :field (byte 5 21) :type 'reg)
  (r2  :field (byte 5 16) :type 'reg)
  (s   :field (byte 3 13))
  (op2 :field (byte 8 5))
  (r3  :field (byte 5 0) :type 'reg))

(sb!disassem:define-instruction-format
    (fp-load/store 32)
  (op :field (byte 6 26))
  (b  :field (byte 5 21) :type 'reg)
  (x  :field (byte 5 16) :type 'reg)
  (s  :field (byte 2 14) :type 'space)
  (u  :field (byte 1 13))
  (x1 :field (byte 1 12))
  (x2 :field (byte 2 10))
  (x3 :field (byte 1 9))
  (x4 :field (byte 3 6))
  (m  :field (byte 1 5))
  (t  :field (byte 5 0) :type 'fp-reg))

(sb!disassem:define-instruction-format
    (fp-class-0-inst 32)
  (op1 :field (byte 6 26))
  (r   :field (byte 5 21) :type 'fp-reg)
  (x1  :field (byte 5 16) :type 'fp-reg)
  (op2 :field (byte 3 13))
  (fmt :field (byte 2 11) :type 'fp-fmt-0c)
  (x2  :field (byte 2 9))
  (x3  :field (byte 3 6))
  (x4  :field (byte 1 5))
  (t   :field (byte 5 0) :type 'fp-reg))

(sb!disassem:define-instruction-format
    (fp-class-1-inst 32)
  (op1 :field (byte 6 26))
  (r   :field (byte 5 21) :type 'fp-reg)
  (x1  :field (byte 4 17) :value 0)
  (x2  :field (byte 2 15))
  (df  :field (byte 2 13) :type 'fp-fmt-0c)
  (sf  :field (byte 2 11) :type 'fp-fmt-0c)
  (x3  :field (byte 2 9) :value 1)
  (x4  :field (byte 3 6) :value 0)
  (x5  :field (byte 1 5) :value 0)
  (t   :field (byte 5 0) :type 'fp-reg))



;;;; Load and Store stuff.

(define-bitfield-emitter emit-load/store 32
  (byte 6 26)
  (byte 5 21)
  (byte 5 16)
  (byte 2 14)
  (byte 14 0))


(defun im14-encoding (segment disp)
  (declare (type (or fixup (signed-byte 14))))
  (cond ((fixup-p disp)
         (note-fixup segment :load disp)
         (aver (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
         0)
        (t
         (dpb (ldb (byte 13 0) disp)
              (byte 13 1)
              (ldb (byte 1 13) disp)))))

(macrolet ((define-load-inst (name opcode)
               `(define-instruction ,name (segment disp base reg)
                 (:declare (type tn reg base)
                  (type (or fixup (signed-byte 14)) disp))
                 (:printer load/store ((op ,opcode) (s 0))
                  '(:name :tab im14 "(" s b ")," t/r))
                 (:emitter
                  (emit-load/store segment ,opcode
                   (reg-tn-encoding base) (reg-tn-encoding reg) 0
                   (im14-encoding segment disp)))))
           (define-store-inst (name opcode)
               `(define-instruction ,name (segment reg disp base)
                 (:declare (type tn reg base)
                  (type (or fixup (signed-byte 14)) disp))
                 (:printer load/store ((op ,opcode) (s 0))
                  '(:name :tab t/r "," im14 "(" s b ")"))
                 (:emitter
                  (emit-load/store segment ,opcode
                   (reg-tn-encoding base) (reg-tn-encoding reg) 0
                   (im14-encoding segment disp))))))
  (define-load-inst ldw #x12)
  (define-load-inst ldh #x11)
  (define-load-inst ldb #x10)
  (define-load-inst ldwm #x13)
  (define-load-inst ldo #x0D)

  (define-store-inst stw #x1A)
  (define-store-inst sth #x19)
  (define-store-inst stb #x18)
  (define-store-inst stwm #x1B))

(define-bitfield-emitter emit-extended-load/store 32
  (byte 6 26) (byte 5 21) (byte 5 16) (byte 2 14) (byte 1 13)
  (byte 3 10) (byte 4 6) (byte 1 5) (byte 5 0))

(macrolet ((define-load-indexed-inst (name opcode)
              `(define-instruction ,name (segment index base reg &key modify scale)
                (:declare (type tn reg base index)
                 (type (member t nil) modify scale))
                (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'reg)
                                               (op2 0))
                 `(:name ,@cmplt-index-print :tab x/im5/r
                                              "(" s b ")" t/im5))
                (:emitter
                 (emit-extended-load/store
                  segment #x03 (reg-tn-encoding base) (reg-tn-encoding index)
                  0 (if scale 1 0) 0 ,opcode (if modify 1 0)
                  (reg-tn-encoding reg))))))
  (define-load-indexed-inst ldwx 2)
  (define-load-indexed-inst ldhx 1)
  (define-load-indexed-inst ldbx 0)
  (define-load-indexed-inst ldcwx 7))

(defun short-disp-encoding (segment disp)
  (declare (type (or fixup (signed-byte 5)) disp))
  (cond ((fixup-p disp)
         (note-fixup segment :load-short disp)
         (aver (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
         0)
        (t
         (dpb (ldb (byte 4 0) disp)
              (byte 4 1)
              (ldb (byte 1 4) disp)))))

(macrolet ((define-load-short-inst (name opcode)
               `(define-instruction ,name (segment base disp reg &key modify)
                 (:declare (type tn base reg)
                  (type (or fixup (signed-byte 5)) disp)
                  (type (member :before :after nil) modify))
                 (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'im5)
                                                (op2 4))
                  `(:name ,@cmplt-disp-print :tab x/im5/r
                    "(" s b ")" t/im5))
                 (:emitter
                  (multiple-value-bind
                        (m a)
                      (ecase modify
                        ((nil) (values 0 0))
                        (:after (values 1 0))
                        (:before (values 1 1)))
                    (emit-extended-load/store segment #x03 (reg-tn-encoding base)
                                              (short-disp-encoding segment disp)
                                              0 a 4 ,opcode m
                                              (reg-tn-encoding reg))))))
           (define-store-short-inst (name opcode)
               `(define-instruction ,name (segment reg base disp &key modify)
                 (:declare (type tn reg base)
                  (type (or fixup (signed-byte 5)) disp)
                  (type (member :before :after nil) modify))
                 (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'im5)
                                                (op2 4))
                  `(:name ,@cmplt-disp-print :tab x/im5/r
                    "," t/im5 "(" s b ")"))
                 (:emitter
                  (multiple-value-bind
                        (m a)
                      (ecase modify
                        ((nil) (values 0 0))
                        (:after (values 1 0))
                        (:before (values 1 1)))
                    (emit-extended-load/store segment #x03 (reg-tn-encoding base)
                                              (short-disp-encoding segment disp)
                                              0 a 4 ,opcode m
                                              (reg-tn-encoding reg)))))))
  (define-load-short-inst ldws 2)
  (define-load-short-inst ldhs 1)
  (define-load-short-inst ldbs 0)
  (define-load-short-inst ldcws 7)

  (define-store-short-inst stws 10)
  (define-store-short-inst sths 9)
  (define-store-short-inst stbs 8))

(define-instruction stbys (segment reg base disp where &key modify)
  (:declare (type tn reg base)
            (type (signed-byte 5) disp)
            (type (member :begin :end) where)
            (type (member t nil) modify))
  (:printer extended-load/store ((ext4/c #xC) (t/im5 nil :type 'im5) (op2 4))
            `(:name ,@cmplt-store-print :tab x/im5/r "," t/im5 "(" s b ")"))
  (:emitter
   (emit-extended-load/store segment #x03 (reg-tn-encoding base)
                             (reg-tn-encoding reg) 0
                             (ecase where (:begin 0) (:end 1))
                             4 #xC (if modify 1 0)
                             (short-disp-encoding segment disp))))


;;;; Immediate Instructions.

(define-bitfield-emitter emit-ldil 32
  (byte 6 26)
  (byte 5 21)
  (byte 21 0))

(defun immed-21-encoding (segment value)
  (declare (type (or fixup (signed-byte 21) (unsigned-byte 21)) value))
  (cond ((fixup-p value)
         (note-fixup segment :hi value)
         (aver (or (null (fixup-offset value)) (zerop (fixup-offset value))))
         0)
        (t
         (logior (ash (ldb (byte 5 2) value) 16)
                 (ash (ldb (byte 2 7) value) 14)
                 (ash (ldb (byte 2 0) value) 12)
                 (ash (ldb (byte 11 9) value) 1)
                 (ldb (byte 1 20) value)))))

(define-instruction ldil (segment value reg)
  (:declare (type tn reg)
            (type (or (signed-byte 21) (unsigned-byte 21) fixup) value))
  (:printer ldil ((op #x08)))
  (:emitter
   (emit-ldil segment #x08 (reg-tn-encoding reg)
              (immed-21-encoding segment value))))

(define-instruction addil (segment value reg)
  (:declare (type tn reg)
            (type (or (signed-byte 21) (unsigned-byte 21) fixup) value))
  (:printer ldil ((op #x0A)))
  (:emitter
   (emit-ldil segment #x0A (reg-tn-encoding reg)
              (immed-21-encoding segment value))))


;;;; Branch instructions.

(define-bitfield-emitter emit-branch 32
  (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
  (byte 11 2) (byte 1 1) (byte 1 0))

(defun label-relative-displacement (label posn &optional delta-if-after)
   (declare (type label label) (type index posn))
  (ash (- (if delta-if-after
              (label-position label posn delta-if-after)
              (label-position label))
          (+ posn 8)) -2))

(defun decompose-branch-disp (segment disp)
  (declare (type (or fixup (signed-byte 17)) disp))
  (cond ((fixup-p disp)
         (note-fixup segment :branch disp)
         (aver (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
         (values 0 0 0))
        (t
         (values (ldb (byte 5 11) disp)
                 (dpb (ldb (byte 10 0) disp)
                      (byte 10 1)
                      (ldb (byte 1 10) disp))
                 (ldb (byte 1 16) disp)))))

(defun emit-relative-branch (segment opcode link sub-opcode target nullify)
  (declare (type (unsigned-byte 6) opcode)
           (type (unsigned-byte 5) link)
           (type (unsigned-byte 1) sub-opcode)
           (type label target)
           (type (member t nil) nullify))
  (emit-back-patch segment 4
    #'(lambda (segment posn)
        (let ((disp (label-relative-displacement target posn)))
          (aver (<= (- (ash 1 16)) disp (1- (ash 1 16))))
          (multiple-value-bind
              (w1 w2 w)
              (decompose-branch-disp segment disp)
            (emit-branch segment opcode link w1 sub-opcode w2
                         (if nullify 1 0) w))))))

(define-instruction b (segment target &key nullify)
  (:declare (type label target) (type (member t nil) nullify))
  (:emitter
   (emit-relative-branch segment #x3A 0 0 target nullify)))

(define-instruction bl (segment target reg &key nullify)
  (:declare (type tn reg) (type label target) (type (member t nil) nullify))
  (:printer branch17 ((op1 #x3A) (op2 0)) '(:name n :tab w "," t))
  (:emitter
   (emit-relative-branch segment #x3A (reg-tn-encoding reg) 0 target nullify)))

(define-instruction gateway (segment target reg &key nullify)
  (:declare (type tn reg) (type label target) (type (member t nil) nullify))
  (:printer branch17 ((op1 #x3A) (op2 1)) '(:name n :tab w "," t))
  (:emitter
   (emit-relative-branch segment #x3A (reg-tn-encoding reg) 1 target nullify)))

;;; BLR is useless because we have no way to generate the offset.

(define-instruction bv (segment base &key nullify offset)
  (:declare (type tn base)
            (type (member t nil) nullify)
            (type (or tn null) offset))
  (:printer branch ((op1 #x3A) (op2 6)) '(:name n :tab x "(" t ")"))
  (:emitter
   (emit-branch segment #x3A (reg-tn-encoding base)
                (if offset (reg-tn-encoding offset) 0)
                6 0 (if nullify 1 0) 0)))

(define-instruction be (segment disp space base &key nullify)
  (:declare (type (or fixup (signed-byte 17)) disp)
            (type tn base)
            (type (unsigned-byte 3) space)
            (type (member t nil) nullify))
  (:printer branch17 ((op1 #x38) (op2 nil :type 'im3))
            '(:name n :tab w "(" op2 "," t ")"))
  (:emitter
   (multiple-value-bind
       (w1 w2 w)
       (decompose-branch-disp segment disp)
     (emit-branch segment #x38 (reg-tn-encoding base) w1
                  (space-encoding space) w2 (if nullify 1 0) w))))