home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / rt / insts.lisp < prev    next >
Encoding:
Text File  |  1992-01-25  |  39.1 KB  |  1,438 lines
  1. ;;; -*- Package: RT -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: insts.lisp,v 1.13 92/01/22 18:09:31 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; Description of the IBM RT instruction set.
  15. ;;;
  16. ;;; Written by William Lott and Bill Chiles.
  17. ;;;
  18.  
  19. (in-package "RT")
  20.  
  21. (use-package "ASSEM")
  22. (use-package "EXT")
  23.  
  24.  
  25. ;;;; Resources:
  26.  
  27. (disassem:set-disassem-params :instruction-alignment 16)
  28. (define-resources memory float-status mq cc)
  29.  
  30.  
  31. ;;;; Formats.
  32.  
  33. (define-format (j1 16 :use (cc))
  34.   (op (byte 4 12))
  35.   (sub-op (byte 1 11))
  36.   (n (byte 3 8))
  37.   (j1 (byte 8 0)))
  38.  
  39. (define-format (x 16 :clobber (cc))
  40.   (op (byte 4 12))
  41.   (r1 (byte 4 8) :write t)
  42.   (r2 (byte 4 4) :read t)
  43.   (r3 (byte 4 0) :read t))
  44.  
  45.  
  46. (define-format (r 16 :clobber (cc))
  47.   (op (byte 8 8))
  48.   (r2 (byte 4 4) :read t :write t)
  49.   (r3 (byte 4 0) :read t))
  50.  
  51. (define-format (r-immed 16 :clobber (cc))
  52.   (op (byte 8 8))
  53.   (r2 (byte 4 4) :read t :write t)
  54.   (r3 (byte 4 0)))
  55.  
  56.  
  57. (define-format (bi 32 :use (cc))
  58.   (op (byte 8 24))
  59.   (r2 (byte 4 20))
  60.   (bi (byte 20 0)))
  61.  
  62. (define-format (ba 32 :attributes (assembly-call))
  63.   (op (byte 8 24))
  64.   (ba (byte 24 0)))
  65.  
  66. (define-format (d 32 :clobber (cc))
  67.   (op (byte 8 24))
  68.   (r2 (byte 4 20) :write t)
  69.   (r3 (byte 4 16) :read t)
  70.   (i (byte 16 0)))
  71.  
  72. (define-format (d-short 16 :clobber (cc))
  73.   (op (byte 4 12))
  74.   (i (byte 4 8))
  75.   (r2 (byte 4 4) :write t)
  76.   (r3 (byte 4 0) :read t))
  77.  
  78.  
  79. ;;;; Special argument types and fixups.
  80.  
  81. (define-argument-type register
  82.   :type '(satisfies (lambda (object)
  83.               (and (tn-p object)
  84.                (or (eq (sc-name (tn-sc object)) 'null)
  85.                    (eq (sb-name (sc-sb (tn-sc object)))
  86.                    'registers)))))
  87.   :function (lambda (tn)
  88.           (case (sc-name (tn-sc tn))
  89.         (null null-offset)
  90.         (t (tn-offset tn)))))
  91.  
  92. (defun address-register-p (object)
  93.   (and (tn-p object)
  94.        (not (zerop (tn-offset object)))
  95.        (eq (sb-name (sc-sb (tn-sc object))) 'registers)))
  96.  
  97. (define-argument-type address-register
  98.   :type '(satisfies address-register-p)
  99.   :function tn-offset)
  100.  
  101.  
  102. ;;; LABEL-OFFSET -- Internal.
  103. ;;;
  104. ;;; This uses assem:*current-position* and the label's position to compute
  105. ;;; the bits that an instructions immediate field wants.
  106. ;;;
  107. (defun label-offset (label)
  108.   (ash (- (label-position label) *current-position*) -1))
  109.  
  110. (define-argument-type relative-label
  111.   :type 'label
  112.   :function label-offset)
  113.  
  114.  
  115. (defun jump-condition-value (cond)
  116.   (ecase cond
  117.     (:pz #b000)
  118.     (:lt #b001)
  119.     (:eq #b010)
  120.     (:gt #b011)
  121.     (:c0 #b100)
  122.     (:ov #b110)
  123.     (:tb #b111)))
  124.  
  125. (define-argument-type jump-condition
  126.   :type '(member :pz :lt :eq :gt :c0 :ov :tb)
  127.   :function jump-condition-value)
  128.  
  129. (defun branch-condition-value (cond)
  130.   (ecase cond
  131.     (:pz #b1000)
  132.     (:lt #b1001)
  133.     (:eq #b1010)
  134.     (:gt #b1011)
  135.     (:c0 #b1100)
  136.     (:ov #b1110)
  137.     (:tb #b1111)))
  138.  
  139. (define-argument-type branch-condition
  140.   :type '(member :pz :lt :eq :gt :c0 :ov :tb)
  141.   :function branch-condition-value)
  142.  
  143.  
  144. (define-fixup-type :ba) ;branch-absolute.
  145. (define-fixup-type :cau)
  146. (define-fixup-type :cal)
  147.  
  148.  
  149.  
  150. ;;;; Loading and storing.
  151.  
  152. ;;; load-character.
  153. ;;;
  154. (define-instruction (lc)
  155.   (d-short (op :constant 4)
  156.        (r2 :argument register)
  157.        (r3 :argument address-register)
  158.        (i :argument (unsigned-byte 4)))
  159.   (d-short (op :constant 4)
  160.        (r2 :argument register)
  161.        (r3 :argument address-register)
  162.        (i :constant 0))
  163.   (d (op :constant #xCE)
  164.      (r2 :argument register)
  165.      (r3 :argument address-register)
  166.      (i :argument (signed-byte 16))))
  167.  
  168. ;;; store-character.
  169. ;;;
  170. (define-instruction (stc)
  171.   (d-short (op :constant 1)
  172.        (r2 :argument register :read t :write nil)
  173.        (r3 :argument address-register)
  174.        (i :argument (unsigned-byte 4)))
  175.   (d-short (op :constant 1)
  176.        (r2 :argument register :read t :write nil)
  177.        (r3 :argument address-register)
  178.        (i :constant 0))
  179.   (d (op :constant #xDE)
  180.      (r2 :argument register :read t :write nil)
  181.      (r3 :argument address-register)
  182.      (i :argument (signed-byte 16))))
  183.  
  184. ;;; load-half.
  185. ;;;
  186. (define-instruction (lh)
  187.   (d (op :constant #xDA)
  188.      (r2 :argument register)
  189.      (r3 :argument address-register)
  190.      (i :argument (signed-byte 16)))
  191.   (r (op :constant #xEB)
  192.      (r2 :argument register :read nil)
  193.      (r3 :argument register)))
  194.  
  195. ;;; load-half-algebraic.
  196. ;;;
  197. (define-instruction (lha)
  198.   (d (op :constant #xCA)
  199.      (r2 :argument register)
  200.      (r3 :argument address-register)
  201.      (i :argument (signed-byte 16)))
  202.   (d-short (op :constant 5)
  203.        (r2 :argument register)
  204.        (r3 :argument address-register)
  205.        ;; We want the instruction to take byte indexes, but we plug the
  206.        ;; index into the instruction as a half-word index.
  207.        (i :argument (member 0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30)
  208.           :function (lambda (x) (ash x -1)))))
  209.  
  210. ;;; store-half.
  211. ;;;
  212. (define-instruction (sth)
  213.   (d-short (op :constant 2)
  214.        (r2 :argument register :read t :write nil)
  215.        (r3 :argument address-register)
  216.        ;; We want the instruction to take byte indexes, but we plug the
  217.        ;; index into the instruction as a half-word index.
  218.        (i :argument (member 0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30)
  219.           :function (lambda (x) (ash x -1))))
  220.   (d (op :constant #xDC)
  221.      (r2 :argument register :read t :write nil)
  222.      (r3 :argument address-register)
  223.      (i :argument (signed-byte 16))))
  224.  
  225. ;;; load-word.
  226. ;;;
  227. (define-instruction (l)
  228.   (d-short (op :constant 7)
  229.        (r2 :argument register)
  230.        (r3 :argument address-register)
  231.        ;; We want the instruction to take byte indexes, but we plug the
  232.        ;; index into the instruction as a word index.
  233.        (i :argument (member 0 4 8 12 16 20 24 28 32 36 40 44 48 52 56 60)
  234.           :function (lambda (x) (ash x -2))))
  235.   (d-short (op :constant 7)
  236.        (r2 :argument register)
  237.        (r3 :argument address-register)
  238.        (i :constant 0))
  239.   (d (op :constant #xCD)
  240.      (r2 :argument register)
  241.      (r3 :argument address-register)
  242.      (i :argument (signed-byte 16))))
  243.  
  244. ;;; store-word.
  245. ;;;
  246. (define-instruction (st)
  247.   (d-short (op :constant 3)
  248.        (r2 :argument register :read t :write nil)
  249.        (r3 :argument address-register)
  250.        ;; We want the instruction to take byte indexes, but we plug the
  251.        ;; index into the instruction as a word index.
  252.        (i :argument (member 0 4 8 12 16 20 24 28 32 36 40 44 48 52 56 60)
  253.           :function (lambda (x) (ash x -2))))
  254.   (d-short (op :constant 3)
  255.        (r2 :argument register :read t :write nil)
  256.        (r3 :argument address-register)
  257.        (i :constant 0))
  258.   (d (op :constant #xDD)
  259.      (r2 :argument register :read t :write nil)
  260.      (r3 :argument address-register)
  261.      (i :argument (signed-byte 16))))
  262.  
  263.  
  264. ;;;; Address computation.
  265.  
  266. ;;; compute-address-lower-half.
  267. ;;;
  268. ;;; The second format can be used for load-immediate (signed-byte 16).
  269. ;;;
  270. (define-instruction (cal)
  271.   (d (op :constant #xC8)
  272.      (r2 :argument register)
  273.      (r3 :argument address-register)
  274.      (i :argument (signed-byte 16)))
  275.   (d (op :constant #xC8)
  276.      (r2 :argument register)
  277.      (r3 :same-as r2)
  278.      (i :argument (signed-byte 16)))
  279.   (d (op :constant #xC8)
  280.      (r2 :argument register)
  281.      (r3 :argument (integer 0 0) :read nil)
  282.      (i :argument (signed-byte 16)))
  283.   (d (op :constant #xC8)
  284.      (r2 :argument register)
  285.      (r3 :argument address-register)
  286.      (i :argument cal-fixup)))
  287.  
  288. ;;; compute-address-lower-half-16bit.
  289. ;;;
  290. ;;; The second format can be used for load-immediate (unsigned-byte 16).
  291. ;;;
  292. (define-instruction (cal16)
  293.   (d (op :constant #xC2)
  294.      (r2 :argument register)
  295.      (r3 :argument address-register)
  296.      (i :argument (unsigned-byte 16)))
  297.   (d (op :constant #xC2)
  298.      (r2 :argument register)
  299.      (r3 :constant 0)
  300.      (i :argument (unsigned-byte 16))))
  301.  
  302. ;;; compute-address-upper-half.
  303. ;;;
  304. (define-instruction (cau)
  305.   (d (op :constant #xD8)
  306.      (r2 :argument register)
  307.      (r3 :argument address-register)
  308.      (i :argument (unsigned-byte 16)))
  309.   (d (op :constant #xD8)
  310.      (r2 :argument register)
  311.      (r3 :argument (integer 0 0) :read nil)
  312.      (i :argument (unsigned-byte 16)))
  313.   (d (op :constant #xD8)
  314.      (r2 :argument register)
  315.      (r3 :constant 0)
  316.      (i :argument (unsigned-byte 16)))
  317.   (d (op :constant #xD8)
  318.      (r2 :argument register)
  319.      (r3 :constant 0)
  320.      (i :argument cau-fixup)))
  321.  
  322. ;;; compute-address-short.
  323. ;;;
  324. ;;; Use the second flavor to copy registers.
  325. ;;;
  326. (define-instruction (cas)
  327.   (x (op :constant 6)
  328.      (r1 :argument register)
  329.      (r2 :argument register)
  330.      (r3 :argument address-register))
  331.   (x (op :constant 6)
  332.      (r1 :argument register)
  333.      (r2 :argument register)
  334.      (r3 :constant 0)))
  335.  
  336. ;;; increment.
  337. ;;;
  338. (define-instruction (inc)
  339.   (r-immed
  340.    (op :constant #x91)
  341.    (r2 :argument register)
  342.    (r3 :argument (unsigned-byte 4))))
  343.  
  344. ;;; decrement
  345. ;;;
  346. (define-instruction (dec)
  347.   (r-immed
  348.    (op :constant #x93)
  349.    (r2 :argument register)
  350.    (r3 :argument (unsigned-byte 4))))
  351.  
  352.  
  353. ;;; load-immediate-short.
  354. ;;;
  355. (define-instruction (lis)
  356.   (r-immed
  357.    (op :constant #xA4)
  358.    (r2 :argument register :read nil)
  359.    (r3 :argument (unsigned-byte 4))))
  360.  
  361.  
  362.  
  363. ;;;; Arithmetics.
  364.  
  365. (macrolet ((define-math-inst (name &key two-regs unary short-immediate
  366.                    immediate function (signed t)
  367.                    (use nil use-p) 
  368.                    (clobber nil clobber-p))
  369.          `(define-instruction (,name
  370.                    ,@(when use-p `(:use ,use))
  371.                    ,@(when clobber-p `(:clobber ,clobber)))
  372.         ,@(when two-regs
  373.             `((r (op :constant ,two-regs)
  374.              (r2 :argument register)
  375.              (r3 :argument register))
  376.               (r (op :constant ,two-regs)
  377.              (r2 :argument register)
  378.              (r3 :same-as r2))))
  379.         ,@(when unary
  380.             `((r (op :constant ,unary)
  381.              (r2 :argument register :read nil)
  382.              (r3 :argument register))
  383.               (r (op :constant ,unary)
  384.              (r2 :argument register :read nil)
  385.              (r3 :same-as r2))))
  386.         ,@(when short-immediate
  387.             `((r-immed
  388.                (op :constant ,short-immediate)
  389.                (r2 :argument register)
  390.                (r3 :argument (unsigned-byte 4)))))
  391.         ,@(when immediate
  392.             `((d (op :constant ,immediate)
  393.              (r2 :argument register)
  394.              (r3 :argument register)
  395.              (i :argument
  396.                 (,(if signed 'signed-byte 'unsigned-byte) 16)
  397.                 ,@(if function `(:function ,function))))
  398.               (d (op :constant ,immediate)
  399.              (r2 :argument register)
  400.              (r3 :same-as r2)
  401.              (i :argument
  402.                 (,(if signed 'signed-byte 'unsigned-byte) 16)
  403.                 ,@(if function `(:function ,function)))))))))
  404.  
  405.   (define-math-inst a :two-regs #xE1 :short-immediate #x90 :immediate #xC1)
  406.   (define-math-inst ae :two-regs #xF1 :immediate #xD1 :use (cc))
  407.   (define-math-inst abs :unary #xE0)
  408.   (define-math-inst neg :unary #xE4) ;Arithmetic negation (two's complement).
  409.   (define-math-inst s :two-regs #xE2 :short-immediate #x92
  410.     :immediate #xC1 :function -)
  411.   (define-math-inst sf :two-regs #xB2 :immediate #xD2)
  412.   (define-math-inst se :two-regs #xF2 :use (cc))
  413.   (define-math-inst d :two-regs #xB6 :use (cc mq) :clobber (cc mq))
  414.   (define-math-inst m :two-regs #xE6 :use (cc mq) :clobber (cc mq))
  415.   
  416.   (define-math-inst exts :unary #xB1)
  417.   
  418.   (define-math-inst clrbl :short-immediate #x99)
  419.   (define-math-inst clrbu :short-immediate #x98)
  420.   (define-math-inst setbl :short-immediate #x9B)
  421.   (define-math-inst setbu :short-immediate #x9A)
  422.   
  423.   (define-math-inst not :unary #xF4) ;Logical not.
  424.   (define-math-inst n :two-regs #xE5)
  425.   (define-math-inst nilz :immediate #xC5 :signed nil)
  426.   (define-math-inst nilo :immediate #xC6 :signed nil)
  427.   (define-math-inst niuz :immediate #xD5 :signed nil)
  428.   (define-math-inst niuo :immediate #xD6 :signed nil)
  429.   (define-math-inst o :two-regs #xE3)
  430.   (define-math-inst oil :immediate #xC4 :signed nil)
  431.   (define-math-inst oiu :immediate #xC3 :signed nil)
  432.   (define-math-inst x :two-regs #xE7)
  433.   (define-math-inst xil :immediate #xC7 :signed nil)
  434.   (define-math-inst xiu :immediate #xD7 :signed nil)
  435.  
  436.   (define-math-inst clz :two-regs #xF5)
  437.  
  438. ) ;macrolet
  439.  
  440.  
  441. ;;; compare.
  442. ;;; compare-immediate-short.
  443. ;;; compare-immediate.
  444. ;;;
  445. (define-instruction (c)
  446.   (r (op :constant #xB4)
  447.      (r2 :argument register :write nil)
  448.      (r3 :argument register))
  449.   (r-immed
  450.    (op :constant #x94)
  451.    (r2 :argument register :write nil)
  452.    (r3 :argument (unsigned-byte 4)))
  453.   (d (op :constant #xD4)
  454.      (r2 :constant 0)
  455.      (r3 :argument register)
  456.      (i :argument (signed-byte 16))))
  457.  
  458.  
  459. ;;; compare-logical.
  460. ;;; compare-logical-immediate.
  461. ;;;
  462. (define-instruction (cl)
  463.   (r (op :constant #xB3)
  464.      (r2 :argument register :write nil)
  465.      (r3 :argument register))
  466.   (d (op :constant #xD3)
  467.      (r2 :constant 0)
  468.      (r3 :argument register)
  469.      (i :argument (signed-byte 16))))
  470.  
  471.  
  472.  
  473. ;;;; Shifting.
  474.  
  475. (define-instruction (sr)
  476.   (r (op :constant #xB8)
  477.      (r2 :argument register)
  478.      (r3 :argument register))
  479.   (r-immed
  480.    (op :constant #xA8)
  481.    (r2 :argument register :write nil)
  482.    (r3 :argument (unsigned-byte 4)))
  483.   (r-immed
  484.    (op :constant #xA9)
  485.    (r2 :argument register :write nil)
  486.    (r3 :argument (integer 16 31)
  487.        :function (lambda (x) (- x 16)))))
  488.  
  489. (define-instruction (sl)
  490.   (r (op :constant #xBA)
  491.      (r2 :argument register)
  492.      (r3 :argument register))
  493.   (r-immed
  494.    (op :constant #xAA)
  495.    (r2 :argument register)
  496.    (r3 :argument (unsigned-byte 4)))
  497.   (r-immed
  498.    (op :constant #xAB)
  499.    (r2 :argument register)
  500.    (r3 :argument (integer 16 31)
  501.        :function (lambda (x) (- x 16)))))
  502.  
  503. (define-instruction (sar)
  504.   (r (op :constant #xB0)
  505.      (r2 :argument register)
  506.      (r3 :argument register))
  507.   (r-immed
  508.    (op :constant #xA0)
  509.    (r2 :argument register)
  510.    (r3 :argument (unsigned-byte 4)))
  511.   (r-immed
  512.    (op :constant #xA1)
  513.    (r2 :argument register)
  514.    (r3 :argument (integer 16 31)
  515.        :function (lambda (x) (- x 16)))))
  516.  
  517.  
  518. ;;;; Branch instructions.
  519.  
  520. ;;; There are some pseudo-instructions defined after this page that use these
  521. ;;; definitions.
  522. ;;;
  523.  
  524. (define-instruction (jb)
  525.   (j1 (op :constant 0)
  526.       (sub-op :constant 1)
  527.       (n :argument jump-condition)
  528.       (j1 :argument relative-label)))
  529.  
  530. (define-instruction (jnb)
  531.   (j1 (op :constant 0)
  532.       (sub-op :constant 0)
  533.       (n :argument jump-condition)
  534.       (j1 :argument relative-label)))
  535.  
  536. (macrolet ((define-branch-inst (name immediate-op register-op)
  537.          `(define-instruction (,name)
  538.         (bi (op :constant ,immediate-op)
  539.             (r2 :argument branch-condition)
  540.             (bi :argument relative-label))
  541.         (r (op :constant ,register-op)
  542.            (r2 :argument branch-condition :read nil :write nil)
  543.            (r3 :argument register)))))
  544.  
  545.   ;; branch-on-condition-bit-immediate.
  546.   ;; branch-on-condition-bit-register.
  547.   ;;
  548.   (define-branch-inst bb #x8E #xEE)
  549.   
  550.   ;; branch-on-condition-bit-immediate-with-execute.
  551.   ;; branch-on-condition-bit-register-with-execute.
  552.   ;;
  553.   (define-branch-inst bbx #x8F #xEF)
  554.  
  555.   ;; branch-on-not-condition-bit-immediate.
  556.   ;; branch-on-not-condition-bit-register.
  557.   ;;
  558.   (define-branch-inst bnb #x88 #xE8)
  559.  
  560.   ;; branch-on-not-condition-bit-immediate-with-execute.
  561.   ;; branch-on-not-condition-bit-register-with-execute.
  562.   ;;
  563.   (define-branch-inst bnbx #x89 #xE9)
  564.  
  565. ) ;MACROLET
  566.  
  567. (define-instruction (bala)
  568.   (ba (op :constant #x8A)
  569.       (ba :argument ba-fixup)))
  570.  
  571. (define-instruction (balax)
  572.   (ba (op :constant #x8B)
  573.       (ba :argument ba-fixup)))
  574.  
  575.  
  576.  
  577. ;;;; Pseudo-instructions
  578.  
  579. ;;; move.
  580. ;;;
  581. ;;; This body is the second format of compute-address-short.
  582. ;;;
  583. (define-instruction (move)
  584.   (x (op :constant 6)
  585.      (r1 :argument register)
  586.      (r2 :argument register)
  587.      (r3 :constant 0)))
  588.  
  589. ;;;
  590. ;;; A couple load-immediate pseudo-instructions.
  591. ;;;
  592.  
  593. ;;; load-immediate.
  594. ;;;
  595. ;;; This might affect the condition codes, but it allows for loading 32-bit
  596. ;;; quantities into R0.
  597. ;;;
  598. (define-pseudo-instruction li 64 (reg value)
  599.   (etypecase value
  600.     ((unsigned-byte 4)
  601.      (inst lis reg value))
  602.     ((signed-byte 16)
  603.      (inst cal reg 0 value))
  604.     ((unsigned-byte 16)
  605.      (inst cal16 reg value))
  606.     ((or (signed-byte 32) (unsigned-byte 32))
  607.      (inst cau reg (ldb (byte 16 16) value))
  608.      (let ((low (ldb (byte 16 0) value)))
  609.        (unless (zerop low)
  610.      (inst oil reg low))))))
  611.  
  612. ;;; compute-address-immediate.
  613. ;;;
  614. ;;; This basically exists to load 32-bit constants into address-registers, and
  615. ;;; it does not affect condition codes.  Since fixups are always addresses, we
  616. ;;; have the fixup branch here instead of in load-immediate.  We may use the
  617. ;;; other branches since it already exists.
  618. ;;;
  619. (define-pseudo-instruction cai 64 (reg value)
  620.   (etypecase value
  621.     ((unsigned-byte 4)
  622.      (inst lis reg value))
  623.     ((signed-byte 16)
  624.      (inst cal reg 0 value))
  625.     ((unsigned-byte 16)
  626.      (inst cal16 reg value))
  627.     ((or (signed-byte 32) (unsigned-byte 32))
  628.      (inst cau reg (ldb (byte 16 16) value))
  629.      (let ((low (ldb (byte 16 0) value)))
  630.        (unless (zerop low)
  631.      (inst cal16 reg reg low))))
  632.     (fixup
  633.      (inst cau reg value)
  634.      (inst cal reg reg value))))
  635.  
  636.  
  637. ;;; branch-unconditional.
  638. ;;;
  639. (define-pseudo-instruction b 32 (target)
  640.   (if (and (assem::label-p target)
  641.        (<= -128 (label-offset target) 127))
  642.       (inst jnb :pz target)
  643.       (inst bnb :pz target)))
  644.  
  645. ;;; branch-unconditional-with-execute.
  646. ;;;
  647. (define-pseudo-instruction bx 32 (target)
  648.   (inst bnbx :pz target))
  649.  
  650. ;;; branch-condition.
  651. ;;;
  652. (define-pseudo-instruction bc 32 (condition target)
  653.   (if (and (assem::label-p target)
  654.        (<= -128 (label-offset target) 127))
  655.       (inst jb condition target)
  656.       (inst bb condition target)))
  657.  
  658. ;;; branch-not-condition.
  659. ;;;
  660. (define-pseudo-instruction bnc 32 (condition target)
  661.   (if (and (assem::label-p target)
  662.        (<= -128 (label-offset target) 127))
  663.       (inst jnb condition target)
  664.       (inst bnb condition target)))
  665.  
  666. ;;; branch-condition-with-execute.
  667. ;;; branch-not-condition-with-execute.
  668. ;;;
  669. ;;; We define these, so VOP readers see a consistent naming scheme in branch
  670. ;;; instructions.
  671. ;;;
  672. (define-pseudo-instruction bcx 32 (condition target)
  673.   (inst bbx condition target))
  674. ;;;
  675. (define-pseudo-instruction bncx 32 (condition target)
  676.   (inst bnbx condition target))
  677.  
  678. ;;; no-op.
  679. ;;;
  680. ;;; This is compute-address-short, adding zero to R0 putting the result in R0.
  681. ;;;
  682. (define-instruction (no-op)
  683.   (x (op :constant 6)
  684.      (r1 :constant 0)
  685.      (r2 :constant 0)
  686.      (r3 :constant 0)))
  687.  
  688. (define-format (word-format 32)
  689.   (data (byte 32 0)))
  690. (define-instruction (word)
  691.   (word-format (data :argument (or (unsigned-byte 32) (signed-byte 32)))))
  692.  
  693. (define-format (short-format 16)
  694.   (data (byte 16 0)))
  695. (define-instruction (short)
  696.   (short-format (data :argument (or (unsigned-byte 16) (signed-byte 16)))))
  697.  
  698. (define-format (byte-format 8)
  699.   (data (byte 8 0)))
  700. (define-instruction (byte)
  701.   (byte-format (data :argument (or (unsigned-byte 8) (signed-byte 8)))))
  702.  
  703.  
  704.  
  705. ;;;; Breaking.
  706.  
  707. (define-instruction (tge)
  708.   (r (op :constant #xBD)
  709.      (r2 :argument register)
  710.      (r3 :argument register)))
  711.  
  712. (define-instruction (tlt)
  713.   (r (op :constant #xBE)
  714.      (r2 :argument register)
  715.      (r3 :argument register)))
  716.  
  717. ;;; break.
  718. ;;;
  719. ;;; This is trap-on-condition-immediate.  We use the immediate field to
  720. ;;; stick in a constant value indicating why we're breaking.
  721. ;;;
  722. (define-instruction (break)
  723.   (d (op :constant #xCC)
  724.      (r2 :constant #b0111)
  725.      (r3 :constant 0)
  726.      (i :argument (signed-byte 16))))
  727.  
  728.  
  729.  
  730. ;;;; System control.
  731.  
  732. ;;; move-to-multiplier-quotient-system-control-register
  733. ;;;
  734. (define-instruction (mtmqscr)
  735.   (r (op :constant #xB5)
  736.      (r2 :constant 10)
  737.      (r3 :argument register)))
  738.  
  739. ;;; move-from-multiplier-quotient-system-control-register
  740. ;;;
  741. (define-instruction (mfmqscr)
  742.   (r (op :constant #x96)
  743.      (r2 :constant 10)
  744.      (r3 :argument register :read nil :write t)))
  745.  
  746.  
  747.  
  748. ;;;; Function and LRA Headers emitters and calculation stuff.
  749.  
  750. (defun header-data (ignore)
  751.   (declare (ignore ignore))
  752.   (ash (+ *current-position* (component-header-length)) (- vm:word-shift)))
  753.  
  754. (define-format (header-object 32)
  755.   (type (byte 8 0))
  756.   (data (byte 24 8) :default 0 :function header-data))
  757.  
  758. (define-instruction (function-header-word)
  759.   (header-object (type :constant vm:function-header-type)))
  760.  
  761. (define-instruction (lra-header-word)
  762.   (header-object (type :constant vm:return-pc-header-type)))
  763.  
  764.  
  765. ;;; DEFINE-COMPUTE-INSTRUCTION -- Internal.
  766. ;;;
  767. ;;; This defines a pseudo-instruction, name, which requires the other specific
  768. ;;; instructions.  When the pseudo-instruction expands, it looks at the current
  769. ;;; value of the calculation to choose between two instruction sequences.
  770. ;;; Later, when the assembler emits the instructions, the :function's run to
  771. ;;; really compute the calculation's value.  This is guaranteed to be lesser in
  772. ;;; magnitude than the original test in the pseudo-instruction since all these
  773. ;;; calculation are relative to the component start, so we can only remove
  774. ;;; instructions in that range, not add them.
  775. ;;;
  776. (defmacro define-compute-instruction (name calculation)
  777.   (let ((cal (symbolicate name "-CAL"))
  778.     (cau (symbolicate name "-CAU")))
  779.     `(progn
  780.        ;; This is a special compute-address-lower that takes a label and
  781.        ;; asserts the type of the immediate value.
  782.        (defun ,name (label)
  783.      (let* ((whole ,calculation)
  784.         (low (logand whole #xffff))
  785.         (high (ash whole -16)))
  786.        (values (if (logbitp 15 low)
  787.                (1+ high)
  788.                high)
  789.            low)))
  790.        (define-instruction (,cal)
  791.      (d (op :constant #xC8)
  792.         (r2 :argument register)
  793.         (r3 :argument address-register)
  794.         (i :argument label
  795.            :function (lambda (label)
  796.                (multiple-value-bind (high low) (,name label)
  797.                  (declare (ignore high))
  798.                  low)))))
  799.        (define-instruction (,cau)
  800.      (d (op :constant #xD8)
  801.         (r2 :argument register)
  802.         (r3 :argument address-register)
  803.         (i :argument label
  804.            :function (lambda (label)
  805.                (multiple-value-bind (high low) (,name label)
  806.                  (declare (ignore low))
  807.                  high)))))
  808.        (define-pseudo-instruction ,name 64 (dst src label)
  809.      (multiple-value-bind (high low) (,name label)
  810.        (declare (ignore low))
  811.        (cond ((zerop high)
  812.           (inst ,cal dst src label))
  813.          (t
  814.           (inst ,cal dst src label)
  815.           (inst ,cau dst dst label))))))))
  816.  
  817.  
  818. ;; code = fn - header - label-offset + other-pointer-tag
  819. (define-compute-instruction compute-code-from-fn
  820.                 (- vm:other-pointer-type
  821.                    (label-position label)
  822.                    (component-header-length)))
  823.  
  824. ;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
  825. (define-compute-instruction compute-code-from-lra
  826.                 (- (+ (label-position label)
  827.                   (component-header-length))))
  828.  
  829. ;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
  830. (define-compute-instruction compute-lra-from-code
  831.                 (+ (label-position label)
  832.                    (component-header-length)))
  833.  
  834. ;;;; 68881 instruction set details:
  835.  
  836. ;;; The low 7 bits of the 68881 instructions.
  837. ;;; 
  838. (defconstant mc68881-opcodes
  839.   '((:move . #x00)
  840.     (:int . #x01)
  841.     (:sinh . #x02)
  842.     (:intrz . #x03)
  843.     (:sqrt . #x04)
  844.     (:lognp1 . #x06)
  845.     (:etoxm1 . #x08)
  846.     (:tanh . #x09)
  847.     (:atan . #x0A)
  848.     (:asin . #x0C)
  849.     (:atanh . #x0D)
  850.     (:sin . #x0E)
  851.     (:tan . #x0F)
  852.     (:etox . #x10)
  853.     (:twotox . #x11)
  854.     (:tentox . #x12)
  855.     (:logn . #x14)
  856.     (:log10 . #x15)
  857.     (:log2 . #x16)
  858.     (:abs . #x18)
  859.     (:cosh . #x19)
  860.     (:neg . #x1A)
  861.     (:acos . #x1C)
  862.     (:cos . #x1D)
  863.     (:getexp . #x1E)
  864.     (:getman . #x1F)
  865.     (:div . #x20)
  866.     (:mod . #x21)
  867.     (:add . #x22)
  868.     (:mul . #x23)
  869.     (:sgldiv . #x24)
  870.     (:rem . #x25)
  871.     (:scale . #x26)
  872.     (:sglmul . #x27)
  873.     (:sub . #x28)
  874.     (:sincos . #x30)
  875.     (:cmp . #x38)
  876.     (:tst . #x3A)))
  877.  
  878.  
  879. ;;; Names of interesting 68881 control registers.
  880. ;;;
  881. (defconstant mc68881-control-regs
  882.   '((:fpsr . 2)
  883.     (:fpcr . 4)
  884.     (:fpiar . 1)))
  885.  
  886.  
  887. ;;; The encoding of operand format in memory (bits 10..12 in the 68881
  888. ;;; instruction.)
  889. ;;;
  890. (defconstant mc68881-operand-types
  891.   '((:integer . 0)          ; 32 bit integer.
  892.     (:single . 1)          ; 32 bit float.
  893.     (:double . 5)))          ; 64 bit float.
  894.  
  895.  
  896. ;;; Bits 13..15 in the 68881 instruction.  Controls where operands are found.
  897. ;;;
  898. (defconstant mc68881-instruction-classes
  899.   '((:freg-to-freg . 0)
  900.     (:mem-to-freg . 2)
  901.     (:freg-to-mem . 3)
  902.     (:mem-to-scr . 4)
  903.     (:scr-to-mem . 5)))
  904.  
  905.  
  906. ;;; Length in words of memory data to transfer.  This is part of the RT
  907. ;;; hardware assist protocol, and is placed in the low two bits of the address
  908. ;;; to the store instruction.
  909. ;;;
  910. (defconstant mc68881-operand-lengths
  911.   '((nil . 0) ; No transfer...
  912.     (:integer . 1)
  913.     (:single . 1)
  914.     (:double . 2)))
  915.  
  916. ;;; RT hardware assist protocol for whether to read or write memory, here
  917. ;;; represented as a function of the mc68881 instruction class.
  918. ;;; 
  919. (defconstant mc68881-transfer-control-field-alist
  920.   '((:freg-to-freg . 0)
  921.     (:mem-to-freg . 0)
  922.     (:freg-to-mem . #x3c0000)
  923.     (:mem-to-scr . 0)
  924.     (:scr-to-mem . #x3c0000)))
  925.  
  926.  
  927. (defun mc68881-fp-reg-p (object)
  928.   (and (tn-p object)
  929.        (eq (sb-name (sc-sb (tn-sc object)))
  930.        'mc68881-float-registers)))
  931.  
  932. (define-argument-type mc68881-fp-reg
  933.   :type '(satisfies mc68881-fp-reg-p)
  934.   :function tn-offset)
  935.  
  936. ;;; This is really a ST (store word) instruction, but we have magic extra
  937. ;;; arguments to represent the reading and writing of the FP registers.  R3
  938. ;;; will already have been set up with the high bits of the FP instruction by a
  939. ;;; preceding CAL.
  940. ;;;
  941. (define-format (mc68881-inst 32)
  942.   (fpn (byte 0 0) :read t :write t)
  943.   (fpm (byte 0 0) :read t)
  944.   (op (byte 8 24) :default #xDD)
  945.   (r2 (byte 4 20) :read t)
  946.   (r3 (byte 4 16) :read t)
  947.   (i (byte 16 0)))
  948.  
  949.  
  950. ;;; DO-68881-INST  --  Internal
  951. ;;;
  952. ;;;    Utility used to emit a 68881 operation.  We emit the CAU that sets up
  953. ;;; the high bits of the operation in Temp, and we return the low bits that
  954. ;;; should be passed as the I field of the actual FP operation instruction.
  955. ;;;
  956. (defun do-68881-inst (op temp &key fpn fpm (class :freg-to-freg)
  957.              data optype creg)
  958.   (assert (if fpm
  959.           (and (mc68881-fp-reg-p fpm)
  960.            (not (or optype data))
  961.            (eql class :freg-to-freg))
  962.           (and (tn-p data)
  963.            (eq (sb-name (sc-sb (tn-sc data))) 'registers)
  964.             (or optype creg)
  965.            (not (eql class :freg-to-freg)))))
  966.   (assert (if fpn
  967.           (mc68881-fp-reg-p fpn)
  968.           (and creg (member class '(:mem-to-scr :scr-to-mem)))))
  969.            
  970.   (let* ((opcode
  971.       (logior #xFC000000
  972.           (or (cdr (assoc class mc68881-transfer-control-field-alist))
  973.               (error "Unknown instruction class ~S." class))
  974.           (ash (cdr (assoc class mc68881-instruction-classes))
  975.                15)
  976.           (ash (ecase class
  977.              (:freg-to-freg (tn-offset fpm))
  978.              ((:mem-to-freg :freg-to-mem)
  979.               (or (cdr (assoc optype mc68881-operand-types))
  980.                   (error "Unknown operation type ~S." optype)))
  981.              ((:mem-to-scr :scr-to-mem)
  982.               (or (cdr (assoc creg mc68881-control-regs))
  983.                   (error "Unknown control register ~S." creg))))
  984.                12)
  985.           (ash (if fpn
  986.                (tn-offset fpn)
  987.                0)
  988.                9)
  989.           (ash (or (cdr (assoc op mc68881-opcodes))
  990.                (error "Unknown opcode ~S." op))
  991.                2)
  992.           (if creg
  993.               1
  994.               (or (cdr (assoc optype mc68881-operand-lengths))
  995.               (error "Unknown operation type ~S." optype)))))
  996.      (low (logand opcode #xFFFF))
  997.      (high (+ (logand (ash opcode -16) #xFFFF)
  998.           (if (eql (logand low #x8000) 0) 0 1))))
  999.     (inst cau temp 0 high)
  1000.     low))
  1001.  
  1002.  
  1003. (define-instruction (mc68881-binop-inst)
  1004.   (mc68881-inst
  1005.    (fpn :argument mc68881-fp-reg)
  1006.    (fpm :argument mc68881-fp-reg)
  1007.    (r2 :constant null-offset)
  1008.    (r3 :argument address-register)
  1009.    (i :argument (unsigned-byte 16))))
  1010.  
  1011. ;;; This pseudo-instruction emits a floating-point binop on the 68881.  FPN is
  1012. ;;; the destination float register (and second arg) FPM is the source float
  1013. ;;; register.  Op is the 68881 opcode.  Temp is a sap-reg (i.e. non-zero,
  1014. ;;; non-descriptor) register that we form the FP instruction in.
  1015. ;;;
  1016. (define-pseudo-instruction mc68881-binop 64 (fpn fpm op temp)
  1017.   (inst mc68881-binop-inst fpn fpm temp
  1018.     (do-68881-inst op temp :fpm fpm :fpn fpn)))
  1019.  
  1020.  
  1021. ;;; Unop is like binop, but we don't read FPN before we write it.
  1022. ;;;
  1023. (define-instruction (mc68881-unop-inst)
  1024.   (mc68881-inst
  1025.    (fpn :argument mc68881-fp-reg :read nil)
  1026.    (fpm :argument mc68881-fp-reg)
  1027.    (r2 :constant null-offset)
  1028.    (r3 :argument address-register)
  1029.    (i :argument (unsigned-byte 16))))
  1030.  
  1031. (define-pseudo-instruction mc68881-unop 64 (fpn fpm op temp)
  1032.   (inst mc68881-unop-inst fpn fpm temp
  1033.     (do-68881-inst op temp :fpm fpm :fpn fpn)))
  1034.  
  1035. ;;; Compare is like binop, but we don't write FPN.
  1036. ;;;
  1037. (define-instruction (mc68881-compare-inst)
  1038.   (mc68881-inst
  1039.    (fpn :argument mc68881-fp-reg :write nil)
  1040.    (fpm :argument mc68881-fp-reg)
  1041.    (r2 :constant null-offset)
  1042.    (r3 :argument address-register)
  1043.    (i :argument (unsigned-byte 16))))
  1044.  
  1045. (define-pseudo-instruction mc68881-compare 64 (fpn fpm op temp)
  1046.   (inst mc68881-compare-inst fpn fpm temp
  1047.     (do-68881-inst op temp :fpm fpm :fpn fpn)))
  1048.  
  1049. ;;; Move FPM to FPN.
  1050. ;;;
  1051. (define-pseudo-instruction mc68881-move 64 (fpn fpm temp)
  1052.   (inst mc68881-unop fpn fpm :move temp))
  1053.  
  1054.  
  1055.  
  1056. (define-format (s 16)
  1057.   (op (byte 12 4))
  1058.   (n (byte 4 0)))
  1059.                
  1060. ;;; This is a "setcb 8", which is used to wait for a result from the FPA to
  1061. ;;; appear in memory (or something...)
  1062. ;;;
  1063. (define-instruction (mc68881-wait)
  1064.   (s
  1065.    (op :constant #x97F)
  1066.    (n :constant 8)))
  1067.  
  1068.  
  1069. (define-instruction (mc68881-load-inst :use (memory))
  1070.   (mc68881-inst
  1071.    (fpn :argument mc68881-fp-reg :read nil)
  1072.    (fpm :constant 0)
  1073.    (r2 :argument register)
  1074.    (r3 :argument address-register)
  1075.    (i :argument (unsigned-byte 16))))
  1076.  
  1077. (define-pseudo-instruction mc68881-load 80 (fpn data optype temp)
  1078.   (inst mc68881-load-inst fpn data temp
  1079.     (do-68881-inst :move temp :fpn fpn :data data :optype optype
  1080.                :class :mem-to-freg))
  1081.   (inst mc68881-wait))
  1082.  
  1083. (define-instruction (mc68881-store-inst :clobber (memory))
  1084.   (mc68881-inst
  1085.    (fpn :argument mc68881-fp-reg :write nil)
  1086.    (fpm :constant 0)
  1087.    (r2 :argument register)
  1088.    (r3 :argument address-register)
  1089.    (i :argument (unsigned-byte 16))))
  1090.  
  1091. (define-pseudo-instruction mc68881-store 80 (fpn data optype temp)
  1092.   (inst mc68881-store-inst fpn data temp
  1093.     (do-68881-inst :move temp :fpn fpn :data data :optype optype
  1094.                :class :freg-to-mem))
  1095.   (inst mc68881-wait))
  1096.  
  1097.  
  1098. (define-instruction (mc68881-load-status-inst :use (memory)
  1099.                           :clobber (float-status))
  1100.   (mc68881-inst
  1101.    (fpn :constant 0)
  1102.    (fpm :constant 0)
  1103.    (r2 :argument register)
  1104.    (r3 :argument address-register)
  1105.    (i :argument (unsigned-byte 16))))
  1106.  
  1107. (define-pseudo-instruction mc68881-load-status 80 (creg data temp)
  1108.   (inst mc68881-load-status-inst data temp
  1109.     (do-68881-inst :move temp :creg creg :data data
  1110.                :class :mem-to-scr))
  1111.   (inst mc68881-wait))
  1112.  
  1113. (define-instruction (mc68881-store-status-inst :clobber (memory)
  1114.                            :use (float-status))
  1115.   (mc68881-inst
  1116.    (fpn :constant 0)
  1117.    (fpm :constant 0)
  1118.    (r2 :argument register)
  1119.    (r3 :argument address-register)
  1120.    (i :argument (unsigned-byte 16))))
  1121.  
  1122. (define-pseudo-instruction mc68881-store-status 80 (creg data temp)
  1123.   (inst mc68881-store-status-inst data temp
  1124.     (do-68881-inst :move temp :creg creg :data data
  1125.                :class :scr-to-mem))
  1126.   (inst mc68881-wait))
  1127.  
  1128.  
  1129. ;;; AFPA instruction set details:
  1130.  
  1131. ;;; Support for the AFPA on IBM RT PC (APC and EAPC models).
  1132.  
  1133. (defconstant afpa-opcodes
  1134.   '((:absl . #x74)
  1135.     (:abss . #x75)
  1136.     (:addl . #x40)
  1137.     (:adds . #x41)
  1138.     (:coml . #x48)
  1139.     (:coms . #x49)
  1140.     (:comtl . #x4A)
  1141.     (:comts . #x4B)
  1142.     (:csl  . #x1B)
  1143.     (:cls  . #x16)
  1144.     (:cwl  . #x03)
  1145.     (:cws  . #x07)
  1146.     (:copl . #x44)
  1147.     (:cops . #x45)
  1148.     (:divl . #x60)
  1149.     (:divs . #x61)
  1150.     (:flw  . #x3B)
  1151.     (:fsw  . #x3F)
  1152.     (:mull . #x70)
  1153.     (:muls . #x71)
  1154.     (:negl . #x54)
  1155.     (:negs . #x55)
  1156.     (:noop . #x9F)
  1157.     (:rdfr . #xBC) ; type = ld
  1158.     (:rlw  . #x23)
  1159.     (:rsw  . #x27)
  1160.     (:subl . #x50)
  1161.     (:subs . #x51)
  1162.     (:tlw  . #x2B)
  1163.     (:tsw  . #x2F)
  1164.     (:wtfr . #x94)))
  1165.   
  1166. (defconstant afpa-special-opcodes
  1167.   '((:wtstr . #.(ash #x10FEE 2)) ; DS = #b01, OP1, OP2 = #xE.
  1168.     (:rdstr . #.(ash #x137EE 2)) ; DS = #b01, OP1, OP2 = #xE, type = ld
  1169.     (:rddma . #.(ash #xF9F00 2)))) ; DS = #b11, OP2 = #x30
  1170.  
  1171. (defconstant afpa-ds-codes
  1172.   '((:register . #b00)
  1173.     (:fr1-immediate . #b10)
  1174.     (:fr2-immediate . #b01)))
  1175.  
  1176. (defconstant afpa-ts-codes
  1177.   '((:pio . #b00)
  1178.     (:word . #b01)
  1179.     (:single . #b01)
  1180.     (:double . #b10)
  1181.     (:multiple . #b11)))
  1182.  
  1183. #|
  1184. (defconstant afpa-atanl #x0D4)
  1185. (defconstant afpa-cosl #x0C2)
  1186. (defconstant afpa-expl #x0D8)
  1187. (defconstant afpa-log10l #x0DE)
  1188. (defconstant afpa-logl #x0DC)
  1189. (defconstant afpa-sinl #x0C0)
  1190. (defconstant afpa-sqrl #x064)
  1191. (defconstant afpa-sqrs #x065)
  1192. (defconstant afpa-tanl #x0C4)
  1193. |#
  1194.  
  1195. (defun afpa-fp-reg-p (object)
  1196.   (and (tn-p object)
  1197.        (eq (sb-name (sc-sb (tn-sc object)))
  1198.        'afpa-float-registers)))
  1199.  
  1200. (define-argument-type afpa-fp-reg
  1201.   :type '(satisfies afpa-fp-reg-p)
  1202.   :function tn-offset)
  1203.  
  1204. ;;; These are really L and ST (load and store word) instructions, but we have
  1205. ;;; magic extra arguments to represent the reading and writing of the FP
  1206. ;;; registers.  R3 will already have been set up with the high bits of the FP
  1207. ;;; instruction by a preceding CAL.
  1208. ;;;
  1209. (define-format (afpa-l-inst 32)
  1210.   (fr2 (byte 0 0) :default 0)
  1211.   (fr1 (byte 0 0) :read t)
  1212.   (op (byte 8 24) :default #xCD)
  1213.   (r2 (byte 4 20) :write t)
  1214.   (r3 (byte 4 16) :read t)
  1215.   (i (byte 16 0)))
  1216. ;;;
  1217. (define-format (afpa-st-inst 32)
  1218.   (fr2 (byte 0 0) :read t :write t)
  1219.   (fr1 (byte 0 0) :read t)
  1220.   (op (byte 8 24) :default #xDD)
  1221.   (r2 (byte 4 20) :read t)
  1222.   (r3 (byte 4 16) :read t)
  1223.   (i (byte 16 0)))
  1224.  
  1225.  
  1226. ;;; DO-AFPA-INST  --  Internal
  1227. ;;;
  1228. ;;;    Utility used to emit a afpa operation.  We emit the CAU that sets up
  1229. ;;; the high bits of the operation in Temp, and we return the low bits that
  1230. ;;; should be passed as the I field of the actual FP operation instruction.
  1231. ;;;
  1232. ;;; Note: FR2 is the modified register (if any), and the *first* operand to
  1233. ;;; binops (I didn't make this up.)
  1234. ;;;
  1235. (defun do-afpa-inst (op temp &key fr1 fr2 (ds :register) (ts :pio)
  1236.             data odd)
  1237.   (when fr1
  1238.     (assert (afpa-fp-reg-p fr1)))
  1239.   (when fr2
  1240.     (assert (afpa-fp-reg-p fr2)))
  1241.   (when data
  1242.     (assert (and (tn-p data)
  1243.          (eq (sb-name (sc-sb (tn-sc data))) 'registers)
  1244.          (not (and fr1 fr2)))))
  1245.   (when odd (assert data))
  1246.   (let* ((inc (if odd 1 0))
  1247.      (fr1-offset (if fr1 (+ (tn-offset fr1) inc) 0))
  1248.      (fr2-offset (if fr2 (+ (tn-offset fr2) inc) 0))
  1249.      (opcode
  1250.       (logior (ash (if (eq ts :pio) #xFF #xFE) 24)
  1251.           (ash (ldb (byte 2 4) fr1-offset) 22)
  1252.           (ash (ldb (byte 2 4) fr2-offset) 20)
  1253.           (ash (or (cdr (assoc ds afpa-ds-codes))
  1254.                (error "Unknown DS code: ~S." ds))
  1255.                18)
  1256.           (let ((res (cdr (assoc op afpa-opcodes))))
  1257.             (if res
  1258.             (ash res 10)
  1259.             (or (cdr (assoc op afpa-special-opcodes))
  1260.                 (error "Unknown opcode: ~S." op))))
  1261.           (ash (ldb (byte 4 0) fr1-offset) 6)
  1262.           (ash (ldb (byte 4 0) fr2-offset) 2)
  1263.           (or (cdr (assoc ts afpa-ts-codes))
  1264.               (error "Unknown TS code: ~S." ts))))
  1265.      (low (logand opcode #xFFFF))
  1266.      (high (+ (logand (ash opcode -16) #xFFFF)
  1267.           (if (eql (logand low #x8000) 0) 0 1))))
  1268.     (inst cau temp 0 high)
  1269.     low))
  1270.  
  1271.  
  1272. ;;; The AFPA-BINOP pseudo-instruction emits a floating-point binop on the afpa.
  1273. ;;; FR2 is the destination float register (and first arg).  FR1 is the source
  1274. ;;; float register.  Op is the afpa opcode.  Temp is a sap-reg (i.e. non-zero,
  1275. ;;; non-descriptor) register that we form the FP instruction in.
  1276. ;;;
  1277. (define-instruction (afpa-binop-inst)
  1278.   (afpa-st-inst
  1279.    (fr2 :argument afpa-fp-reg)
  1280.    (fr1 :argument afpa-fp-reg)
  1281.    (r2 :constant null-offset)
  1282.    (r3 :argument address-register)
  1283.    (i :argument (unsigned-byte 16))))
  1284. ;;;
  1285. (define-pseudo-instruction afpa-binop 64 (fr2 fr1 op temp)
  1286.   (inst afpa-binop-inst fr2 fr1 temp
  1287.     (do-afpa-inst op temp :fr1 fr1 :fr2 fr2)))
  1288.  
  1289.  
  1290. ;;; Unop is like binop, but we don't read FR2 before we write it.
  1291. ;;;
  1292. (define-instruction (afpa-unop-inst)
  1293.   (afpa-st-inst
  1294.    (fr2 :argument afpa-fp-reg :read nil)
  1295.    (fr1 :argument afpa-fp-reg)
  1296.    (r2 :constant null-offset)
  1297.    (r3 :argument address-register)
  1298.    (i :argument (unsigned-byte 16))))
  1299.  
  1300. (define-pseudo-instruction afpa-unop 64 (fr2 fr1 op temp)
  1301.   (inst afpa-unop-inst fr2 fr1 temp
  1302.     (do-afpa-inst op temp :fr1 fr1 :fr2 fr2)))
  1303.  
  1304. ;;; Sugar up the move a bit...
  1305. (define-pseudo-instruction afpa-move 64 (fr2 fr1 format temp)
  1306.   (inst afpa-unop fr2 fr1
  1307.     (ecase format
  1308.       (:single :cops)
  1309.       (:double :copl))
  1310.     temp))
  1311.  
  1312. ;;; Compare is like binop, but we don't write FR2.
  1313. ;;;
  1314. (define-instruction (afpa-compare-inst)
  1315.   (afpa-st-inst
  1316.    (fr2 :argument afpa-fp-reg :write nil)
  1317.    (fr1 :argument afpa-fp-reg)
  1318.    (r2 :constant null-offset)
  1319.    (r3 :argument address-register)
  1320.    (i :argument (unsigned-byte 16))))
  1321.  
  1322. (define-pseudo-instruction afpa-compare 64 (fr2 fr1 op temp)
  1323.   (inst afpa-compare-inst fr2 fr1 temp
  1324.     (do-afpa-inst op temp :fr1 fr1 :fr2 fr2)))
  1325.  
  1326.  
  1327. ;;; Noop is used to wait for DMA operations (load and store) to complete.
  1328. ;;;
  1329. (define-instruction (afpa-noop-inst :pinned t)
  1330.   (afpa-st-inst
  1331.    (fr1 :constant 0)
  1332.    (fr2 :constant 0)
  1333.    (r2 :constant null-offset)
  1334.    (r3 :argument address-register)
  1335.    (i :argument (unsigned-byte 16))))
  1336.  
  1337. (define-pseudo-instruction afpa-noop 64 (temp)
  1338.   (inst afpa-noop-inst temp
  1339.     (do-afpa-inst :noop temp)))
  1340.  
  1341.  
  1342. ;;; Load = WTFR (write float reg) + DMA.
  1343. ;;;
  1344. (define-instruction (afpa-load-inst :use (memory))
  1345.   (afpa-st-inst
  1346.    (fr2 :argument afpa-fp-reg :read nil)
  1347.    (fr1 :constant 0)
  1348.    (r2 :argument register)
  1349.    (r3 :argument address-register)
  1350.    (i :argument (unsigned-byte 16))))
  1351.  
  1352. (define-pseudo-instruction afpa-load 64 (fr2 data ts temp)
  1353.   (inst afpa-load-inst fr2 data temp
  1354.     (do-afpa-inst :wtfr temp :fr2 fr2 :data data :ts ts)))
  1355.  
  1356.  
  1357. ;;; Store = RDDMA
  1358. ;;;
  1359. (define-instruction (afpa-store-inst :clobber (memory))
  1360.   (afpa-st-inst
  1361.    (fr2 :constant 0)
  1362.    (fr1 :argument afpa-fp-reg)
  1363.    (r2 :argument register)
  1364.    (r3 :argument address-register)
  1365.    (i :argument (unsigned-byte 16))))
  1366.  
  1367. (define-pseudo-instruction afpa-store 64 (fr1 data ts temp)
  1368.   (inst afpa-store-inst fr1 data temp
  1369.     (do-afpa-inst :rddma temp :fr1 fr1 :data data :ts ts)))
  1370.  
  1371.  
  1372. ;;; Get float = RDFR
  1373. ;;;
  1374. (define-instruction (afpa-get-float-inst :clobber (float-status))
  1375.   (afpa-l-inst
  1376.    (fr2 :constant 0)
  1377.    (fr1 :argument afpa-fp-reg)
  1378.    (r2 :argument register)
  1379.    (r3 :argument address-register)
  1380.    (i :argument (unsigned-byte 16))))
  1381.  
  1382. (define-pseudo-instruction afpa-get-float 64 (data fr1 temp)
  1383.   (inst afpa-get-float-inst fr1 data temp
  1384.     (do-afpa-inst :rdfr temp :fr1 fr1 :data data)))
  1385.  
  1386. (define-pseudo-instruction afpa-get-float-odd 64 (data fr1 temp)
  1387.   (inst afpa-get-float-inst fr1 data temp
  1388.     (do-afpa-inst :rdfr temp :fr1 fr1 :data data :odd t)))
  1389.  
  1390.  
  1391. ;;; Put float = WTFR
  1392. ;;;
  1393. (define-instruction (afpa-put-float-inst)
  1394.   (afpa-st-inst
  1395.    (fr2 :argument afpa-fp-reg)
  1396.    (fr1 :constant 0)
  1397.    (r2 :argument register)
  1398.    (r3 :argument address-register)
  1399.    (i :argument (unsigned-byte 16))))
  1400.  
  1401. (define-pseudo-instruction afpa-put-float 64 (fr2 data temp)
  1402.   (inst afpa-put-float-inst fr2 data temp
  1403.     (do-afpa-inst :wtfr temp :fr2 fr2 :data data)))
  1404.  
  1405. (define-pseudo-instruction afpa-put-float-odd 64 (fr2 data temp)
  1406.   (inst afpa-put-float-inst fr2 data temp
  1407.     (do-afpa-inst :wtfr temp :fr2 fr2 :data data :odd t)))
  1408.  
  1409.  
  1410. ;;; Get status = RDSTR
  1411. ;;;
  1412. (define-instruction (afpa-get-status-inst :clobber (float-status))
  1413.   (afpa-l-inst
  1414.    (fr2 :constant 0)
  1415.    (fr1 :constant 0)
  1416.    (r2 :argument register)
  1417.    (r3 :argument address-register)
  1418.    (i :argument (unsigned-byte 16))))
  1419.  
  1420. (define-pseudo-instruction afpa-get-status 64 (data temp)
  1421.   (inst afpa-get-status-inst data temp
  1422.     (do-afpa-inst :rdstr temp :data data)))
  1423.  
  1424.  
  1425. ;;; Put status = WTSTR
  1426. ;;;
  1427. (define-instruction (afpa-put-status-inst :use (float-status))
  1428.   (afpa-st-inst
  1429.    (fr2 :constant 0)
  1430.    (fr1 :constant 0)
  1431.    (r2 :argument register)
  1432.    (r3 :argument address-register)
  1433.    (i :argument (unsigned-byte 16))))
  1434.  
  1435. (define-pseudo-instruction afpa-put-status 64 (data temp)
  1436.   (inst afpa-put-status-inst data temp
  1437.     (do-afpa-inst :wtstr temp :data data)))
  1438.