insts.lisp

开源跨平台Lisp编译器

  #'equalp)

(define-instruction blez (segment reg target)
  (:declare (type label target) (type tn reg))
  (:printer
   immediate ((op #b000110) (rt 0) (immediate nil :type 'relative-label))
            cond-branch-printer)
  (:attributes branch)
  (:dependencies (reads reg))
  (:delay 1)
  (:emitter
   (emit-relative-branch segment #b000110 reg 0 target)))

(define-instruction bgtz (segment reg target)
  (:declare (type label target) (type tn reg))
  (:printer
   immediate ((op #b000111) (rt 0) (immediate nil :type 'relative-label))
            cond-branch-printer)
  (:attributes branch)
  (:dependencies (reads reg))
  (:delay 1)
  (:emitter
   (emit-relative-branch segment #b000111 reg 0 target)))

(define-instruction bltz (segment reg target)
  (:declare (type label target) (type tn reg))
  (:printer
   immediate ((op bcond-op) (rt 0) (immediate nil :type 'relative-label))
            cond-branch-printer)
  (:attributes branch)
  (:dependencies (reads reg))
  (:delay 1)
  (:emitter
   (emit-relative-branch segment bcond-op reg #b00000 target)))

(define-instruction bgez (segment reg target)
  (:declare (type label target) (type tn reg))
  (:printer
   immediate ((op bcond-op) (rt 1) (immediate nil :type 'relative-label))
            cond-branch-printer)
  (:attributes branch)
  (:dependencies (reads reg))
  (:delay 1)
  (:emitter
   (emit-relative-branch segment bcond-op reg #b00001 target)))

(define-instruction bltzal (segment reg target)
  (:declare (type label target) (type tn reg))
  (:printer
   immediate ((op bcond-op) (rt #b01000) (immediate nil :type 'relative-label))
            cond-branch-printer)
  (:attributes branch)
  (:dependencies (reads reg) (writes lip-tn))
  (:delay 1)
  (:emitter
   (emit-relative-branch segment bcond-op reg #b10000 target)))

(define-instruction bgezal (segment reg target)
  (:declare (type label target) (type tn reg))
  (:printer
   immediate ((op bcond-op) (rt #b01001) (immediate nil :type 'relative-label))
            cond-branch-printer)
  (:attributes branch)
  (:delay 1)
  (:dependencies (reads reg) (writes lip-tn))
  (:emitter
   (emit-relative-branch segment bcond-op reg #b10001 target)))

(defconstant-eqx j-printer
  '(:name :tab (:choose rs target))
  #'equalp)

(define-instruction j (segment target)
  (:declare (type (or tn fixup) target))
  (:printer register ((op special-op) (rt 0) (rd 0) (funct #b001000))
            j-printer)
  (:printer jump ((op #b000010)) j-printer)
  (:attributes branch)
  (:dependencies (reads target))
  (:delay 1)
  (:emitter
   (etypecase target
     (tn
      (emit-register-inst segment special-op (reg-tn-encoding target)
                          0 0 0 #b001000))
     (fixup
      (note-fixup segment :lui target)
      (emit-immediate-inst segment #b001111 0 28 0)
      (note-fixup segment :addi target)
      (emit-immediate-inst segment #b001001 28 28 0)
      (emit-register-inst segment special-op 28 0 0 0 #b001000)))))

(define-instruction jal (segment reg-or-target &optional target)
  (:declare (type (or null tn fixup) target)
            (type (or tn fixup) reg-or-target))
  (:printer register ((op special-op) (rt 0) (funct #b001001)) j-printer)
  (:printer jump ((op #b000011)) j-printer)
  (:attributes branch)
  (:dependencies (cond
                   (target
                    (writes reg-or-target) (reads target))
                   (t
                    (writes lip-tn)
                    (when (tn-p reg-or-target)
                      (reads reg-or-target)))))
  (:delay 1)
  (:emitter
   (unless target
     (setf target reg-or-target
           reg-or-target lip-tn))
   (etypecase target
     (tn
      (emit-register-inst segment special-op (reg-tn-encoding target) 0
                          (reg-tn-encoding reg-or-target) 0 #b001001))
     (fixup
      (note-fixup segment :lui target)
      (emit-immediate-inst segment #b001111 0 28 0)
      (note-fixup segment :addi target)
      (emit-immediate-inst segment #b001001 28 28 0)
      (emit-register-inst segment special-op 28 0
                          (reg-tn-encoding reg-or-target) 0 #b001001)))))

(define-instruction bc1f (segment target)
  (:declare (type label target))
  (:printer coproc-branch ((op cop1-op) (funct #x100)
                           (offset nil :type 'relative-label)))
  (:attributes branch)
  (:dependencies (reads :float-status))
  (:delay 1)
  (:emitter
   (emit-relative-branch segment cop1-op #b01000 #b00000 target)))

(define-instruction bc1t (segment target)
  (:declare (type label target))
  (:printer coproc-branch ((op cop1-op) (funct #x101)
                           (offset nil :type 'relative-label)))
  (:attributes branch)
  (:dependencies (reads :float-status))
  (:delay 1)
  (:emitter
   (emit-relative-branch segment cop1-op #b01000 #b00001 target)))



;;;; Random movement instructions.

(define-instruction lui (segment reg value)
  (:declare (type tn reg)
            (type (or fixup (signed-byte 16) (unsigned-byte 16)) value))
  (:printer immediate ((op #b001111)
                       (immediate nil :sign-extend nil :printer "#x~4,'0X")))
  (:dependencies (writes reg))
  (:delay 0)
  (:emitter
   (when (fixup-p value)
     (note-fixup segment :lui value)
     (setf value 0))
   (emit-immediate-inst segment #b001111 0 (reg-tn-encoding reg) value)))

(defconstant-eqx mvsreg-printer '(:name :tab rd)
  #'equalp)

(define-instruction mfhi (segment reg)
  (:declare (type tn reg))
  (:printer register ((op special-op) (rs 0) (rt 0) (funct #b010000))
            mvsreg-printer)
  (:dependencies (reads :hi-reg) (writes reg))
  (:delay 2)
  (:emitter
   (emit-register-inst segment special-op 0 0 (reg-tn-encoding reg) 0
                        #b010000)))

(define-instruction mthi (segment reg)
  (:declare (type tn reg))
  (:printer register ((op special-op) (rs 0) (rt 0) (funct #b010001))
            mvsreg-printer)
  (:dependencies (reads reg) (writes :hi-reg))
  (:delay 0)
  (:emitter
   (emit-register-inst segment special-op 0 0 (reg-tn-encoding reg) 0
                        #b010001)))

(define-instruction mflo (segment reg)
  (:declare (type tn reg))
  (:printer register ((op special-op) (rs 0) (rt 0) (funct #b010010))
            mvsreg-printer)
  (:dependencies (reads :low-reg) (writes reg))
  (:delay 2)
  (:emitter
   (emit-register-inst segment special-op 0 0 (reg-tn-encoding reg) 0
                        #b010010)))

(define-instruction mtlo (segment reg)
  (:declare (type tn reg))
  (:printer register ((op special-op) (rs 0) (rt 0) (funct #b010011))
            mvsreg-printer)
  (:dependencies (reads reg) (writes :low-reg))
  (:delay 0)
  (:emitter
   (emit-register-inst segment special-op 0 0 (reg-tn-encoding reg) 0
                        #b010011)))

(define-instruction move (segment dst src)
  (:declare (type tn dst src))
  (:printer register ((op special-op) (rt 0) (funct #b100001))
            '(:name :tab rd ", " rs))
  (:attributes flushable)
  (:dependencies (reads src) (writes dst))
  (:delay 0)
  (:emitter
   (emit-register-inst segment special-op (reg-tn-encoding src) 0
                       (reg-tn-encoding dst) 0 #b100001)))

(define-instruction fmove (segment format dst src)
  (:declare (type float-format format) (type tn dst src))
  (:printer float ((funct #b000110)) '(:name "." format :tab fd ", " fs))
  (:attributes flushable)
  (:dependencies (reads src) (writes dst))
  (:delay 0)
  (:emitter
   (emit-float-inst segment cop1-op 1 (float-format-value format) 0
                    (fp-reg-tn-encoding src) (fp-reg-tn-encoding dst)
                    #b000110)))

(defun %li (reg value)
  (etypecase value
    ((unsigned-byte 16)
     (inst or reg zero-tn value))
    ((signed-byte 16)
     (inst addu reg zero-tn value))
    ((or (signed-byte 32) (unsigned-byte 32))
     (inst lui reg (ldb (byte 16 16) value))
     (inst or reg (ldb (byte 16 0) value)))
    (fixup
     (inst lui reg value)
     (inst addu reg value))))

(define-instruction-macro li (reg value)
  `(%li ,reg ,value))

(defconstant-eqx sub-op-printer '(:name :tab rd ", " rt) #'equalp)

(define-instruction mtc1 (segment to from)
  (:declare (type tn to from))
  (:printer register ((op cop1-op) (rs #b00100) (funct 0)) sub-op-printer)
  (:dependencies (reads from) (writes to))
  (:delay 1)
  (:emitter
   (emit-register-inst segment cop1-op #b00100 (reg-tn-encoding from)
                       (fp-reg-tn-encoding to) 0 0)))

(define-instruction mtc1-odd (segment to from)
  (:declare (type tn to from))
  (:dependencies (reads from) (writes to))
  (:delay 1)
  (:emitter
   (emit-register-inst segment cop1-op #b00100 (reg-tn-encoding from)
                       (1+ (fp-reg-tn-encoding to)) 0 0)))

(define-instruction mfc1 (segment to from)
  (:declare (type tn to from))
  (:printer register ((op cop1-op) (rs 0) (rd nil :type 'fp-reg) (funct 0))
            sub-op-printer)
  (:dependencies (reads from) (writes to))
  (:delay 1)
  (:emitter
   (emit-register-inst segment cop1-op #b00000 (reg-tn-encoding to)
                       (fp-reg-tn-encoding from) 0 0)))

(define-instruction mfc1-odd (segment to from)
  (:declare (type tn to from))
  (:dependencies (reads from) (writes to))
  (:delay 1)
  (:emitter
   (emit-register-inst segment cop1-op #b00000 (reg-tn-encoding to)
                       (1+ (fp-reg-tn-encoding from)) 0 0)))

(define-instruction mfc1-odd2 (segment to from)
  (:declare (type tn to from))
  (:dependencies (reads from) (writes to))
  (:delay 1)
  (:emitter
   (emit-register-inst segment cop1-op #b00000 (1+ (reg-tn-encoding to))
                       (fp-reg-tn-encoding from) 0 0)))

(define-instruction mfc1-odd3 (segment to from)
  (:declare (type tn to from))
  (:dependencies (reads from) (writes to))
  (:delay 1)
  (:emitter
   (emit-register-inst segment cop1-op #b00000 (1+ (reg-tn-encoding to))
                       (1+ (fp-reg-tn-encoding from)) 0 0)))

(define-instruction cfc1 (segment reg cr)
  (:declare (type tn reg) (type (unsigned-byte 5) cr))
  (:printer register ((op cop1-op) (rs #b00010) (rd nil :type 'control-reg)
                      (funct 0)) sub-op-printer)
  (:dependencies (reads :ctrl-stat-reg) (writes reg))
  (:delay 1)
  (:emitter
   (emit-register-inst segment cop1-op #b00010 (reg-tn-encoding reg)
                       cr 0 0)))

(define-instruction ctc1 (segment reg cr)
  (:declare (type tn reg) (type (unsigned-byte 5) cr))
  (:printer register ((op cop1-op) (rs #b00110) (rd nil :type 'control-reg)
                      (funct 0)) sub-op-printer)
  (:dependencies (reads reg) (writes :ctrl-stat-reg))
  (:delay 1)
  (:emitter
   (emit-register-inst segment cop1-op #b00110 (reg-tn-encoding reg)
                       cr 0 0)))



;;;; Random system hackery and other noise

(define-instruction-macro entry-point ()
  nil)

(defun snarf-error-junk (sap offset &optional length-only)
  (let* ((length (sap-ref-8 sap offset))
         (vector (make-array length :element-type '(unsigned-byte 8))))
    (declare (type 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
           (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))))))))

(defmacro break-cases (breaknum &body cases)
  (let ((bn-temp (gensym)))
    (collect ((clauses))
      (dolist (case cases)
        (clauses `((= ,bn-temp ,(car case)) ,@(cdr case))))
      `(let ((,bn-temp ,breaknum))