insts.lisp

开源跨平台Lisp编译器

;;; the instruction set definition for the Alpha

;;;; 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")

;;;(def-assembler-params
;;;  :scheduler-p nil)

;;; ../x86/insts contains the invocation
;;; (setf sb!disassem:*disassem-inst-alignment-bytes* 1)
;;; which apparently was another use of def-assembler-params

;;;; utility functions

(defun reg-tn-encoding (tn)
  (declare (type tn tn)
           (values (unsigned-byte 5)))
  (sc-case tn
    (zero zero-offset)
    (null null-offset)
    (t
     (aver (eq (sb-name (sc-sb (tn-sc tn))) 'registers))
     (tn-offset tn))))

(defun fp-reg-tn-encoding (tn)
  (declare (type tn tn))
  (sc-case tn
    (fp-single-zero (tn-offset fp-single-zero-tn))
    (fp-double-zero (tn-offset fp-double-zero-tn))
    (t
     (unless (eq (sb-name (sc-sb (tn-sc tn))) 'float-registers)
       (error "~S isn't a floating-point register." tn))
     (tn-offset tn))))

;;;; initial disassembler setup

;; XXX find out what this was supposed to do
;; (sb!disassem:set-disassem-params :instruction-alignment 32)

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

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

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

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

(sb!disassem:define-arg-type fp-reg
  :printer (lambda (value stream dstate)
             (declare (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))))

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



;;;; DEFINE-INSTRUCTION-FORMATs for the disassembler

(sb!disassem:define-instruction-format
    (memory 32 :default-printer '(:name :tab ra "," disp "(" rb ")"))
  (op   :field (byte 6 26))
  (ra   :field (byte 5 21) :type 'reg)
  (rb   :field (byte 5 16) :type 'reg)
  (disp :field (byte 16 0) :sign-extend t))

(sb!disassem:define-instruction-format
    (jump 32 :default-printer '(:name :tab ra ",(" rb ")," hint))
  (op    :field (byte 6 26))
  (ra    :field (byte 5 21) :type 'reg)
  (rb    :field (byte 5 16) :type 'reg)
  (subop :field (byte 2 14))
  (hint  :field (byte 14 0)))

(sb!disassem:define-instruction-format
    (branch 32 :default-printer '(:name :tab ra "," disp))
  (op   :field (byte 6 26))
  (ra   :field (byte 5 21) :type 'reg)
  (disp :field (byte 21 0) :type 'relative-label))

(sb!disassem:define-instruction-format
    (reg-operate 32 :default-printer '(:name :tab ra "," rb "," rc))
  (op  :field (byte 6 26))
  (ra  :field (byte 5 21) :type 'reg)
  (rb  :field (byte 5 16) :type 'reg)
  (sbz :field (byte 3 13))
  (f   :field (byte 1 12) :value 0)
  (fn  :field (byte 7 5))
  (rc  :field (byte 5 0) :type 'reg))

(sb!disassem:define-instruction-format
    (lit-operate 32 :default-printer '(:name :tab ra "," lit "," rc))
  (op  :field (byte 6 26))
  (ra  :field (byte 5 21) :type 'reg)
  (lit :field (byte 8 13))
  (f   :field (byte 1 12) :value 1)
  (fn  :field (byte 7 5))
  (rc  :field (byte 5 0) :type 'reg))

(sb!disassem:define-instruction-format
    (fp-operate 32 :default-printer '(:name :tab fa "," fb "," fc))
  (op :field (byte 6 26))
  (fa :field (byte 5 21) :type 'fp-reg)
  (fb :field (byte 5 16) :type 'fp-reg)
  (fn :field (byte 11 5))
  (fc :field (byte 5 0) :type 'fp-reg))

(sb!disassem:define-instruction-format
    (call-pal 32 :default-printer '('call_pal :tab 'pal_ :name))
  (op      :field (byte 6 26) :value 0)
  (palcode :field (byte 26 0)))


;;;; emitters

(define-bitfield-emitter emit-word 16
  (byte 16 0))

(define-bitfield-emitter emit-lword 32
  (byte 32 0))

(define-bitfield-emitter emit-qword 64
  (byte 64 0))

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

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

(define-bitfield-emitter emit-reg-operate 32
  (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 1 12) (byte 7 5)
  (byte 5 0))

(define-bitfield-emitter emit-lit-operate 32
  (byte 6 26) (byte 5 21) (byte 8 13) (byte 1 12) (byte 7 5) (byte 5 0))

(define-bitfield-emitter emit-fp-operate 32
  (byte 6 26) (byte 5 21) (byte 5 16) (byte 11 5) (byte 5 0))

(define-bitfield-emitter emit-pal 32
  (byte 6 26) (byte 26 0))

;;;; macros for instructions

(macrolet ((define-memory (name op &optional fixup float)
             `(define-instruction ,name (segment ra disp rb ,@(if fixup
                                                                  '(&optional type)))
                (:declare (type tn ra rb)
                          ,@(if fixup    ; ### unsigned-byte 16 bad idea?
                                '((type (or (unsigned-byte 16) (signed-byte 16) fixup)
                                        disp))
                              '((type (or (unsigned-byte 16) (signed-byte 16)) disp))))
                (:printer memory ((op ,op)))
                (:emitter
                 ,@(when fixup
                     `((when (fixup-p disp)
                         (note-fixup segment (or type ,fixup) disp)
                         (setf disp 0))))
                 (emit-memory segment ,op ,@(if float
                                                '((fp-reg-tn-encoding ra))
                                              '((reg-tn-encoding ra)))
                              (reg-tn-encoding rb)
                              disp)))))
  (define-memory lda   #x08 :lda)
  (define-memory ldah  #x09 :ldah)
  (define-memory ldbu  #x0a)            ; BWX extension
  (define-memory ldwu  #x0c)            ; BWX extension
  (define-memory ldl   #x28)
  (define-memory ldq   #x29)
  (define-memory ldl_l #x2a)
  (define-memory ldq_q #x2b)
  (define-memory ldq_u #x0b)
  (define-memory stw   #x0d)            ; BWX extension
  (define-memory stb   #x0e)            ; BWX extension
  (define-memory stl   #x2c)
  (define-memory stq   #x2d)
  (define-memory stl_c #x2e)
  (define-memory stq_c #x2f)
  (define-memory stq_u #x0f)
  (define-memory ldf   #x20 nil t)
  (define-memory ldg   #x21 nil t)
  (define-memory lds   #x22 nil t)
  (define-memory ldt   #x23 nil t)
  (define-memory stf   #x24 nil t)
  (define-memory stg   #x25 nil t)
  (define-memory sts   #x26 nil t)
  (define-memory stt   #x27 nil t))

(macrolet ((define-jump (name subop)
             `(define-instruction ,name (segment ra rb &optional (hint 0))
                (:declare (type tn ra rb)
                          (type (or (unsigned-byte 14) fixup) hint))
                (:printer jump ((op #x1a) (subop ,subop)))
                (:emitter
                 (when (fixup-p hint)
                   (note-fixup segment :jmp-hint hint)
                   (setf hint 0))
                 (emit-memory segment #x1a (reg-tn-encoding ra) (reg-tn-encoding rb)
                              (logior (ash ,subop 14) hint))))))
  (define-jump jmp 0)
  (define-jump jsr 1)
  (define-jump ret 2)
  (define-jump jsr-coroutine 3))


(macrolet ((define-branch (name op &optional (float nil))
             `(define-instruction ,name (segment ra target)
                (:declare (type tn ra)
                          (type label target))
                (:printer branch ((op ,op)
                                  ,@(when float
                                      '((ra nil :type 'fp-reg)))))
                (:emitter
                 (emit-back-patch segment 4
                                  (lambda (segment posn)
                                    (emit-branch segment ,op
                                                 ,@(if float
                                                       '((fp-reg-tn-encoding ra))
                                                       '((reg-tn-encoding ra)))
                                                 (ash (- (label-position target)
                                                         (+ posn 4))
                                                      -2))))))))
  (define-branch br   #x30)
  (define-branch bsr  #x34)
  (define-branch blbc #x38)
  (define-branch blbs #x3c)
  (define-branch fbeq #x31 t)
  (define-branch fbne #x35 t)
  (define-branch beq  #x39)
  (define-branch bne  #x3d)
  (define-branch fblt #x32 t)
  (define-branch fbge #x36 t)
  (define-branch blt  #x3a)
  (define-branch bge  #x3e)
  (define-branch fble #x33 t)
  (define-branch fbgt #x37 t)
  (define-branch ble  #x3b)
  (define-branch bgt  #x3f))

(macrolet ((define-operate (name op fn)
             `(define-instruction ,name (segment ra rb rc)
                (:declare (type tn ra rc)
                          (type (or tn (unsigned-byte 8)) rb))
                (:printer reg-operate ((op ,op) (fn ,fn)))
                (:printer lit-operate ((op ,op) (fn ,fn)))
                ,@(when (and (= op #x11) (= fn #x20))
                    `((:printer reg-operate ((op ,op) (fn ,fn) (ra 31))
                                '('move :tab rb "," rc))
                      (:printer reg-operate ((op ,op) (fn ,fn) (ra 31) (rb 31) (rc 31))
                                '('nop))))
                (:emitter
                 (etypecase rb
                   (tn
                    (emit-reg-operate segment ,op (reg-tn-encoding ra)
                                      (reg-tn-encoding rb) 0 0 ,fn (reg-tn-encoding rc)))
                   (number
                    (emit-lit-operate segment ,op (reg-tn-encoding ra) rb 1 ,fn
                                      (reg-tn-encoding rc))))))))
  (define-operate addl   #x10 #x00)
  (define-operate addl/v #x10 #x40)
  (define-operate addq   #x10 #x20)
  (define-operate addq/v #x10 #x60)
  (define-operate cmpule #x10 #x3d)
  (define-operate cmpbge #x10 #x0f)
  (define-operate subl   #x10 #x09)
  (define-operate subl/v #x10 #x49)
  (define-operate subq   #x10 #x29)
  (define-operate subq/v #x10 #x69)
  (define-operate cmpeq  #x10 #x2d)
  (define-operate cmplt  #x10 #x4d)
  (define-operate cmple  #x10 #x6d)
  (define-operate cmpult #x10 #x1d)
  (define-operate s4addl #x10 #x02)
  (define-operate s4addq #x10 #x22)
  (define-operate s4subl #x10 #x0b)
  (define-operate s4subq #x10 #x2b)
  (define-operate s8addl #x10 #x12)
  (define-operate s8addq #x10 #x32)
  (define-operate s8subl #x10 #x1b)
  (define-operate s8subq #x10 #x3b)

  (define-operate and     #x11 #x00)
  (define-operate bic     #x11 #x08)
  (define-operate cmoveq  #x11 #x24)
  (define-operate cmovne  #x11 #x26)
  (define-operate cmovlbs #x11 #x14)
  (define-operate bis     #x11 #x20)
  (define-operate ornot   #x11 #x28)
  (define-operate cmovlt  #x11 #x44)
  (define-operate cmovge  #x11 #x46)
  (define-operate cmovlbc #x11 #x16)
  (define-operate xor     #x11 #x40)
  (define-operate eqv     #x11 #x48)
  (define-operate cmovle  #x11 #x64)
  (define-operate cmovgt  #x11 #x66)