insts.lisp

开源跨平台Lisp编译器

;;;; the instruction set definition for HPPA

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

(eval-when (:compile-toplevel :load-toplevel :execute)
  (setf sb!assem:*assem-scheduler-p* nil))

;;;; Utility functions.

(defun reg-tn-encoding (tn)
  (declare (type tn tn))
  (sc-case tn
    (null null-offset)
    (zero zero-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 (values 0 nil))
    (single-reg (values (tn-offset tn) nil))
    (fp-double-zero (values 0 t))
    (double-reg (values (tn-offset tn) t))))

(defconstant-eqx compare-conditions
  '(:never := :< :<= :<< :<<= :sv :od :tr :<> :>= :> :>>= :>> :nsv :ev)
  #'equalp)

(deftype compare-condition ()
  `(member nil ,@compare-conditions))

(defun compare-condition (cond)
  (declare (type compare-condition cond))
  (if cond
      (let ((result (or (position cond compare-conditions :test #'eq)
                        (error "Bogus Compare/Subtract condition: ~S" cond))))
        (values (ldb (byte 3 0) result)
                (logbitp 3 result)))
      (values 0 nil)))

(defconstant-eqx add-conditions
  '(:never := :< :<= :nuv :znv :sv :od :tr :<> :>= :> :uv :vnz :nsv :ev)
  #'equalp)

(deftype add-condition ()
  `(member nil ,@add-conditions))

(defun add-condition (cond)
    (declare (type add-condition cond))
  (if cond
      (let ((result (or (position cond add-conditions :test #'eq)
                        (error "Bogus Add condition: ~S" cond))))
        (values (ldb (byte 3 0) result)
                (logbitp 3 result)))
      (values 0 nil)))

(defconstant-eqx logical-conditions
  '(:never := :< :<= nil nil nil :od :tr :<> :>= :> nil nil nil :ev)
  #'equalp)

(deftype logical-condition ()
  `(member nil ,@(remove nil logical-conditions)))

(defun logical-condition (cond)
    (declare (type logical-condition cond))
  (if cond
      (let ((result (or (position cond logical-conditions :test #'eq)
                        (error "Bogus Logical condition: ~S" cond))))
        (values (ldb (byte 3 0) result)
                (logbitp 3 result)))
      (values 0 nil)))

(defconstant-eqx unit-conditions
  '(:never nil :sbz :shz :sdc :sbc :shc :tr nil :nbz :nhz :ndc :nbc :nhc)
  #'equalp)

(deftype unit-condition ()
  `(member nil ,@(remove nil unit-conditions)))

(defun unit-condition (cond)
  (declare (type unit-condition cond))
  (if cond
      (let ((result (or (position cond unit-conditions :test #'eq)
                        (error "Bogus Unit condition: ~S" cond))))
        (values (ldb (byte 3 0) result)
                (logbitp 3 result)))
      (values 0 nil)))

(defconstant-eqx extract/deposit-conditions
  '(:never := :< :od :tr :<> :>= :ev)
  #'equalp)

(deftype extract/deposit-condition ()
  `(member nil ,@extract/deposit-conditions))

(defun extract/deposit-condition (cond)
  (declare (type extract/deposit-condition cond))
  (if cond
      (or (position cond extract/deposit-conditions :test #'eq)
          (error "Bogus Extract/Deposit condition: ~S" cond))
      0))


(defun space-encoding (space)
  (declare (type (unsigned-byte 3) space))
  (dpb (ldb (byte 2 0) space)
       (byte 2 1)
       (ldb (byte 1 2) space)))


;;;; Initial disassembler setup.

(setf sb!disassem:*disassem-inst-alignment-bytes* 4)

(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 "$F~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 fp-fmt-0c
  :printer #'(lambda (value stream dstate)
               (declare (ignore dstate) (stream stream) (fixnum value))
               (ecase value
                 (0 (format stream "~A" '\,SGL))
                 (1 (format stream "~A" '\,DBL))
                 (3 (format stream "~A" '\,QUAD)))))

(defun low-sign-extend (x n)
  (let ((normal (dpb x (byte 1 (1- n)) (ldb (byte (1- n) 1) x))))
    (if (logbitp 0 x)
        (logior (ash -1 (1- n)) normal)
        normal)))

(defun sign-extend (x n)
  (if (logbitp (1- n) x)
      (logior (ash -1 (1- n)) x)
      x))

(defun assemble-bits (x list)
  (let ((result 0)
        (offset 0))
    (dolist (e (reverse list))
      (setf result (logior result (ash (ldb e x) offset)))
      (incf offset (byte-size e)))
    result))

(defmacro define-imx-decode (name bits)
  `(sb!disassem:define-arg-type ,name
     :printer #'(lambda (value stream dstate)
                  (declare (ignore dstate) (stream stream) (fixnum value))
                  (format stream "~S" (low-sign-extend value ,bits)))))

(define-imx-decode im5 5)
(define-imx-decode im11 11)
(define-imx-decode im14 14)

(sb!disassem:define-arg-type im3
  :printer #'(lambda (value stream dstate)
               (declare (ignore dstate) (stream stream) (fixnum value))
               (format stream "~S" (assemble-bits value `(,(byte 1 0)
                                                          ,(byte 2 1))))))

(sb!disassem:define-arg-type im21
  :printer #'(lambda (value stream dstate)
               (declare (ignore dstate) (stream stream) (fixnum value))
               (format stream "~S"
                       (assemble-bits value `(,(byte 1 0) ,(byte 11 1)
                                              ,(byte 2 14) ,(byte 5 16)
                                              ,(byte 2 12))))))

(sb!disassem:define-arg-type cp
  :printer #'(lambda (value stream dstate)
               (declare (ignore dstate) (stream stream) (fixnum value))
               (format stream "~S" (- 31 value))))

(sb!disassem:define-arg-type clen
  :printer #'(lambda (value stream dstate)
               (declare (ignore dstate) (stream stream) (fixnum value))
               (format stream "~S" (- 32 value))))

(sb!disassem:define-arg-type compare-condition
  :printer #("" \,= \,< \,<= \,<< \,<<= \,SV \,OD \,TR \,<> \,>=
             \,> \,>>= \,>> \,NSV \,EV))

(sb!disassem:define-arg-type compare-condition-false
  :printer #(\,TR \,<> \,>= \,> \,>>= \,>> \,NSV \,EV
             "" \,= \,< \,<= \,<< \,<<= \,SV \,OD))

(sb!disassem:define-arg-type add-condition
  :printer #("" \,= \,< \,<= \,NUV \,ZNV \,SV \,OD \,TR \,<> \,>= \,> \,UV
             \,VNZ \,NSV \,EV))

(sb!disassem:define-arg-type add-condition-false
  :printer #(\,TR \,<> \,>= \,> \,UV \,VNZ \,NSV \,EV
             "" \,= \,< \,<= \,NUV \,ZNV \,SV \,OD))

(sb!disassem:define-arg-type logical-condition
  :printer #("" \,= \,< \,<= "" "" "" \,OD \,TR \,<> \,>= \,> "" "" "" \,EV))

(sb!disassem:define-arg-type unit-condition
  :printer #("" "" \,SBZ \,SHZ \,SDC \,SBC \,SHC \,TR "" \,NBZ \,NHZ \,NDC
             \,NBC \,NHC))

(sb!disassem:define-arg-type extract/deposit-condition
  :printer #("" \,= \,< \,OD \,TR \,<> \,>= \,EV))

(sb!disassem:define-arg-type extract/deposit-condition-false
  :printer #(\,TR \,<> \,>= \,EV "" \,= \,< \,OD))

(sb!disassem:define-arg-type nullify
  :printer #("" \,N))

(sb!disassem:define-arg-type fcmp-cond
  :printer #(\FALSE? \FALSE \? \!<=> \= \=T \?= \!<> \!?>= \< \?<
                     \!>= \!?> \<= \?<= \!> \!?<= \> \?>\ \!<= \!?< \>=
                     \?>= \!< \!?= \<> \!= \!=T \!? \<=> \TRUE? \TRUE))

(sb!disassem:define-arg-type integer
  :printer #'(lambda (value stream dstate)
               (declare (ignore dstate) (stream stream) (fixnum value))
               (format stream "~S" value)))

(sb!disassem:define-arg-type space
  :printer #("" |1,| |2,| |3,|))


;;;; Define-instruction-formats for disassembler.

(sb!disassem:define-instruction-format
    (load/store 32)
  (op   :field (byte 6 26))
  (b    :field (byte 5 21) :type 'reg)
  (t/r  :field (byte 5 16) :type 'reg)
  (s    :field (byte 2 14) :type 'space)
  (im14 :field (byte 14 0) :type 'im14))

(defconstant-eqx cmplt-index-print '((:cond ((u :constant 1) '\,S))
                                 (:cond ((m :constant 1) '\,M)))
  #'equalp)

(defconstant-eqx cmplt-disp-print '((:cond ((m :constant 1)
                                  (:cond ((s :constant 0) '\,MA)
                                         (t '\,MB)))))
  #'equalp)

(defconstant-eqx cmplt-store-print '((:cond ((s :constant 0) '\,B)
                                         (t '\,E))
                                  (:cond ((m :constant 1) '\,M)))
  #'equalp)

(sb!disassem:define-instruction-format
    (extended-load/store 32)
  (op1     :field (byte 6 26) :value 3)
  (b       :field (byte 5 21) :type 'reg)
  (x/im5/r :field (byte 5 16) :type 'reg)
  (s       :field (byte 2 14) :type 'space)
  (u       :field (byte 1 13))
  (op2     :field (byte 3 10))
  (ext4/c  :field (byte 4 6))
  (m       :field (byte 1 5))
  (t/im5   :field (byte 5 0) :type 'reg))

(sb!disassem:define-instruction-format
    (ldil 32 :default-printer '(:name :tab im21 "," t))
  (op    :field (byte 6 26))
  (t   :field (byte 5 21) :type 'reg)
  (im21 :field (byte 21 0) :type 'im21))

(sb!disassem:define-instruction-format
    (branch17 32)
  (op1 :field (byte 6 26))
  (t   :field (byte 5 21) :type 'reg)
  (w   :fields `(,(byte 5 16) ,(byte 11 2) ,(byte 1 0))
       :use-label
       #'(lambda (value dstate)
           (declare (type sb!disassem:disassem-state dstate) (list value))
           (let ((x (logior (ash (first value) 12) (ash (second value) 1)
                            (third value))))
             (+ (ash (sign-extend
                      (assemble-bits x `(,(byte 1 0) ,(byte 5 12) ,(byte 1 1)
                                         ,(byte 10 2))) 17) 2)
                (sb!disassem:dstate-cur-addr dstate) 8))))
  (op2 :field (byte 3 13))
  (n   :field (byte 1 1) :type 'nullify))

(sb!disassem:define-instruction-format
    (branch12 32)
  (op1 :field (byte 6 26))
  (r2  :field (byte 5 21) :type 'reg)
  (r1  :field (byte 5 16) :type 'reg)
  (w   :fields `(,(byte 11 2) ,(byte 1 0))
       :use-label
       #'(lambda (value dstate)
           (declare (type sb!disassem:disassem-state dstate) (list value))
           (let ((x (logior (ash (first value) 1) (second value))))
             (+ (ash (sign-extend
                      (assemble-bits x `(,(byte 1 0) ,(byte 1 1) ,(byte 10 2)))
                      12) 2)
                (sb!disassem:dstate-cur-addr dstate) 8))))
  (c   :field (byte 3 13))
  (n   :field (byte 1 1) :type 'nullify))

(sb!disassem:define-instruction-format
    (branch 32)
  (op1 :field (byte 6 26))
  (t   :field (byte 5 21) :type 'reg)
  (x   :field (byte 5 16) :type 'reg)
  (op2 :field (byte 3 13))
  (x1  :field (byte 11 2))
  (n   :field (byte 1 1) :type 'nullify)
  (x2  :field (byte 1 0)))

(sb!disassem:define-instruction-format
     (r3-inst 32 :default-printer '(:name c :tab r1 "," r2 "," t))
  (r3 :field (byte 6 26) :value 2)
  (r2 :field (byte 5 21) :type 'reg)
  (r1 :field (byte 5 16) :type 'reg)
  (c  :field (byte 3 13))
  (f  :field (byte 1 12))
  (op :field (byte 7 5))
  (t  :field (byte 5 0) :type 'reg))

(sb!disassem:define-instruction-format
    (imm-inst 32 :default-printer '(:name c :tab im11 "," r "," t))
  (op   :field (byte 6 26))
  (r    :field (byte 5 21) :type 'reg)
  (t    :field (byte 5 16) :type 'reg)
  (c    :field (byte 3 13))
  (f    :field (byte 1 12))
  (o    :field (byte 1 11))
  (im11 :field (byte 11 0) :type 'im11))

(sb!disassem:define-instruction-format
    (extract/deposit-inst 32)
  (op1    :field (byte 6 26))
  (r2     :field (byte 5 21) :type 'reg)
  (r1     :field (byte 5 16) :type 'reg)
  (c      :field (byte 3 13) :type 'extract/deposit-condition)