insts.lisp

开源跨平台Lisp编译器

         (cond ,@(clauses))))))

(defun break-control (chunk inst stream dstate)
  (declare (ignore inst))
  (flet ((nt (x) (if stream (sb!disassem:note x dstate))))
    (when (= (break-code chunk dstate) 0)
      (case (break-subcode chunk dstate)
        (#.halt-trap
         (nt "Halt trap"))
        (#.pending-interrupt-trap
         (nt "Pending interrupt trap"))
        (#.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"))
        (#.fun-end-breakpoint-trap
         (nt "Function end breakpoint trap"))
        (#.after-breakpoint-trap
         (nt "After breakpoint trap"))
        (#.pseudo-atomic-trap
         (nt "Pseudo atomic trap"))
        (#.object-not-list-trap
         (nt "Object not list trap"))
        (#.object-not-instance-trap
         (nt "Object not instance trap"))
        (#.single-step-around-trap
         (nt "Single step around trap"))
        (#.single-step-before-trap
         (nt "Single step before trap"))))))

(define-instruction break (segment code &optional (subcode 0))
  (:declare (type (unsigned-byte 10) code subcode))
  (:printer break ((op special-op) (funct #b001101))
            '(:name :tab code (:unless (:constant 0) ", " subcode))
            :control #'break-control)
  :pinned
  (:cost 0)
  (:delay 0)
  (:emitter
   (emit-break-inst segment special-op code subcode #b001101)))

(define-instruction syscall (segment)
  (:printer register ((op special-op) (rd 0) (rt 0) (rs 0) (funct #b001110))
            '(:name))
  :pinned
  (:delay 0)
  (:emitter
   (emit-register-inst segment special-op 0 0 0 0 #b001110)))

(define-instruction nop (segment)
  (:printer register ((op 0) (rd 0) (rd 0) (rs 0) (funct 0)) '(:name))
  (:attributes flushable)
  (:delay 0)
  (:emitter
   (emit-word segment 0)))

(!def-vm-support-routine emit-nop (segment)
  (emit-word segment 0))

(define-instruction word (segment word)
  (:declare (type (or (unsigned-byte 32) (signed-byte 32)) word))
  :pinned
  (:cost 0)
  (:delay 0)
  (:emitter
   (emit-word segment word)))

(define-instruction short (segment short)
  (:declare (type (or (unsigned-byte 16) (signed-byte 16)) short))
  :pinned
  (:cost 0)
  (:delay 0)
  (:emitter
   (emit-short segment short)))

(define-instruction byte (segment byte)
  (:declare (type (or (unsigned-byte 8) (signed-byte 8)) byte))
  :pinned
  (:cost 0)
  (:delay 0)
  (:emitter
   (emit-byte segment byte)))


(defun emit-header-data (segment type)
  (emit-back-patch
   segment 4
   #'(lambda (segment posn)
       (emit-word segment
                  (logior type
                          (ash (+ posn (component-header-length))
                               (- n-widetag-bits word-shift)))))))

(define-instruction simple-fun-header-word (segment)
  :pinned
  (:cost 0)
  (:delay 0)
  (:emitter
   (emit-header-data segment simple-fun-header-widetag)))

(define-instruction lra-header-word (segment)
  :pinned
  (:cost 0)
  (:delay 0)
  (:emitter
   (emit-header-data segment return-pc-header-widetag)))


(defun emit-compute-inst (segment vop dst src label temp calc)
  (emit-chooser
   ;; We emit either 12 or 4 bytes, so we maintain 8 byte alignments.
   segment 12 3
   #'(lambda (segment posn delta-if-after)
       (let ((delta (funcall calc label posn delta-if-after)))
          (when (typep delta '(signed-byte 16))
            (emit-back-patch segment 4
                             #'(lambda (segment posn)
                                 (assemble (segment vop)
                                           (inst addu dst src
                                                 (funcall calc label posn 0)))))
            t)))
   #'(lambda (segment posn)
       (let ((delta (funcall calc label posn 0)))
         (assemble (segment vop)
                   (inst lui temp (ldb (byte 16 16) delta))
                   (inst or temp (ldb (byte 16 0) delta))
                   (inst addu dst src temp))))))

;; code = lip - header - label-offset + other-pointer-lowtag
(define-instruction compute-code-from-lip (segment dst src label temp)
  (:declare (type tn dst src temp) (type label label))
  (:attributes variable-length)
  (:dependencies (reads src) (writes dst) (writes temp))
  (:delay 0)
  (:vop-var vop)
  (:emitter
   (emit-compute-inst segment vop dst src label temp
                      #'(lambda (label posn delta-if-after)
                          (- other-pointer-lowtag
                             (label-position label posn delta-if-after)
                             (component-header-length))))))

;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
;;      = lra - (header + label-offset)
(define-instruction compute-code-from-lra (segment dst src label temp)
  (:declare (type tn dst src temp) (type label label))
  (:attributes variable-length)
  (:dependencies (reads src) (writes dst) (writes temp))
  (:delay 0)
  (:vop-var vop)
  (:emitter
   (emit-compute-inst segment vop dst src label temp
                      #'(lambda (label posn delta-if-after)
                          (- (+ (label-position label posn delta-if-after)
                                (component-header-length)))))))

;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
;;     = code + header + label-offset
(define-instruction compute-lra-from-code (segment dst src label temp)
  (:declare (type tn dst src temp) (type label label))
  (:attributes variable-length)
  (:dependencies (reads src) (writes dst) (writes temp))
  (:delay 0)
  (:vop-var vop)
  (:emitter
   (emit-compute-inst segment vop dst src label temp
                      #'(lambda (label posn delta-if-after)
                          (+ (label-position label posn delta-if-after)
                             (component-header-length))))))


;;;; Loads and Stores

(defun emit-load/store-inst (segment opcode reg base index
                                     &optional (oddhack 0))
  (when (fixup-p index)
    (note-fixup segment :addi index)
    (setf index 0))
  (emit-immediate-inst segment opcode (reg-tn-encoding reg)
                       (+ (reg-tn-encoding base) oddhack) index))

(defconstant-eqx load-store-printer
  '(:name :tab
          rt ", "
          rs
          (:unless (:constant 0) "[" immediate "]"))
  #'equalp)

(define-instruction lb (segment reg base &optional (index 0))
  (:declare (type tn reg base)
            (type (or (signed-byte 16) fixup) index))
  (:printer immediate ((op #b100000)) load-store-printer)
  (:dependencies (reads base) (reads :memory) (writes reg))
  (:delay 1)
  (:emitter
   (emit-load/store-inst segment #b100000 base reg index)))

(define-instruction lh (segment reg base &optional (index 0))
  (:declare (type tn reg base)
            (type (or (signed-byte 16) fixup) index))
  (:printer immediate ((op #b100001)) load-store-printer)
  (:dependencies (reads base) (reads :memory) (writes reg))
  (:delay 1)
  (:emitter
   (emit-load/store-inst segment #b100001 base reg index)))

(define-instruction lwl (segment reg base &optional (index 0))
  (:declare (type tn reg base)
            (type (or (signed-byte 16) fixup) index))
  (:printer immediate ((op #b100010)) load-store-printer)
  (:dependencies (reads base) (reads :memory) (writes reg))
  (:delay 1)
  (:emitter
   (emit-load/store-inst segment #b100010 base reg index)))

(define-instruction lw (segment reg base &optional (index 0))
  (:declare (type tn reg base)
            (type (or (signed-byte 16) fixup) index))
  (:printer immediate ((op #b100011)) load-store-printer)
  (:dependencies (reads base) (reads :memory) (writes reg))
  (:delay 1)
  (:emitter
   (emit-load/store-inst segment #b100011 base reg index)))

;; next is just for ease of coding double-in-int c-call convention
(define-instruction lw-odd (segment reg base &optional (index 0))
  (:declare (type tn reg base)
            (type (or (signed-byte 16) fixup) index))
  (:dependencies (reads base) (reads :memory) (writes reg))
  (:delay 1)
  (:emitter
   (emit-load/store-inst segment #b100011 base reg index 1)))

(define-instruction lbu (segment reg base &optional (index 0))
  (:declare (type tn reg base)
            (type (or (signed-byte 16) fixup) index))
  (:printer immediate ((op #b100100)) load-store-printer)
  (:dependencies (reads base) (reads :memory) (writes reg))
  (:delay 1)
  (:emitter
   (emit-load/store-inst segment #b100100 base reg index)))

(define-instruction lhu (segment reg base &optional (index 0))
  (:declare (type tn reg base)
            (type (or (signed-byte 16) fixup) index))
  (:printer immediate ((op #b100101)) load-store-printer)
  (:dependencies (reads base) (reads :memory) (writes reg))
  (:delay 1)
  (:emitter
   (emit-load/store-inst segment #b100101 base reg index)))

(define-instruction lwr (segment reg base &optional (index 0))
  (:declare (type tn reg base)
            (type (or (signed-byte 16) fixup) index))
  (:printer immediate ((op #b100110)) load-store-printer)
  (:dependencies (reads base) (reads :memory) (writes reg))
  (:delay 1)
  (:emitter
   (emit-load/store-inst segment #b100110 base reg index)))

(define-instruction sb (segment reg base &optional (index 0))
  (:declare (type tn reg base)
            (type (or (signed-byte 16) fixup) index))
  (:printer immediate ((op #b101000)) load-store-printer)
  (:dependencies (reads base) (reads reg) (writes :memory))
  (:delay 0)
  (:emitter
   (emit-load/store-inst segment #b101000 base reg index)))

(define-instruction sh (segment reg base &optional (index 0))
  (:declare (type tn reg base)
            (type (or (signed-byte 16) fixup) index))
  (:printer immediate ((op #b101001)) load-store-printer)
  (:dependencies (reads base) (reads reg) (writes :memory))
  (:delay 0)
  (:emitter
   (emit-load/store-inst segment #b101001 base reg index)))

(define-instruction swl (segment reg base &optional (index 0))
  (:declare (type tn reg base)
            (type (or (signed-byte 16) fixup) index))
  (:printer immediate ((op #b101010)) load-store-printer)
  (:dependencies (reads base) (reads reg) (writes :memory))
  (:delay 0)
  (:emitter
   (emit-load/store-inst segment #b101010 base reg index)))

(define-instruction sw (segment reg base &optional (index 0))
  (:declare (type tn reg base)
            (type (or (signed-byte 16) fixup) index))
  (:printer immediate ((op #b101011)) load-store-printer)
  (:dependencies (reads base) (reads reg) (writes :memory))
  (:delay 0)
  (:emitter
   (emit-load/store-inst segment #b101011 base reg index)))

(define-instruction swr (segment reg base &optional (index 0))
  (:declare (type tn reg base)
            (type (or (signed-byte 16) fixup) index))
  (:printer immediate ((op #b101110)) load-store-printer)
  (:dependencies (reads base) (reads reg) (writes :memory))
  (:delay 0)
  (:emitter
   (emit-load/store-inst segment #b101110 base reg index)))


(defun emit-fp-load/store-inst (segment opcode reg odd base index)
  (when (fixup-p index)
    (note-fixup segment :addi index)
    (setf index 0))
  (emit-immediate-inst segment opcode (reg-tn-encoding base)
                       (+ (fp-reg-tn-encoding reg) odd) index))

(define-instruction lwc1 (segment reg base &optional (index 0))
  (:declare (type tn reg base)
            (type (or (signed-byte 16) fixup) index))
  (:printer immediate ((op #b110001) (rt nil :type 'fp-reg)) load-store-printer)
  (:dependencies (reads base) (reads :memory) (writes reg))
  (:delay 1)
  (:emitter
   (emit-fp-load/store-inst segment #b110001 reg 0 base index)))

(define-instruction lwc1-odd (segment reg base &optional (index 0))
  (:declare (type tn reg base)
            (type (or (signed-byte 16) fixup) index))
  (:dependencies (reads base) (reads :memory) (writes reg))
  (:delay 1)
  (:emitter
   (emit-fp-load/store-inst segment #b110001 reg 1 base index)))

(define-instruction swc1 (segment reg base &optional (index 0))
  (:declare (type tn reg base)
            (type (or (signed-byte 16) fixup) index))
  (:printer immediate ((op #b111001) (rt nil :type 'fp-reg)) load-store-printer)
  (:dependencies (reads base) (reads reg) (writes :memory))
  (:delay 0)
  (:emitter
   (emit-fp-load/store-inst segment #b111001 reg 0 base index)))

(define-instruction swc1-odd (segment reg base &optional (index 0))
  (:declare (type tn reg base)
            (type (or (signed-byte 16) fixup) index))
  (:dependencies (reads base) (reads reg) (writes :memory))
  (:delay 0)
  (:emitter
   (emit-fp-load/store-inst segment #b111001 reg 1 base index)))