insts.lisp

开源跨平台Lisp编译器

    (unless (and (typep startbit '(unsigned-byte 32))
                 (typep endbit '(unsigned-byte 32))
                 (>= endbit startbit))
      (error "Bad bits."))
    ``(byte ,(1+ ,(- endbit startbit)) ,(- 31 ,endbit)))

  (defparameter *ppc-field-specs-alist*
    `((aa :field ,(ppc-byte 30))
      (ba :field ,(ppc-byte 11 15) :type 'bi-field)
      (bb :field ,(ppc-byte 16 20) :type 'bi-field)
      (bd :field ,(ppc-byte 16 29) :type 'relative-label)
      (bf :field ,(ppc-byte 6 8) :type 'crf)
      (bfa :field ,(ppc-byte 11 13) :type 'crf)
      (bi :field ,(ppc-byte 11 15) :type 'bi-field)
      (bo :field ,(ppc-byte 6 10) :type 'bo-field)
      (bt :field ,(ppc-byte 6 10) :type 'bi-field)
      (d :field ,(ppc-byte 16 31) :sign-extend t)
      (flm :field ,(ppc-byte 7 14) :sign-extend nil)
      (fra :field ,(ppc-byte 11 15) :type 'fp-reg)
      (frb :field ,(ppc-byte 16 20) :type 'fp-reg)
      (frc :field ,(ppc-byte 21 25) :type 'fp-reg)
      (frs :field ,(ppc-byte 6 10) :type 'fp-reg)
      (frt :field ,(ppc-byte 6 10) :type 'fp-reg)
      (fxm :field ,(ppc-byte 12 19) :sign-extend nil)
      (l :field ,(ppc-byte 10) :sign-extend nil)
      (li :field ,(ppc-byte 6 29) :sign-extend t :type 'relative-label)
      (li-abs :field ,(ppc-byte 6 29) :sign-extend t :printer jump-printer)
      (lk :field ,(ppc-byte 31))
      (mb :field ,(ppc-byte 21 25) :sign-extend nil)
      (me :field ,(ppc-byte 26 30) :sign-extend nil)
      (nb :field ,(ppc-byte 16 20) :sign-extend nil)
      (oe :field ,(ppc-byte 21))
      (ra :field ,(ppc-byte 11 15) :type 'reg)
      (rb :field ,(ppc-byte 16 20) :type 'reg)
      (rc :field ,(ppc-byte 31))
      (rs :field ,(ppc-byte 6 10) :type 'reg)
      (rt :field ,(ppc-byte 6 10) :type 'reg)
      (sh :field ,(ppc-byte 16 20) :sign-extend nil)
      (si :field ,(ppc-byte 16 31) :sign-extend t)
      (spr :field ,(ppc-byte 11 20) :type 'spr)
      (to :field ,(ppc-byte 6 10) :type 'to-field)
      (u :field ,(ppc-byte 16 19) :sign-extend nil)
      (ui :field ,(ppc-byte 16 31) :sign-extend nil)
      (xo21-30 :field ,(ppc-byte 21 30) :sign-extend nil)
      (xo22-30 :field ,(ppc-byte 22 30) :sign-extend nil)
      (xo26-30 :field ,(ppc-byte 26 30) :sign-extend nil)))



(sb!disassem:define-instruction-format (instr 32)
  (op :field (byte 6 26))
  (other :field (byte 26 0)))

(sb!disassem:define-instruction-format (xinstr 32 :default-printer '(:name :tab data))
  (op-to-a :field (byte 16 16))
  (data :field (byte 16 0)))

(sb!disassem:define-instruction-format (sc 32 :default-printer '(:name :tab rest))
  (op :field (byte 6 26))
  (rest :field (byte 26 0) :value 2))



(macrolet ((def-ppc-iformat ((name &optional default-printer) &rest specs)
               (flet ((specname-field (specname)
                        (or (assoc specname *ppc-field-specs-alist*)
                            (error "Unknown ppc instruction field spec ~s" specname))))
                 (labels ((spec-field (spec)
                            (if (atom spec)
                                (specname-field spec)
                                (cons (car spec)
                                      (cdr (specname-field (cadr spec)))))))
                   (collect ((field (list '(op :field (byte 6 26)))))
                            (dolist (spec specs)
                              (field (spec-field spec)))
                            `(sb!disassem:define-instruction-format (,name 32 ,@(if default-printer `(:default-printer ,default-printer)))
                              ,@(field)))))))

(def-ppc-iformat (i '(:name :tab li))
  li aa lk)

(def-ppc-iformat (i-abs '(:name :tab li-abs))
  li-abs aa lk)

(def-ppc-iformat (b '(:name :tab bo "," bi "," bd))
  bo bi bd aa lk)

(def-ppc-iformat (d '(:name :tab rt "," d "(" ra ")"))
  rt ra d)

(def-ppc-iformat (d-si '(:name :tab rt "," ra "," si ))
  rt ra si)

(def-ppc-iformat (d-rs '(:name :tab rs "," d "(" ra ")"))
  rs ra d)

(def-ppc-iformat (d-rs-ui '(:name :tab ra "," rs "," ui))
  rs ra ui)

(def-ppc-iformat (d-crf-si)
  bf l ra si)

(def-ppc-iformat (d-crf-ui)
  bf l ra ui)

(def-ppc-iformat (d-to '(:name :tab to "," ra "," si))
  to ra rb si)

(def-ppc-iformat (d-frt '(:name :tab frt "," d "(" ra ")"))
  frt ra d)

(def-ppc-iformat (d-frs '(:name :tab frs "," d "(" ra ")"))
  frs ra d)



;;; There are around ... oh, 28 or so ... variants on the "X" format.
;;;  Some of them are only used by one instruction; some are used by dozens.
;;;  Some aren't used by instructions that we generate ...

(def-ppc-iformat (x '(:name :tab rt "," ra "," rb))
  rt ra rb (xo xo21-30))

(def-ppc-iformat (x-1 '(:name :tab rt "," ra "," nb))
  rt ra nb (xo xo21-30))

(def-ppc-iformat (x-4 '(:name :tab rt))
  rt (xo xo21-30))

(def-ppc-iformat (x-5 '(:name :tab ra "," rs "," rb))
  rs ra rb (xo xo21-30) rc)

(def-ppc-iformat (x-7 '(:name :tab ra "," rs "," rb))
  rs ra rb (xo xo21-30))

(def-ppc-iformat (x-8 '(:name :tab ra "," rs "," nb))
  rs ra nb (xo xo21-30))

(def-ppc-iformat (x-9 '(:name :tab ra "," rs "," sh))
  rs ra sh (xo xo21-30) rc)

(def-ppc-iformat (x-10 '(:name :tab ra "," rs))
  rs ra (xo xo21-30) rc)

(def-ppc-iformat (x-14 '(:name :tab bf "," l "," ra "," rb))
  bf l ra rb (xo xo21-30))

(def-ppc-iformat (x-15 '(:name :tab bf "," l "," fra "," frb))
  bf l fra frb (xo xo21-30))

(def-ppc-iformat (x-18 '(:name :tab bf))
  bf (xo xo21-30))

(def-ppc-iformat (x-19 '(:name :tab to "," ra "," rb))
  to ra rb (xo xo21-30))

(def-ppc-iformat (x-20 '(:name :tab frt "," ra "," rb))
  frt ra rb (xo xo21-30))

(def-ppc-iformat (x-21 '(:name :tab frt "," rb))
  frt rb (xo xo21-30) rc)

(def-ppc-iformat (x-22 '(:name :tab frt))
  frt (xo xo21-30) rc)

(def-ppc-iformat (x-23 '(:name :tab ra "," frs "," rb))
  frs ra rb (xo xo21-30))

(def-ppc-iformat (x-24 '(:name :tab bt))
  bt (xo xo21-30) rc)

(def-ppc-iformat (x-25 '(:name :tab ra "," rb))
  ra rb (xo xo21-30))

(def-ppc-iformat (x-26 '(:name :tab rb))
  rb (xo xo21-30))

(def-ppc-iformat (x-27 '(:name))
  (xo xo21-30))


;;;;

(def-ppc-iformat (xl '(:name :tab bt "," ba "," bb))
  bt ba bb (xo xo21-30))

(def-ppc-iformat (xl-bo-bi '(:name :tab bo "," bi))
  bo bi (xo xo21-30) lk)

(def-ppc-iformat (xl-cr '(:name :tab bf "," bfa))
  bf bfa (xo xo21-30))

(def-ppc-iformat (xl-xo '(:name))
  (xo xo21-30))


;;;;

(def-ppc-iformat (xfx)
  rt spr (xo xo21-30))

(def-ppc-iformat (xfx-fxm '(:name :tab fxm "," rs))
  rs fxm (xo xo21-30))

(def-ppc-iformat (xfl '(:name :tab flm "," frb))
  flm frb (xo xo21-30) rc)


;;;

(def-ppc-iformat (xo '(:name :tab rt "," ra "," rb))
  rt ra rb oe (xo xo22-30) rc)

(def-ppc-iformat (xo-oe '(:name :tab rt "," ra "," rb))
  rt ra rb (xo xo22-30) rc)

(def-ppc-iformat (xo-a '(:name :tab rt "," ra))
  rt ra oe (xo xo22-30) rc)


;;;

(def-ppc-iformat (a '(:name :tab frt "," fra "," frb "," frc))
  frt fra frb frc (xo xo26-30) rc)

(def-ppc-iformat (a-tab '(:name :tab frt "," fra "," frb))
  frt fra frb (xo xo26-30) rc)

(def-ppc-iformat (a-tac '(:name :tab frt "," fra "," frc))
  frt fra frc (xo xo26-30) rc)

(def-ppc-iformat (a-tbc '(:name :tab frt "," frb "," frc))
  frt frb frc (xo xo26-30) rc)


(def-ppc-iformat (m '(:name :tab ra "," rs "," rb "," mb "," me))
  rs ra rb mb me rc)

(def-ppc-iformat (m-sh '(:name :tab ra "," rs "," sh "," mb "," me))
  rs ra sh mb me rc)))




;;;; Primitive emitters.


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

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

(define-bitfield-emitter emit-i-form-inst 32
  (byte 6 26) (byte 24 2) (byte 1 1) (byte 1 0))

(define-bitfield-emitter emit-b-form-inst 32
  (byte 6 26) (byte 5 21) (byte 5 16) (byte 14 2) (byte 1 1) (byte 1 0))

(define-bitfield-emitter emit-sc-form-inst 32
  (byte 6 26) (byte 26 0))

(define-bitfield-emitter emit-d-form-inst 32
  (byte 6 26) (byte 5 21) (byte 5 16) (byte 16 0))

; Also used for XL-form.  What's the difference ?
(define-bitfield-emitter emit-x-form-inst 32
  (byte 6 26) (byte 5 21) (byte 5 16) (byte 5 11) (byte 10 1) (byte 1 0))

(define-bitfield-emitter emit-xfx-form-inst 32
  (byte 6 26) (byte 5 21) (byte 10 11) (byte 10 1) (byte 1 0))

(define-bitfield-emitter emit-xfl-form-inst 32
  (byte 6 26) (byte 10  16) (byte 5 11) (byte 10 1) (byte 1 0))

; XS is 64-bit only
(define-bitfield-emitter emit-xo-form-inst 32
  (byte 6 26) (byte 5 21) (byte 5 16) (byte 5 11) (byte 1 10) (byte 9 1) (byte 1 0))

(define-bitfield-emitter emit-a-form-inst 32
  (byte 6 26) (byte 5 21) (byte 5 16) (byte 5 11) (byte 5 6) (byte 5 1) (byte 1 0))




(defun unimp-control (chunk inst stream dstate)
  (declare (ignore inst))
  (flet ((nt (x) (if stream (sb!disassem:note x dstate))))
    (case (xinstr-data 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))
      (#.object-not-list-trap
       (nt "Object not list trap"))
      (#.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"))
      (#.object-not-instance-trap
       (nt "Object not instance trap")))))

(eval-when (:compile-toplevel :execute)

(defun classify-dependencies (deplist)
  (collect ((reads) (writes))
    (dolist (dep deplist)
      (ecase (car dep)
        (reads (reads dep))
        (writes (writes dep))))
    (values (reads) (writes)))))

(macrolet ((define-xo-instruction
               (name op xo oe-p rc-p always-reads-xer always-writes-xer cost)
               `(define-instruction ,name (segment rt ra rb)
                 (:printer xo ((op ,op ) (xo ,xo) (oe ,(if oe-p 1 0)) (rc ,(if rc-p 1 0))))
                 (:dependencies (reads ra) (reads rb) ,@(if always-reads-xer '((reads :xer)))
                  (writes rt) ,@(if rc-p '((writes :ccr))) ,@(if (or oe-p always-writes-xer) '((writes :xer))) )
                 (:cost ,cost)
                 (:delay ,cost)
                 (:emitter
                  (emit-xo-form-inst segment ,op
                   (reg-tn-encoding rt)
                   (reg-tn-encoding ra)
                   (reg-tn-encoding rb)
                   ,(if oe-p 1 0)
                   ,xo
                   ,(if rc-p 1 0)))))
           (define-xo-oe-instruction
               (name op xo rc-p always-reads-xer always-writes-xer cost)