src/compiler/arm/insts.lisp

   1 ;;;; that part of the description of the ARM instruction set (for
   2 ;;;; ARMv5) which can live on the cross-compilation host
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB!ARM-ASM")
  14
  15 (eval-when (:compile-toplevel :load-toplevel :execute)
  16   ;; Imports from this package into SB-VM
  17   (import '(conditional-opcode emit-word
  18             composite-immediate-instruction encodable-immediate
  19             lsl lsr asr ror cpsr @) 'sb!vm)
  20   ;; Imports from SB-VM into this package
  21   (import '(sb!vm::nil-value sb!vm::registers sb!vm::null-tn sb!vm::null-offset
  22             sb!vm::pc-tn sb!vm::pc-offset sb!vm::code-offset)))
  23
  24 (setf *disassem-inst-alignment-bytes* 4)
  25 \f
  26
  27 (defconstant-eqx +conditions+
  28   '((:eq . 0)
  29     (:ne . 1)
  30     (:cs . 2) (:hs . 2)
  31     (:cc . 3) (:lo . 3)
  32     (:mi . 4)
  33     (:pl . 5)
  34     (:vs . 6)
  35     (:vc . 7)
  36     (:hi . 8)
  37     (:ls . 9)
  38     (:ge . 10)
  39     (:lt . 11)
  40     (:gt . 12)
  41     (:le . 13)
  42     (:al . 14))
  43   #'equal)
  44 (defconstant-eqx sb!vm::+condition-name-vec+
  45   #.(let ((vec (make-array 16 :initial-element nil)))
  46       (dolist (cond +conditions+ vec)
  47         (when (null (aref vec (cdr cond)))
  48           (setf (aref vec (cdr cond)) (car cond)))))
  49   #'equalp)
  50
  51 ;;; Set assembler parameters. (In CMU CL, this was done with
  52 ;;; a call to a macro DEF-ASSEMBLER-PARAMS.)
  53 (eval-when (:compile-toplevel :load-toplevel :execute)
  54   (setf sb!assem:*assem-scheduler-p* nil))
  55
  56 (defun conditional-opcode (condition)
  57   (cdr (assoc condition +conditions+ :test #'eq)))
  58 \f
  59 ;;;; disassembler field definitions
  60
  61 (define-arg-type condition-code :printer #'print-condition)
  62
  63 (define-arg-type reg :printer #'print-reg)
  64
  65 (define-arg-type float-reg :printer #'print-float-reg)
  66
  67 (define-arg-type float-sys-reg :printer #'print-float-sys-reg)
  68
  69 (define-arg-type shift-type :printer #'print-shift-type)
  70
  71 (define-arg-type immediate-shift :printer #'print-immediate-shift)
  72
  73 (define-arg-type shifter-immediate :printer #'print-shifter-immediate)
  74
  75 (define-arg-type relative-label
  76   :sign-extend t
  77   :use-label #'use-label-relative-label)
  78
  79 (define-arg-type load/store-immediate :printer #'print-load/store-immediate)
  80
  81 (define-arg-type load/store-register :printer #'print-load/store-register)
  82
  83 (define-arg-type msr-field-mask :printer #'print-msr-field-mask)
  84 \f
  85 ;;;; disassembler instruction format definitions
  86
  87 (define-instruction-format (dp-shift-immediate 32
  88                             :default-printer
  89                             '(:name cond :tab rd ", " rn ", " rm shift))
  90   (cond :field (byte 4 28) :type 'condition-code)
  91   (opcode-8 :field (byte 8 20))
  92   (rn :field (byte 4 16) :type 'reg)
  93   (rd :field (byte 4 12) :type 'reg)
  94   (shift :fields (list (byte 5 7) (byte 2 5)) :type 'immediate-shift)
  95   (register-shift-p :field (byte 1 4) :value 0)
  96   (rm :field (byte 4 0) :type 'reg))
  97
  98 (define-instruction-format
  99     (dp-shift-register 32
 100      :default-printer
 101      '(:name cond :tab rd ", " rn ", " rm ", " shift-type " " rs))
 102   (cond :field (byte 4 28) :type 'condition-code)
 103   (opcode-8 :field (byte 8 20))
 104   (rn :field (byte 4 16) :type 'reg)
 105   (rd :field (byte 4 12) :type 'reg)
 106   (rs :field (byte 4 8) :type 'reg)
 107   (multiply-p :field (byte 1 7) :value 0)
 108   (shift-type :field (byte 2 5) :type 'shift-type)
 109   (register-shift-p :field (byte 1 4) :value 1)
 110   (rm :field (byte 4 0) :type 'reg))
 111
 112 (define-instruction-format (dp-immediate 32
 113                             :default-printer
 114                             '(:name cond :tab rd ", " rn ", #" immediate))
 115   (cond :field (byte 4 28) :type 'condition-code)
 116   (opcode-8 :field (byte 8 20))
 117   (rn :field (byte 4 16) :type 'reg)
 118   (rd :field (byte 4 12) :type 'reg)
 119   (immediate :field (byte 12 0) :type 'shifter-immediate))
 120
 121 (define-instruction-format (branch 32 :default-printer '(:name cond :tab target))
 122   (cond :field (byte 4 28) :type 'condition-code)
 123   (opcode-4 :field (byte 4 24))
 124   (target :field (byte 24 0) :type 'relative-label))
 125
 126 (define-instruction-format
 127     (load/store-immediate 32
 128      ;; FIXME: cond should come between LDR/STR and B.
 129      :default-printer '(:name cond :tab rd ", [" rn load/store-offset))
 130   (cond :field (byte 4 28) :type 'condition-code)
 131   (opcode-3 :field (byte 3 25))
 132   (load/store-offset :fields (list (byte 1 24)
 133                                    (byte 1 23)
 134                                    (byte 1 21)
 135                                    (byte 12 0))
 136                      :type 'load/store-immediate)
 137   (opcode-b :field (byte 1 22))
 138   (opcode-l :field (byte 1 20))
 139   (rn :field (byte 4 16) :type 'reg)
 140   (rd :field (byte 4 12) :type 'reg))
 141
 142 (define-instruction-format
 143     (load/store-register 32
 144      ;; FIXME: cond should come between LDR/STR and B.
 145      :default-printer '(:name cond :tab rd ", [" rn load/store-offset))
 146   (cond :field (byte 4 28) :type 'condition-code)
 147   (opcode-3 :field (byte 3 25))
 148   (load/store-offset :fields (list (byte 1 24)
 149                                    (byte 1 23)
 150                                    (byte 1 21)
 151                                    (byte 5 7)  ;; shift_imm
 152                                    (byte 2 5)  ;; shift
 153                                    (byte 4 0)) ;; Rm
 154                      :type 'load/store-register)
 155   (opcode-b :field (byte 1 22))
 156   (opcode-l :field (byte 1 20))
 157   (opcode-0 :field (byte 1 4))
 158   (rn :field (byte 4 16) :type 'reg)
 159   (rd :field (byte 4 12) :type 'reg))
 160
 161 (define-instruction-format (swi 32
 162                             :default-printer '(:name cond :tab "#" swi-number))
 163   (cond :field (byte 4 28) :type 'condition-code)
 164   (opcode-4 :field (byte 4 24))
 165   (swi-number :field (byte 24 0)))
 166
 167 (define-instruction-format (debug-trap 32 :default-printer '(:name :tab code))
 168   (opcode-32 :field (byte 32 0))
 169   ;; We use a prefilter in order to read trap codes in order to avoid
 170   ;; encoding the code within the instruction body (requiring the use of
 171   ;; a different trap instruction and a SIGILL handler) and in order to
 172   ;; avoid attempting to include the code in the decoded instruction
 173   ;; proper (requiring moving to a 40-bit instruction for disassembling
 174   ;; trap codes, and being affected by endianness issues).
 175   (code :prefilter (lambda (dstate) (read-suffix 8 dstate))
 176         :reader debug-trap-code))
 177
 178 (define-instruction-format (msr-immediate 32
 179                             :default-printer
 180                             '(:name cond :tab field-mask ", #" immediate))
 181   (cond :field (byte 4 28) :type 'condition-code)
 182   (opcode-5 :field (byte 5 23) :value #b00110)
 183   (field-mask :fields (list (byte 1 22) (byte 4 16)) :type 'msr-field-mask)
 184   (opcode-2 :field (byte 2 20) :value #b10)
 185   (sbo :field (byte 4 12) :value #b1111)
 186   (immediate :field (byte 12 0) :type 'shifter-immediate))
 187
 188 (define-instruction-format (msr-register 32
 189                             :default-printer '(:name cond :tab field-mask ", " rm))
 190   (cond :field (byte 4 28) :type 'condition-code)
 191   (opcode-5 :field (byte 5 23) :value #b00010)
 192   (field-mask :fields (list (byte 1 22) (byte 4 16)) :type 'msr-field-mask)
 193   (opcode-2 :field (byte 2 20) :value #b10)
 194   (sbo :field (byte 4 12) :value #b1111)
 195   (sbz :field (byte 8 4) :value #b00000000)
 196   (rm :field (byte 4 0) :type 'reg))
 197
 198 (define-instruction-format (multiply-dzsm 32
 199                             :default-printer '(:name cond :tab rd ", " rs ", " rm))
 200   (cond :field (byte 4 28) :type 'condition-code)
 201   (opcode-8 :field (byte 8 20))
 202   (rd :field (byte 4 16) :type 'reg)
 203   (sbz :field (byte 4 12) :value 0)
 204   (rs :field (byte 4 8) :type 'reg)
 205   (opcode-4 :field (byte 4 4))
 206   (rm :field (byte 4 0) :type 'reg))
 207
 208 (define-instruction-format
 209     (multiply-dnsm 32
 210      :default-printer '(:name cond :tab rd ", " rs ", " rm ", " num))
 211   (cond :field (byte 4 28) :type 'condition-code)
 212   (opcode-8 :field (byte 8 20))
 213   (rd :field (byte 4 16) :type 'reg)
 214   (num :field (byte 4 12) :type 'reg)
 215   (rs :field (byte 4 8) :type 'reg)
 216   (opcode-4 :field (byte 4 4))
 217   (rm :field (byte 4 0) :type 'reg))
 218
 219 (define-instruction-format
 220     (multiply-ddsm 32
 221      :default-printer '(:name cond :tab rdlo ", " rdhi ", " rs ", " rm))
 222   (cond :field (byte 4 28) :type 'condition-code)
 223   (opcode-8 :field (byte 8 20))
 224   (rdhi :field (byte 4 16) :type 'reg)
 225   (rdlo :field (byte 4 12) :type 'reg)
 226   (rs :field (byte 4 8) :type 'reg)
 227   (opcode-4 :field (byte 4 4))
 228   (rm :field (byte 4 0) :type 'reg))
 229
 230 (define-instruction-format (branch-exchange 32
 231                             :default-printer '(:name cond :tab rm))
 232   (cond :field (byte 4 28) :type 'condition-code)
 233   (opcode-8 :field (byte 8 20))
 234   (sbo :field (byte 12 8) :value #xFFF)
 235   (opcode-4 :field (byte 4 4))
 236   (rm :field (byte 4 0) :type 'reg))
 237
 238 (define-instruction-format (fp-binary 32
 239                             :default-printer '(:name cond :tab fd ", " fn ", " fm))
 240   (cond :field (byte 4 28) :type 'condition-code)
 241   (opc-1 :field (byte 4 24) :value #b1110)
 242   (p :field (byte 1 23))
 243   (q :field (byte 1 21))
 244   (r :field (byte 1 20))
 245   (s :field (byte 1 6))
 246   (fn :fields (list (byte 1 8) (byte 4 16) (byte 1 7)) :type 'float-reg)
 247   (fd :fields (list (byte 1 8) (byte 4 12) (byte 1 22)) :type 'float-reg)
 248   (fm :fields (list (byte 1 8) (byte 4 0) (byte 1 5)) :type 'float-reg)
 249   (opc-2 :field (byte 3 9) :value #b101)
 250   (size :field (byte 1 8))
 251   (opc-3 :field (byte 1 4) :value 0))
 252
 253 (define-instruction-format (fp-unary 32
 254                             :default-printer '(:name cond :tab fd  ", " fm))
 255   (cond :field (byte 4 28) :type 'condition-code)
 256   (opc-1 :field (byte 5 23) :value #b11101)
 257   (opc-2 :field (byte 2 20) :value #b11)
 258   (opc :field (byte 4 16))
 259   (fd :fields (list (byte 1 8) (byte 4 12) (byte 1 22)) :type 'float-reg)
 260   (fm :fields (list (byte 1 8) (byte 4 0) (byte 1 5)) :type 'float-reg)
 261   (opc-3 :field (byte 3 9) :value #b101)
 262   (size :field (byte 1 8))
 263   (n :field (byte 1 7))
 264   (s :field (byte 1 6) :value 1)
 265   (opc-4 :field (byte 1 4) :value 0))
 266
 267 (define-instruction-format (fp-unary-one-op 32
 268                             :default-printer '(:name cond :tab fd))
 269   (cond :field (byte 4 28) :type 'condition-code)
 270   (opc-1 :field (byte 5 23) :value #b11101)
 271   (opc-2 :field (byte 2 20) :value #b11)
 272   (opc :field (byte 4 16))
 273   (fd :fields (list (byte 1 8) (byte 4 12) (byte 1 22)) :type 'float-reg)
 274   (fm :fields (list (byte 1 8) (byte 4 0) (byte 1 5)) :type 'float-reg)
 275   (opc-3 :field (byte 3 9) :value #b101)
 276   (size :field (byte 1 8))
 277   (n :field (byte 1 7))
 278   (s :field (byte 1 6) :value 1)
 279   (sbz :field (byte 6 0) :value 0))
 280
 281 (define-instruction-format (fp-srt 32)
 282   (cond :field (byte 4 28) :type 'condition-code)
 283   (opc-1 :field (byte 4 24) :value #b1110)
 284   (opc :field (byte 3 21))
 285   (l :field (byte 1 20))
 286   (fn :fields (list (byte 1 8) (byte 1 7) (byte 4 16)) :type 'float-reg)
 287   (rd :field (byte 4 12)  :type 'reg)
 288   (opc-3 :field (byte 3 9) :value #b101)
 289   (size :field (byte 1 8))
 290   (opc-4 :field (byte 7 0) :value #b0010000))
 291
 292 (define-instruction-format (fp-srt-sys 32)
 293   (cond :field (byte 4 28) :type 'condition-code)
 294   (opc-1 :field (byte 4 24) :value #b1110)
 295   (opc :field (byte 3 21))
 296   (l :field (byte 1 20))
 297   (fn :field (byte 4 16) :type 'float-sys-reg)
 298   (rd :field (byte 4 12)  :type 'reg)
 299   (opc-3 :field (byte 3 9) :value #b101)
 300   (opc-4 :field (byte 8 0) :value #b00010000))
 301
 302 (define-instruction-format (fp-trt 32)
 303   (cond :field (byte 4 28) :type 'condition-code)
 304   (opc-1 :field (byte 7 21) :value #b1100010)
 305   (l :field (byte 1 20))
 306   (rn :field (byte 4 16)  :type 'reg)
 307   (rd :field (byte 4 12)  :type 'reg)
 308   (opc-2 :field (byte 3 9) :value #b101)
 309   (size :field (byte 1 8))
 310   (opc-3 :field (byte 2 6) :value 0)
 311   (fm :fields (list (byte 1 8) (byte 4 0) (byte 1 5)) :type 'float-reg)
 312   (opc-4 :field (byte 1 4) :value 1))
 313
 314 (define-instruction-format (conditional 32 :default-printer '(:name cond))
 315   (cond :field (byte 4 28) :type 'condition-code)
 316   (op :field (byte 28 0)))
 317 \f
 318 ;;;; primitive emitters
 319
 320 ;(define-bitfield-emitter emit-word 16
 321 ;  (byte 16 0))
 322
 323 (define-bitfield-emitter emit-word 32
 324   (byte 32 0))
 325 \f
 326 ;;;; fixup emitters
 327 #|
 328 (defun emit-absolute-fixup (segment fixup)
 329   (note-fixup segment :absolute fixup)
 330   (let ((offset (fixup-offset fixup)))
 331     (if (label-p offset)
 332         (emit-back-patch segment
 333                          4 ; FIXME: n-word-bytes
 334                          (lambda (segment posn)
 335                            (declare (ignore posn))
 336                            (emit-dword segment
 337                                        (- (+ (component-header-length)
 338                                              (or (label-position offset)
 339                                                  0))
 340                                           other-pointer-lowtag))))
 341         (emit-dword segment (or offset 0)))))
 342
 343 (defun emit-relative-fixup (segment fixup)
 344   (note-fixup segment :relative fixup)
 345   (emit-dword segment (or (fixup-offset fixup) 0)))
 346 |#
 347 \f
 348 ;;;; miscellaneous hackery
 349
 350 (defun register-p (thing)
 351   (and (tn-p thing)
 352        (eq (sb-name (sc-sb (tn-sc thing))) 'registers)))
 353
 354 (defmacro with-condition-defaulted ((argvar arglist) &body body)
 355   (let ((internal-emitter (gensym)))
 356     `(flet ((,internal-emitter ,arglist
 357               ,@body))
 358        (if (assoc (car ,argvar) +conditions+)
 359            (apply #',internal-emitter ,argvar)
 360            (apply #',internal-emitter :al ,argvar)))))
 361
 362 (define-instruction byte (segment byte)
 363   (:emitter
 364    (emit-byte segment byte)))
 365
 366 ;(define-instruction word (segment word)
 367 ;  (:emitter
 368 ;   (emit-word segment word)))
 369
 370 (define-instruction word (segment word)
 371   (:emitter
 372    (etypecase word
 373      (fixup
 374       (note-fixup segment :absolute word)
 375       (emit-word segment 0))
 376      (integer
 377       (emit-word segment word)))))
 378
 379 (defun emit-header-data (segment type)
 380   (emit-back-patch segment
 381                    4
 382                    (lambda (segment posn)
 383                      (emit-word segment
 384                                 (logior type
 385                                         (ash (+ posn
 386                                                 (component-header-length))
 387                                              (- n-widetag-bits
 388                                                 word-shift)))))))
 389
 390 (define-instruction simple-fun-header-word (segment)
 391   (:emitter
 392    (emit-header-data segment simple-fun-widetag)))
 393
 394 (define-instruction lra-header-word (segment)
 395   (:emitter
 396    (emit-header-data segment return-pc-widetag)))
 397 \f
 398 ;;;; Addressing mode 1 support
 399
 400 ;;; Addressing mode 1 has some 11 formats.  These are immediate,
 401 ;;; register, and nine shift/rotate functions based on one or more
 402 ;;; registers.  As the mnemonics used for these functions are not
 403 ;;; currently used, we simply define them as constructors for a
 404 ;;; shifter-operand structure, similar to the make-ea function in the
 405 ;;; x86 backend.
 406
 407 (defstruct shifter-operand
 408   register
 409   function-code
 410   operand)
 411
 412 (defun lsl (register operand)
 413   (aver (register-p register))
 414   (aver (or (register-p operand)
 415             (typep operand '(integer 0 31))))
 416
 417   (make-shifter-operand :register register :function-code 0 :operand operand))
 418
 419 (defun lsr (register operand)
 420   (aver (register-p register))
 421   (aver (or (register-p operand)
 422             (typep operand '(integer 1 32))))
 423
 424   (make-shifter-operand :register register :function-code 1 :operand operand))
 425
 426 (defun asr (register operand)
 427   (aver (register-p register))
 428   (aver (or (register-p operand)
 429             (typep operand '(integer 1 32))))
 430
 431   (make-shifter-operand :register register :function-code 2 :operand operand))
 432
 433 (defun ror (register operand)
 434   ;; ROR is a special case: the encoding for ROR with an immediate
 435   ;; shift of 32 (0) is actually RRX.
 436   (aver (register-p register))
 437   (aver (or (register-p operand)
 438             (typep operand '(integer 1 31))))
 439
 440   (make-shifter-operand :register register :function-code 3 :operand operand))
 441
 442 (defun rrx (register)
 443   ;; RRX is a special case: it is encoded as ROR with an immediate
 444   ;; shift of 32 (0), and has no operand.
 445   (aver (register-p register))
 446   (make-shifter-operand :register register :function-code 3 :operand 0))
 447
 448 (define-condition cannot-encode-immediate-operand (error)
 449   ((value :initarg :value)))
 450
 451 (defun encodable-immediate (operand)
 452   ;; 32-bit immediate data is encoded as an 8-bit immediate data value
 453   ;; and a 4-bit immediate shift count.  The actual value is the
 454   ;; immediate data rotated right by a number of bits equal to twice
 455   ;; the shift count.  Note that this means that there are a limited
 456   ;; number of valid immediate integers and that some integers have
 457   ;; multiple possible encodings.  In the case of multiple encodings,
 458   ;; the correct one to use is the one with the lowest shift count.
 459   ;;
 460   ;; XXX: Is it possible to determine the correct encoding in constant
 461   ;; time, rather than time proportional to the final shift count?  Is
 462   ;; it possible to determine if a given integer is valid without
 463   ;; attempting to encode it?  Are such solutions cheaper (either time
 464   ;; or spacewise) than simply attempting to encode it?
 465   (labels ((try-immediate-encoding (value shift)
 466              (unless (<= 0 shift 15)
 467                (return-from encodable-immediate))
 468              (if (typep value '(unsigned-byte 8))
 469                  (dpb shift (byte 4 8) value)
 470                  (try-immediate-encoding (dpb value (byte 30 2)
 471                                               (ldb (byte 2 30) value))
 472                                          (1+ shift)))))
 473     (try-immediate-encoding operand 0)))
 474
 475 (defun encode-shifter-immediate (operand)
 476   (or
 477    (encodable-immediate operand)
 478    (error 'cannot-encode-immediate-operand :value operand)))
 479
 480 (defun encode-shifter-operand (operand)
 481   (etypecase operand
 482     (integer
 483      (dpb 1 (byte 1 25) (encode-shifter-immediate operand)))
 484
 485     (tn
 486      (cond
 487        ((eq 'registers (sb-name (sc-sb (tn-sc operand))))
 488         ;; For those wondering, this is LSL immediate for 0 bits.
 489         (tn-offset operand))
 490
 491        ((eq 'null (sc-name (tn-sc operand)))
 492         null-offset)
 493
 494        (t (error "Don't know how to encode TN ~A as a SHIFTER-OPERAND" operand))))
 495
 496     (shifter-operand
 497      (let ((Rm (tn-offset (shifter-operand-register operand)))
 498            (shift-code (shifter-operand-function-code operand))
 499            (shift-amount (shifter-operand-operand operand)))
 500        (etypecase shift-amount
 501          (integer
 502           (dpb shift-amount (byte 5 7)
 503                (dpb shift-code (byte 2 5)
 504                     Rm)))
 505          (tn
 506           (dpb (tn-offset shift-amount) (byte 4 8)
 507                (dpb shift-code (byte 2 5)
 508                     (dpb 1 (byte 1 4)
 509                          Rm)))))))))
 510
 511 (defun lowest-set-bit-index (integer-value)
 512   (max 0 (1- (integer-length (logand integer-value (- integer-value))))))
 513
 514 ;; FIXME: it would be idiomatic to use (DEFINE-INSTRUCTION-MACRO COMPOSITE ...)
 515 ;; instead of exporting another instruction-generating macro into SB!VM.
 516 ;; An invocation would resemble (INST COMPOSITE {ADD|SUB|whatever| ARGS ...)
 517 (defmacro composite-immediate-instruction (op r x y &key fixnumize neg-op invert-y invert-r single-op-op first-op first-no-source)
 518   ;; Successively applies 8-bit wide chunks of Y to X using OP storing the result in R.
 519   ;;
 520   ;; If FIXNUMIZE is true, Y is fixnumized before being used.
 521   ;; If NEG-OP is given and Y is negative, NEG-OP is used instead of OP.
 522   ;; If INVERT-Y is given LOGNOT is applied to Y before it being used (but after possibly
 523   ;; being fixnumized.
 524   ;; If INVERT-R is given R is bit wise inverted at the end.
 525   ;; If SINGLE-OP-OP is given and (possibly fixnumized) Y fits into a single ARM immediate
 526   ;; it is used for a single operation instead of OP.
 527   ;; If FIRST-OP is given, it is used in the first iteration instead of OP.
 528   ;; If FIRST-NO-SOURCE is given, there will be ne source register (X) in the first iteration.
 529   (let ((bytespec (gensym "bytespec"))
 530         (value (gensym "value"))
 531         (transformed (gensym "transformed")))
 532     (labels ((instruction (source-reg op neg-op &optional no-source)
 533                `(,@(if neg-op
 534                         `((if (< ,y 0)
 535                               (inst ,neg-op ,r ,@(when (not no-source)`(,source-reg))
 536                                     (mask-field ,bytespec ,value))
 537                               (inst ,op ,r ,@(when (not no-source) `(,source-reg))
 538                                     (mask-field ,bytespec ,value))))
 539                         `((inst ,op ,r ,@(when (not no-source) `(,source-reg))
 540                                 (mask-field ,bytespec ,value))))
 541                   (setf (ldb ,bytespec ,value) 0)))
 542              (composite ()
 543                `((let ((,bytespec (byte 8 (logandc1 1 (lowest-set-bit-index ,value)))))
 544                     ,@(instruction x (or first-op op) neg-op first-no-source))
 545                   (do ((,bytespec (byte 8 (logandc1 1 (lowest-set-bit-index ,value)))
 546                                   (byte 8 (logandc1 1 (lowest-set-bit-index ,value)))))
 547                       ((zerop ,value))
 548                     ,@(instruction r op neg-op)
 549                     ,@(when invert-r
 550                             `((inst mvn ,r ,r)))))))
 551       `(let* ((,transformed ,(if fixnumize
 552                                  `(fixnumize ,y)
 553                                  `,y))
 554               (,value (ldb (byte 32 0)
 555                            ,@(if neg-op
 556                                  `((if (< ,transformed 0) (- ,transformed) ,transformed))
 557                                  (if invert-y
 558                                      `((lognot ,transformed))
 559                                      `(,transformed))))))
 560          ,@(if single-op-op
 561               `((handler-case
 562                     (progn
 563                       (inst ,single-op-op ,r ,x ,transformed))
 564                   (cannot-encode-immediate-operand ()
 565                     ,@(composite))))
 566               (composite))))))
 567
 568 \f
 569 ;;;; Addressing mode 2 support
 570
 571 ;;; Addressing mode 2 ostensibly has 9 formats.  These are formed from
 572 ;;; a cross product of three address calculations and three base
 573 ;;; register writeback modes.  As one of the address calculations is a
 574 ;;; scaled register calculation identical to the mode 1 register shift
 575 ;;; by constant, we reuse the shifter-operand structure and its public
 576 ;;; constructors.
 577
 578 (defstruct memory-operand
 579   base
 580   offset
 581   direction
 582   mode)
 583
 584 ;;; The @ macro is used to encode a memory addressing mode.  The
 585 ;;; parameters for the base form are a base register, an optional
 586 ;;; offset (either an integer, a register tn or a shifter-operand
 587 ;;; structure with a constant shift amount, optionally within a unary
 588 ;;; - form), and a base register writeback mode (either :offset,
 589 ;;; :pre-index, or :post-index).  The alternative form uses a label as
 590 ;;; the base register, and accepts only (optionally negated) integers
 591 ;;; as offsets, and requires a mode of :offset.
 592 (defun %@ (base offset direction mode)
 593   (when (label-p base)
 594     (aver (eq mode :offset))
 595     (aver (integerp offset)))
 596
 597   (when (shifter-operand-p offset)
 598     (aver (integerp (shifter-operand-operand offset))))
 599
 600   ;; Fix up direction with negative offsets.
 601   (when (and (not (label-p base))
 602              (integerp offset)
 603              (< offset 0))
 604     (setf offset (- offset))
 605     (setf direction (if (eq direction :up) :down :up)))
 606
 607   (make-memory-operand :base base :offset offset
 608                        :direction direction :mode mode))
 609
 610 (defmacro @ (base &optional (offset 0) (mode :offset))
 611   (let* ((direction (if (and (consp offset)
 612                              (eq (car offset) '-)
 613                              (null (cddr offset)))
 614                         :down
 615                         :up))
 616          (offset (if (eq direction :down) (cadr offset) offset)))
 617     `(%@ ,base ,offset ,direction ,mode)))
 618 \f
 619 ;;;; Data-processing instructions
 620
 621 ;;; Data processing instructions have a 4-bit opcode field and a 1-bit
 622 ;;; "S" field for updating condition bits.  They are adjacent, so we
 623 ;;; roll them into one 5-bit field for convenience.
 624
 625 (define-bitfield-emitter emit-dp-instruction 32
 626   (byte 4 28) (byte 2 26) (byte 1 25) (byte 5 20)
 627   (byte 4 16) (byte 4 12) (byte 12 0))
 628
 629 ;;; There are 16 data processing instructions, with a breakdown as
 630 ;;; follows:
 631 ;;;
 632 ;;;   1.) Two "move" instructions, with no "source" operand (they have
 633 ;;;       destination and shifter operands only).
 634 ;;;
 635 ;;;   2.) Four "test" instructions, with no "destination" operand.
 636 ;;;       These instructions always have their "S" bit set, though it
 637 ;;;       is not specified in their mnemonics.
 638 ;;;
 639 ;;;   3.) Ten "normal" instructions, with all three operands.
 640 ;;;
 641 ;;; Aside from this, the instructions all have a regular encoding, so
 642 ;;; we can use a single macro to define them.
 643
 644 (defmacro define-data-processing-instruction (instruction opcode dest-p src-p)
 645   `(define-instruction ,instruction (segment &rest args)
 646      (:printer dp-shift-immediate ((opcode-8 ,opcode)
 647                                    ,@(unless dest-p '((rd 0)))
 648                                    ,@(unless src-p '((rn 0))))
 649                ,@(cond
 650                   ((not dest-p)
 651                    '('(:name cond :tab rn ", " rm shift)))
 652                   ((not src-p)
 653                    '('(:name cond :tab rd ", " rm shift)))))
 654      (:printer dp-shift-register ((opcode-8 ,opcode)
 655                                   ,@(unless dest-p '((rd 0)))
 656                                   ,@(unless src-p '((rn 0))))
 657                ,@(cond
 658                   ((not dest-p)
 659                    '('(:name cond :tab rn ", " rm ", " shift-type " " rs)))
 660                   ((not src-p)
 661                    '('(:name cond :tab rd ", " rm ", " shift-type " " rs)))))
 662      (:printer dp-immediate ((opcode-8 ,(logior opcode #x20))
 663                              ,@(unless dest-p '((rd 0)))
 664                              ,@(unless src-p '((rn 0))))
 665                ,@(cond
 666                   ((not dest-p)
 667                    '('(:name cond :tab rn ", " immediate)))
 668                   ((not src-p)
 669                    '('(:name cond :tab rd ", " immediate)))))
 670      (:emitter
 671       (with-condition-defaulted (args (condition ,@(if dest-p '(dest))
 672                                                  ,@(if src-p '(src))
 673                                                  shifter-operand))
 674         ,(if dest-p '(aver (register-p dest)))
 675         ,(if src-p '(aver (register-p src)))
 676         (let ((shifter-operand (encode-shifter-operand shifter-operand)))
 677           (emit-dp-instruction segment
 678                                (conditional-opcode condition)
 679                                0
 680                                (ldb (byte 1 25) shifter-operand)
 681                                ,opcode
 682                                ,(if src-p '(tn-offset src) 0)
 683                                ,(if dest-p '(tn-offset dest) 0)
 684                                (ldb (byte 12 0) shifter-operand)))))))
 685
 686 (define-data-processing-instruction and  #x00 t t)
 687 (define-data-processing-instruction ands #x01 t t)
 688 (define-data-processing-instruction eor  #x02 t t)
 689 (define-data-processing-instruction eors #x03 t t)
 690 (define-data-processing-instruction sub  #x04 t t)
 691 (define-data-processing-instruction subs #x05 t t)
 692 (define-data-processing-instruction rsb  #x06 t t)
 693 (define-data-processing-instruction rsbs #x07 t t)
 694 (define-data-processing-instruction add  #x08 t t)
 695 (define-data-processing-instruction adds #x09 t t)
 696 (define-data-processing-instruction adc  #x0a t t)
 697 (define-data-processing-instruction adcs #x0b t t)
 698 (define-data-processing-instruction sbc  #x0c t t)
 699 (define-data-processing-instruction sbcs #x0d t t)
 700 (define-data-processing-instruction rsc  #x0e t t)
 701 (define-data-processing-instruction rscs #x0f t t)
 702 (define-data-processing-instruction orr  #x18 t t)
 703 (define-data-processing-instruction orrs #x19 t t)
 704 (define-data-processing-instruction bic  #x1c t t)
 705 (define-data-processing-instruction bics #x1d t t)
 706
 707 (define-data-processing-instruction tst  #x11 nil t)
 708 (define-data-processing-instruction teq  #x13 nil t)
 709 (define-data-processing-instruction cmp  #x15 nil t)
 710 (define-data-processing-instruction cmn  #x17 nil t)
 711
 712 (define-data-processing-instruction mov  #x1a t nil)
 713 (define-data-processing-instruction movs #x1b t nil)
 714 (define-data-processing-instruction mvn  #x1e t nil)
 715 (define-data-processing-instruction mvns #x1f t nil)
 716 \f
 717 ;;;; Exception-generating instructions
 718
 719 ;;; There are two exception-generating instructions.  One, BKPT, is
 720 ;;; ostensibly used as a breakpoint instruction, and to communicate
 721 ;;; with debugging hardware.  The other, SWI, is intended for use as a
 722 ;;; system call interface.  We need both because, at least on some
 723 ;;; platforms, the only breakpoint trap that works properly is a
 724 ;;; syscall.
 725
 726 (define-bitfield-emitter emit-swi-instruction 32
 727   (byte 4 28) (byte 4 24) (byte 24 0))
 728
 729 (define-instruction swi (segment &rest args)
 730   (:printer swi ((opcode-4 #b1111)))
 731   (:emitter
 732    (with-condition-defaulted (args (condition code))
 733      (emit-swi-instruction segment
 734                            (conditional-opcode condition)
 735                            #b1111 code))))
 736
 737 (define-bitfield-emitter emit-bkpt-instruction 32
 738   (byte 4 28) (byte 8 20) (byte 12 8) (byte 4 4) (byte 4 0))
 739
 740 (define-instruction bkpt (segment code)
 741   (:emitter
 742    (emit-bkpt-instruction segment #b1110 #b00010010
 743                           (ldb (byte 12 4) code)
 744                           #b0111
 745                           (ldb (byte 4 0) code))))
 746
 747 ;;; It turns out that the Linux kernel decodes this particular
 748 ;;; officially undefined instruction as a single-instruction SIGTRAP
 749 ;;; generation instruction, or breakpoint.
 750 (define-instruction debug-trap (segment)
 751   (:printer debug-trap ((opcode-32 #!+linux #xe7f001f0
 752                                    #!+netbsd #xe7ffdefe))
 753             :default :control #'debug-trap-control)
 754   (:emitter
 755    (emit-word segment #!+linux #xe7f001f0 #!+netbsd #xe7ffdefe)))
 756 \f
 757 ;;;; Miscellaneous arithmetic instructions
 758
 759 (define-bitfield-emitter emit-clz-instruction 32
 760   (byte 4 28) (byte 12 16) (byte 4 12) (byte 8 4) (byte 4 0))
 761
 762 (define-instruction clz (segment &rest args)
 763   (:printer dp-shift-register ((opcode-8 #b00010110)
 764                                (rn #b1111)
 765                                (rs #b1111)
 766                                (shift-type #b00))
 767             '(:name cond :tab rd ", " rm))
 768   (:emitter
 769    (with-condition-defaulted (args (condition dest src))
 770      (aver (register-p dest))
 771      (aver (register-p src))
 772      (emit-clz-instruction segment (conditional-opcode condition)
 773                            #b000101101111
 774                            (tn-offset dest)
 775                            #b11110001
 776                            (tn-offset src)))))
 777 \f
 778 ;;;; Branch instructions
 779
 780 (define-bitfield-emitter emit-branch-instruction 32
 781   (byte 4 28) (byte 4 24) (byte 24 0))
 782
 783 (defun emit-branch-back-patch (segment condition opcode dest)
 784   (emit-back-patch segment 4
 785                    (lambda (segment posn)
 786                      (emit-branch-instruction segment
 787                                               (conditional-opcode condition)
 788                                               opcode
 789                                               (ldb (byte 24 2)
 790                                                    (- (label-position dest)
 791                                                       (+ posn 8)))))))
 792
 793 (define-instruction b (segment &rest args)
 794   (:printer branch ((opcode-4 #b1010)))
 795   (:emitter
 796    (with-condition-defaulted (args (condition dest))
 797      (aver (label-p dest))
 798      (emit-branch-back-patch segment condition #b1010 dest))))
 799
 800 (define-instruction bl (segment &rest args)
 801   (:printer branch ((opcode-4 #b1011)))
 802   (:emitter
 803    (with-condition-defaulted (args (condition dest))
 804      (aver (label-p dest))
 805      (emit-branch-back-patch segment condition #b1011 dest))))
 806
 807 (define-bitfield-emitter emit-branch-exchange-instruction 32
 808   (byte 4 28) (byte 8 20) (byte 4 16) (byte 4 12)
 809   (byte 4 8) (byte 4 4) (byte 4 0))
 810
 811 (define-instruction bx (segment &rest args)
 812   (:printer branch-exchange ((opcode-8 #b00010010)
 813                              (opcode-4 #b0001)))
 814   (:emitter
 815    (with-condition-defaulted (args (condition dest))
 816      (aver (register-p dest))
 817      (emit-branch-exchange-instruction segment
 818                                        (conditional-opcode condition)
 819                                        #b00010010 #b1111 #b1111
 820                                        #b1111 #b0001 (tn-offset dest)))))
 821
 822 (define-instruction blx (segment &rest args)
 823   (:printer branch-exchange ((opcode-8 #b00010010)
 824                              (opcode-4 #b0011)))
 825   (:emitter
 826    (with-condition-defaulted (args (condition dest))
 827      (aver (register-p dest))
 828      (emit-branch-exchange-instruction segment
 829                                        (conditional-opcode condition)
 830                                        #b00010010 #b1111 #b1111
 831                                        #b1111 #b0011 (tn-offset dest)))))
 832 \f
 833 ;;;; Semaphore instructions
 834
 835 (defun emit-semaphore-instruction (segment opcode condition dest value address)
 836   (aver (register-p dest))
 837   (aver (register-p value))
 838   (aver (memory-operand-p address))
 839   (aver (zerop (memory-operand-offset address)))
 840   (aver (eq :offset (memory-operand-mode address)))
 841   (emit-dp-instruction segment (conditional-opcode condition)
 842                        #b00 0 opcode (tn-offset (memory-operand-base address))
 843                        (tn-offset dest)
 844                        (dpb #b1001 (byte 4 4) (tn-offset value))))
 845
 846 (define-instruction swp (segment &rest args)
 847   (:emitter
 848    (with-condition-defaulted (args (condition dest value address))
 849      (emit-semaphore-instruction segment #b10000
 850                                  condition dest value address))))
 851
 852 (define-instruction swpb (segment &rest args)
 853   (:emitter
 854    (with-condition-defaulted (args (condition dest value address))
 855      (emit-semaphore-instruction segment #b10100
 856                                  condition dest value address))))
 857 \f
 858 ;;;; Status-register instructions
 859
 860 (define-instruction mrs (segment &rest args)
 861   (:printer dp-shift-immediate ((opcode-8 #b0010000)
 862                                 (rn #b1111)
 863                                 (shift '(0 0))
 864                                 (rm 0))
 865             '(:name cond :tab rd ", CPSR"))
 866   (:printer dp-shift-immediate ((opcode-8 #b0010100)
 867                                 (rn #b1111)
 868                                 (shift '(0 0))
 869                                 (rm 0))
 870             '(:name cond :tab rd ", SPSR"))
 871   (:emitter
 872    (with-condition-defaulted (args (condition dest reg))
 873      (aver (register-p dest))
 874      (aver (member reg '(:cpsr :spsr)))
 875      (emit-dp-instruction segment (conditional-opcode condition)
 876                           #b00 0 (if (eq reg :cpsr) #b10000 #b10100)
 877                           #b1111 (tn-offset dest) 0))))
 878
 879 (defun encode-status-register-fields (fields)
 880   (let ((fields (string fields)))
 881     (labels ((frob (mask index)
 882                (let* ((field (aref fields index))
 883                       (field-mask (cdr (assoc field
 884                                               '((#\C . #b0001) (#\X . #b0010)
 885                                                 (#\S . #b0100) (#\F . #b1000))
 886                                               :test #'char=))))
 887                  (unless field-mask
 888                    (error "bad status register field desginator ~S" fields))
 889                  (if (< (1+ index) (length fields))
 890                      (frob (logior mask field-mask) (1+ index))
 891                      (logior mask field-mask)))))
 892       (frob 0 0))))
 893
 894 (defmacro cpsr (fields)
 895   (encode-status-register-fields fields))
 896
 897 (defmacro spsr (fields)
 898   (logior #b10000 (encode-status-register-fields fields)))
 899
 900 (define-instruction msr (segment &rest args)
 901   (:printer msr-immediate ())
 902   (:printer msr-register ())
 903   (:emitter
 904    (with-condition-defaulted (args (condition field-mask src))
 905      (aver (or (register-p src)
 906                (integerp src)))
 907      (let ((encoded-src (encode-shifter-operand src)))
 908        (emit-dp-instruction segment (conditional-opcode condition)
 909                             #b00 (ldb (byte 1 25) encoded-src)
 910                             (if (logbitp 4 field-mask) #b10110 #b10010)
 911                             field-mask #b1111
 912                             (ldb (byte 12 0) encoded-src))))))
 913 \f
 914 ;;;; Multiply instructions
 915
 916 (define-bitfield-emitter emit-multiply-instruction 32
 917   (byte 4 28) (byte 8 20) (byte 4 16) (byte 4 12)
 918   (byte 4 8) (byte 4 4) (byte 4 0))
 919
 920 (macrolet
 921     ((define-multiply-instruction (name field-mapping opcode1 opcode2)
 922        (let ((arglist (ecase field-mapping
 923                         (:dzsm '(dest src multiplicand))
 924                         (:dnsm '(dest src multiplicand num))
 925                         (:ddsm '(dest-lo dest src multiplicand)))))
 926          `(define-instruction ,name (segment &rest args)
 927             (:printer ,(symbolicate 'multiply- field-mapping)
 928                       ((opcode-8 ,opcode1)
 929                        (opcode-4 ,opcode2)))
 930             (:emitter
 931              (with-condition-defaulted (args (condition ,@arglist))
 932                ,@(loop
 933                     for arg in arglist
 934                     collect `(aver (register-p ,arg)))
 935                (emit-multiply-instruction segment (conditional-opcode condition)
 936                                           ,opcode1
 937                                           (tn-offset dest)
 938                                           ,(ecase field-mapping
 939                                              (:dzsm 0)
 940                                              (:dnsm '(tn-offset num))
 941                                              (:ddsm '(tn-offset dest-lo)))
 942                                           (tn-offset src)
 943                                           ,opcode2
 944                                           (tn-offset multiplicand))))))))
 945
 946   (define-multiply-instruction mul  :dzsm #b00000000 #b1001)
 947   (define-multiply-instruction muls :dzsm #b00000001 #b1001)
 948   (define-multiply-instruction mla  :dnsm #b00000010 #b1001)
 949   (define-multiply-instruction mlas :dnsm #b00000011 #b1001)
 950
 951   (define-multiply-instruction umull  :ddsm #b00001000 #b1001)
 952   (define-multiply-instruction umulls :ddsm #b00001001 #b1001)
 953   (define-multiply-instruction umlal  :ddsm #b00001010 #b1001)
 954   (define-multiply-instruction umlals :ddsm #b00001011 #b1001)
 955
 956   (define-multiply-instruction smull  :ddsm #b00001100 #b1001)
 957   (define-multiply-instruction smulls :ddsm #b00001101 #b1001)
 958   (define-multiply-instruction smlal  :ddsm #b00001110 #b1001)
 959   (define-multiply-instruction smlals :ddsm #b00001111 #b1001)
 960
 961   (define-multiply-instruction smlabb :dnsm #b00010000 #b1000)
 962   (define-multiply-instruction smlatb :dnsm #b00010000 #b1010)
 963   (define-multiply-instruction smlabt :dnsm #b00010000 #b1100)
 964   (define-multiply-instruction smlatt :dnsm #b00010000 #b1110)
 965
 966   (define-multiply-instruction smlalbb :ddsm #b00010100 #b1000)
 967   (define-multiply-instruction smlaltb :ddsm #b00010100 #b1010)
 968   (define-multiply-instruction smlalbt :ddsm #b00010100 #b1100)
 969   (define-multiply-instruction smlaltt :ddsm #b00010100 #b1110)
 970
 971   (define-multiply-instruction smulbb :dzsm #b00010110 #b1000)
 972   (define-multiply-instruction smultb :dzsm #b00010110 #b1010)
 973   (define-multiply-instruction smulbt :dzsm #b00010110 #b1100)
 974   (define-multiply-instruction smultt :dzsm #b00010110 #b1110)
 975
 976   (define-multiply-instruction smlawb :dnsm #b00010010 #b1000)
 977   (define-multiply-instruction smlawt :dnsm #b00010010 #b1100)
 978
 979   (define-multiply-instruction smulwb :dzsm #b00010010 #b1010)
 980   (define-multiply-instruction smulwt :dzsm #b00010010 #b1110))
 981 \f
 982 ;;;; Load/store instructions
 983
 984 ;;; Emit a load/store instruction.  CONDITION is a condition code
 985 ;;; name, KIND is :load or :store, WIDTH is :word or :byte, DATA is a
 986 ;;; register TN and ADDRESS is either a memory-operand structure or a
 987 ;;; stack TN.
 988 (defun emit-load/store-instruction (segment condition kind width data address)
 989   (flet ((compute-opcode (direction mode)
 990            (let ((opcode-bits '(:load #b00001 :store #b00000
 991                                 :word #b00000 :byte #b00100
 992                                 :up #b01000 :down #b00000
 993                                 :offset #b10000
 994                                 :pre-index #b10010
 995                                 :post-index #b00000)))
 996              (reduce #'logior (list kind width direction mode)
 997                      :key (lambda (value) (getf opcode-bits value))))))
 998     (etypecase address
 999       (memory-operand
1000        (let* ((base (memory-operand-base address))
1001               (offset (memory-operand-offset address))
1002               (direction (memory-operand-direction address))
1003               (mode (memory-operand-mode address))
1004               (cond-bits (conditional-opcode condition)))
1005          (cond
1006            ((label-p base)
1007             (emit-back-patch
1008              segment 4
1009              (lambda (segment posn)
1010                (let* ((label-delta (- (label-position base)
1011                                       (+ posn 8)))
1012                       (offset-delta (if (eq direction :up)
1013                                         offset
1014                                         (- offset)))
1015                       (overall-delta (+ label-delta
1016                                         offset-delta))
1017                       (absolute-delta (abs overall-delta)))
1018                  (aver (typep absolute-delta '(unsigned-byte 12)))
1019                  (emit-dp-instruction segment cond-bits #b01 0
1020                                       (compute-opcode (if (< overall-delta 0)
1021                                                           :down
1022                                                           :up)
1023                                                       mode)
1024                                       pc-offset (tn-offset data)
1025                                       absolute-delta)))))
1026            ((integerp offset)
1027             (aver (typep offset '(unsigned-byte 12)))
1028             (emit-dp-instruction segment cond-bits #b01 0
1029                                  (compute-opcode direction mode)
1030                                  (tn-offset base) (tn-offset data)
1031                                  offset))
1032            (t
1033             (emit-dp-instruction segment cond-bits #b01 1
1034                                  (compute-opcode direction mode)
1035                                  (tn-offset base) (tn-offset data)
1036                                  (encode-shifter-operand offset))))))
1037
1038       #+(or)
1039       (tn
1040        ;; FIXME: This is for stack TN references, and needs must be
1041        ;; implemented.
1042        ))))
1043
1044 (macrolet
1045     ((define-load/store-instruction (name kind width)
1046        `(define-instruction ,name (segment &rest args)
1047           (:printer load/store-immediate ((opcode-3 #b010)
1048                                           (opcode-b ,(ecase width
1049                                                        (:word 0)
1050                                                        (:byte 1)))
1051                                           (opcode-l ,(ecase kind
1052                                                        (:load 1)
1053                                                        (:store 0)))))
1054           (:printer load/store-register ((opcode-3 #b011)
1055                                          (opcode-0 0)
1056                                          (opcode-b ,(ecase width
1057                                                       (:word 0)
1058                                                       (:byte 1)))
1059                                          (opcode-l ,(ecase kind
1060                                                       (:load 1)
1061                                                       (:store 0)))))
1062           (:emitter
1063            (with-condition-defaulted (args (condition reg address))
1064              (aver (or (register-p reg)
1065                        ,@(when (eq :store kind)
1066                                '((and (tn-p reg)
1067                                   (eq 'null (sc-name (tn-sc reg))))))))
1068              (emit-load/store-instruction segment condition
1069                                           ,kind ,width
1070                                           (if (register-p reg) reg null-tn)
1071                                           address))))))
1072   (define-load/store-instruction ldr :load :word)
1073   (define-load/store-instruction ldrb :load :byte)
1074   (define-load/store-instruction str :store :word)
1075   (define-load/store-instruction strb :store :byte))
1076
1077 ;;; Emit a miscellaneous load/store instruction.  CONDITION is a
1078 ;;; condition code name, OPCODE1 is the low bit of the first opcode
1079 ;;; field, OPCODE2 is the second opcode field, DATA is a register TN
1080 ;;; and ADDRESS is either a memory-operand structure or a stack TN.
1081 (defun emit-misc-load/store-instruction (segment condition opcode1
1082                                          opcode2 data address)
1083   (flet ((compute-opcode (kind direction mode)
1084            (let ((opcode-bits '(:register #b00000 :immediate #b00100
1085                                 :up #b01000 :down #b00000
1086                                 :offset #b10000
1087                                 :pre-index #b10010
1088                                 :post-index #b00000)))
1089              (reduce #'logior (list kind direction mode)
1090                      :key (lambda (value) (getf opcode-bits value))))))
1091     (etypecase address
1092       (memory-operand
1093        (let* ((base (memory-operand-base address))
1094               (offset (memory-operand-offset address))
1095               (direction (memory-operand-direction address))
1096               (mode (memory-operand-mode address))
1097               (cond-bits (conditional-opcode condition)))
1098          (cond
1099            ((label-p base)
1100             (emit-back-patch
1101              segment 4
1102              (lambda (segment posn)
1103                (let* ((label-delta (- (label-position base)
1104                                       (+ posn 8)))
1105                       (offset-delta (if (eq direction :up)
1106                                         offset
1107                                         (- offset)))
1108                       (overall-delta (+ label-delta
1109                                         offset-delta))
1110                       (absolute-delta (abs overall-delta)))
1111                  (aver (typep absolute-delta '(unsigned-byte 8)))
1112                  (emit-multiply-instruction segment cond-bits
1113                                             (logior opcode1
1114                                                     (compute-opcode :immedaite
1115                                                                     (if (< overall-delta 0)
1116                                                                         :down
1117                                                                         :up)
1118                                                                     mode))
1119                                             (tn-offset base) (tn-offset data)
1120                                             (ldb (byte 4 4) absolute-delta)
1121                                             opcode2 absolute-delta)))))
1122            ((integerp offset)
1123             (aver (typep offset '(unsigned-byte 8)))
1124             (emit-multiply-instruction segment cond-bits
1125                                        (logior opcode1
1126                                                (compute-opcode :immediate direction mode))
1127                                        (tn-offset base) (tn-offset data)
1128                                        (ldb (byte 4 4) offset)
1129                                        opcode2 offset))
1130            ((register-p offset)
1131             (emit-multiply-instruction segment cond-bits
1132                                        (logior opcode1
1133                                                (compute-opcode :register direction mode))
1134                                        (tn-offset base) (tn-offset data)
1135                                        0 opcode2 (tn-offset offset)))
1136            (t
1137             (error "bad thing for a miscellaneous load/store address ~S"
1138                    address)))))
1139
1140       #+(or)
1141       (tn
1142        ;; FIXME: This is for stack TN references, and needs must be
1143        ;; implemented.
1144        ))))
1145
1146 (macrolet
1147     ((define-misc-load/store-instruction (name opcode1 opcode2 double-width)
1148        `(define-instruction ,name (segment &rest args)
1149           (:emitter
1150            (with-condition-defaulted (args (condition reg address))
1151              (aver (register-p reg))
1152              ,(when double-width '(aver (evenp (tn-offset reg))))
1153              (emit-misc-load/store-instruction segment condition
1154                                                ,opcode1 ,opcode2
1155                                                reg address))))))
1156   (define-misc-load/store-instruction strh 0 #b1011 nil)
1157   (define-misc-load/store-instruction ldrd 0 #b1101 t)
1158   (define-misc-load/store-instruction strd 0 #b1111 t)
1159
1160   (define-misc-load/store-instruction ldrh 1 #b1011 nil)
1161   (define-misc-load/store-instruction ldrsb 1 #b1101 nil)
1162   (define-misc-load/store-instruction ldrsh 1 #b1111 nil))
1163 \f
1164 ;;;; Boxed-object computation instructions (for LRA and CODE)
1165
1166 ;;; Compute the address of a CODE object by parsing the header of a
1167 ;;; nearby LRA or SIMPLE-FUN.
1168 (define-instruction compute-code (segment code lip object-label temp)
1169   (:vop-var vop)
1170   (:emitter
1171    (emit-back-patch
1172     segment 12
1173     (lambda (segment position)
1174       (assemble (segment vop)
1175         ;; Calculate the address of the code component.  This is an
1176         ;; exercise in excess cleverness.  First, we calculate (from
1177         ;; our program counter only) the address of OBJECT-LABEL plus
1178         ;; OTHER-POINTER-LOWTAG.  The extra two words are to
1179         ;; compensate for the offset applied by ARM CPUs when reading
1180         ;; the program counter.
1181         (inst sub lip pc-tn (- ;; The 8 below is the displacement
1182                                ;; from reading the program counter.
1183                                (+ position 8)
1184                                (+ (label-position object-label)
1185                                   other-pointer-lowtag)))
1186         ;; Next, we read the function header.
1187         (inst ldr temp (@ lip (- other-pointer-lowtag)))
1188         ;; And finally we use the header value (a count in words),
1189         ;; plus the fact that the top two bits of the widetag are
1190         ;; clear (SIMPLE-FUN-WIDETAG is #x2A and
1191         ;; RETURN-PC-HEADER-WIDETAG is #x36) to compute the boxed
1192         ;; address of the code component.
1193         (inst sub code lip (lsr temp (- 8 word-shift))))))))
1194
1195 ;;; Compute the address of a nearby LRA object by dead reckoning from
1196 ;;; the location of the current instruction.
1197 (define-instruction compute-lra (segment dest lip lra-label)
1198   (:vop-var vop)
1199   (:emitter
1200    ;; We can compute the LRA in a single instruction if the overall
1201    ;; offset puts it to within an 8-bit displacement.  Otherwise, we
1202    ;; need to load it by parts into LIP until we're down to an 8-bit
1203    ;; displacement, and load the final 8 bits into DEST.  We may
1204    ;; safely presume that an overall displacement may be up to 24 bits
1205    ;; wide (the PPC backend has special provision for branches over 15
1206    ;; bits, which implies that segments can become large, but a 16
1207    ;; megabyte segment (24 bits of displacement) is ridiculous), so we
1208    ;; need to cover a range of up to three octets of displacement.
1209    (labels ((compute-delta (position &optional magic-value)
1210               (- (+ (label-position lra-label
1211                                     (when magic-value position)
1212                                     magic-value)
1213                     other-pointer-lowtag)
1214                  ;; The 8 below is the displacement
1215                  ;; from reading the program counter.
1216                  (+ position 8)))
1217
1218             (load-chunk (segment delta dst src chunk)
1219               (assemble (segment vop)
1220                 (if (< delta 0)
1221                     (inst sub dst src chunk)
1222                     (inst add dst src chunk))))
1223
1224             (three-instruction-emitter (segment position)
1225               (let* ((delta (compute-delta position))
1226                      (absolute-delta (abs delta)))
1227                 (load-chunk segment delta
1228                             lip pc-tn (mask-field (byte 8 16) absolute-delta))
1229                 (load-chunk segment delta
1230                             lip lip (mask-field (byte 8 8) absolute-delta))
1231                 (load-chunk segment delta
1232                             dest lip (mask-field (byte 8 0) absolute-delta))))
1233
1234             (two-instruction-emitter (segment position)
1235               (let* ((delta (compute-delta position))
1236                      (absolute-delta (abs delta)))
1237                 (assemble (segment vop)
1238                   (load-chunk segment delta
1239                               lip pc-tn (mask-field (byte 8 8) absolute-delta))
1240                   (load-chunk segment delta
1241                               dest lip (mask-field (byte 8 0) absolute-delta)))))
1242
1243             (one-instruction-emitter (segment position)
1244               (let* ((delta (compute-delta position))
1245                      (absolute-delta (abs delta)))
1246                 (assemble (segment vop)
1247                   (load-chunk segment delta
1248                               dest pc-tn absolute-delta))))
1249
1250             (two-instruction-maybe-shrink (segment posn magic-value)
1251               (let ((delta (compute-delta posn magic-value)))
1252                 (when (<= (integer-length delta) 8)
1253                   (emit-back-patch segment 4
1254                                    #'one-instruction-emitter)
1255                   t)))
1256
1257             (three-instruction-maybe-shrink (segment posn magic-value)
1258               (let ((delta (compute-delta posn magic-value)))
1259                 (when (<= (integer-length delta) 16)
1260                   (emit-chooser segment 8 2
1261                                 #'two-instruction-maybe-shrink
1262                                 #'two-instruction-emitter)
1263                   t))))
1264      (emit-chooser
1265       ;; We need to emit up to three instructions, which is 12 octets.
1266       ;; This preserves a mere two bits of alignment.
1267       segment 12 2
1268       #'three-instruction-maybe-shrink
1269       #'three-instruction-emitter))))
1270
1271 ;;; Load a register from a "nearby" LABEL by dead reckoning from the
1272 ;;; location of the current instruction.
1273 (define-instruction load-from-label (segment &rest args)
1274   (:vop-var vop)
1275   (:emitter
1276    (with-condition-defaulted (args (condition dest lip label))
1277      ;; We can load the word addressed by a label in a single
1278      ;; instruction if the overall offset puts it to within a 12-bit
1279      ;; displacement.  Otherwise, we need to build an address by parts
1280      ;; into LIP until we're down to a 12-bit displacement, and then
1281      ;; apply the final 12 bits with LDR.  For now, we'll allow up to 20
1282      ;; bits of displacement, as that should be easy to implement, and a
1283      ;; megabyte large code object is already a bit unwieldly.  If
1284      ;; neccessary, we can expand to a 28 bit displacement.
1285      (labels ((compute-delta (position &optional magic-value)
1286                 (- (label-position label
1287                                    (when magic-value position)
1288                                    magic-value)
1289                    ;; The 8 below is the displacement
1290                    ;; from reading the program counter.
1291                    (+ position 8)))
1292
1293               (load-chunk (segment delta dst src chunk)
1294                 (assemble (segment vop)
1295                   (if (< delta 0)
1296                       (inst sub condition dst src chunk)
1297                       (inst add condition dst src chunk))))
1298
1299               (two-instruction-emitter (segment position)
1300                 (let* ((delta (compute-delta position))
1301                        (absolute-delta (abs delta)))
1302                   (assemble (segment vop)
1303                     (load-chunk segment delta
1304                                 lip pc-tn (mask-field (byte 8 12) absolute-delta))
1305                     (inst ldr condition dest (@ lip (mask-field (byte 12 0) delta))))))
1306
1307               (one-instruction-emitter (segment position)
1308                 (let* ((delta (compute-delta position)))
1309                   (assemble (segment vop)
1310                     (inst ldr condition dest (@ pc-tn delta)))))
1311
1312               (two-instruction-maybe-shrink (segment posn magic-value)
1313                 (let ((delta (compute-delta posn magic-value)))
1314                   (when (<= (integer-length delta) 12)
1315                     (emit-back-patch segment 4
1316                                      #'one-instruction-emitter)
1317                     t))))
1318        (emit-chooser
1319         ;; We need to emit up to two instructions, which is 8 octets,
1320         ;; but might wish to emit only one.  This preserves a mere two
1321         ;; bits of alignment.
1322         segment 8 2
1323         #'two-instruction-maybe-shrink
1324         #'two-instruction-emitter)))))
1325
1326 (define-instruction adr (segment code label &optional (offset 0))
1327   (:vop-var vop)
1328   (:emitter
1329    (emit-back-patch
1330     segment 4
1331     (lambda (segment position)
1332       (assemble (segment vop)
1333         (let ((offset (+ (- (label-position label)
1334                             (+ position 8))
1335                          offset)))
1336           (if (plusp offset)
1337               (inst add code pc-tn offset)
1338               (inst sub code pc-tn (- offset)))))))))
1339
1340 ;; data processing floating point instructions
1341 (define-bitfield-emitter emit-fp-dp-instruction 32
1342   (byte 4 28) ; cond
1343   (byte 4 24) ; #b1110
1344   (byte 1 23) ; p
1345   (byte 1 22) ; D
1346   (byte 1 21) ; q
1347   (byte 1 20) ; r
1348   (byte 4 16) ; Fn || extension op
1349   (byte 4 12) ; Fd
1350   (byte 3 9) ; #b101
1351   (byte 1 8) ; double/single precission
1352   (byte 1 7) ; N || extension op
1353   (byte 1 6) ; s
1354   (byte 1 5) ; M
1355   (byte 1 4) ; #b0
1356   (byte 4 0)) ; Fm
1357
1358 (defun low-bit-float-reg (reg-tn)
1359   (logand 1 (tn-offset reg-tn)))
1360
1361 (defun high-bits-float-reg (reg-tn)
1362   (ash (tn-offset reg-tn) -1))
1363
1364 (defmacro define-binary-fp-data-processing-instruction (name precision p q r s)
1365   (let ((precision-flag (ecase precision
1366                           (:single 0)
1367                           (:double 1))))
1368     `(define-instruction ,name (segment &rest args)
1369        (:printer fp-binary ((p ,p)
1370                             (q ,q)
1371                             (r ,r)
1372                             (s ,s)
1373                             (size ,precision-flag)))
1374        (:emitter
1375         (with-condition-defaulted (args (condition dest op-n op-m))
1376           (emit-fp-dp-instruction segment
1377                                   (conditional-opcode condition)
1378                                   #b1110
1379                                   ,p
1380                                   (low-bit-float-reg dest)
1381                                   ,q
1382                                   ,r
1383                                   (high-bits-float-reg op-n)
1384                                   (high-bits-float-reg dest)
1385                                   #b101
1386                                   ,precision-flag
1387                                   (low-bit-float-reg op-n)
1388                                   ,s
1389                                   (low-bit-float-reg op-m)
1390                                   #b0
1391                                   (high-bits-float-reg op-m)))))))
1392
1393 (defmacro define-binary-fp-data-processing-instructions (root p q r s)
1394   `(progn
1395      (define-binary-fp-data-processing-instruction ,(symbolicate root 's) :single ,p ,q ,r ,s)
1396      (define-binary-fp-data-processing-instruction ,(symbolicate root 'd) :double ,p ,q ,r ,s)))
1397
1398 (define-binary-fp-data-processing-instructions fmac  0 0 0 0)
1399 (define-binary-fp-data-processing-instructions fnmac 0 0 0 1)
1400 (define-binary-fp-data-processing-instructions fmsc  0 0 1 0)
1401 (define-binary-fp-data-processing-instructions fnmsc 0 0 1 1)
1402 (define-binary-fp-data-processing-instructions fmul  0 1 0 0)
1403 (define-binary-fp-data-processing-instructions fnmul 0 1 0 1)
1404 (define-binary-fp-data-processing-instructions fadd  0 1 1 0)
1405 (define-binary-fp-data-processing-instructions fsub  0 1 1 1)
1406 (define-binary-fp-data-processing-instructions fdiv  1 0 0 0)
1407
1408 ;;; op-m-sbz means that it should-be-zero, and only one register is supplied.
1409 (defmacro define-unary-fp-data-processing-instruction (name precision fn n
1410                                                        &key op-m-sbz)
1411   (let ((precision-flag (ecase precision
1412                           (:single 0)
1413                           (:double 1))))
1414     `(define-instruction ,name (segment &rest args)
1415        (:printer ,(if op-m-sbz
1416                       'fp-unary-one-op
1417                       'fp-unary)
1418                  ((size ,precision-flag)
1419                   (n ,n)
1420                   (opc ,fn)))
1421        (:emitter
1422         (with-condition-defaulted (args (condition dest
1423                                                    ,@(unless op-m-sbz
1424                                                        '(op-m))))
1425           (emit-fp-dp-instruction segment
1426                                   (conditional-opcode condition)
1427                                   #b1110
1428                                   #b1
1429                                   (low-bit-float-reg dest)
1430                                   #b1
1431                                   #b1
1432                                   ,fn
1433                                   (high-bits-float-reg dest)
1434                                   #b101
1435                                   ,precision-flag
1436                                   ,n
1437                                   #b1
1438                                   ,(if op-m-sbz
1439                                        0
1440                                        '(low-bit-float-reg op-m))
1441                                   #b0
1442                                   ,(if op-m-sbz
1443                                        0
1444                                        '(high-bits-float-reg op-m))))))))
1445
1446 (defmacro define-unary-fp-data-processing-instructions (root fn n &key op-m-sbz)
1447   `(progn
1448      (define-unary-fp-data-processing-instruction ,(symbolicate root 's) :single ,fn ,n
1449        :op-m-sbz ,op-m-sbz)
1450      (define-unary-fp-data-processing-instruction ,(symbolicate root 'd) :double ,fn ,n
1451        :op-m-sbz ,op-m-sbz)))
1452
1453 (define-unary-fp-data-processing-instructions fcpy   #b0000 0)
1454 (define-unary-fp-data-processing-instructions fabs   #b0000 1)
1455 (define-unary-fp-data-processing-instructions fneg   #b0001 0)
1456 (define-unary-fp-data-processing-instructions fsqrt  #b0001 1)
1457 (define-unary-fp-data-processing-instructions fcmp   #b0100 0)
1458 (define-unary-fp-data-processing-instructions fcmpe  #b0100 1)
1459 (define-unary-fp-data-processing-instructions fcmpz  #b0101 0  :op-m-sbz t)
1460 (define-unary-fp-data-processing-instructions fcmpez #b0101 1  :op-m-sbz t)
1461 (define-unary-fp-data-processing-instructions fuito  #b1000 0)
1462 (define-unary-fp-data-processing-instructions fsito  #b1000 1)
1463 (define-unary-fp-data-processing-instructions ftoui  #b1100 0)
1464 (define-unary-fp-data-processing-instructions ftouiz #b1100 1)
1465 (define-unary-fp-data-processing-instructions ftosi  #b1101 0)
1466 (define-unary-fp-data-processing-instructions ftosiz #b1101 1)
1467
1468 (define-unary-fp-data-processing-instruction fcvtds :single #b0111 1)
1469 (define-unary-fp-data-processing-instruction fcvtsd :double #b0111 1)
1470
1471 ;;; Load/Store Float Instructions
1472
1473 (define-bitfield-emitter emit-fp-ls-instruction 32
1474   (byte 4 28) ; cond
1475   (byte 3 25) ; #b110
1476   (byte 1 24) ; P
1477   (byte 1 23) ; U
1478   (byte 1 22) ; D
1479   (byte 1 21) ; W
1480   (byte 1 20) ; L
1481   (byte 4 16) ; Rn
1482   (byte 4 12) ; Fd
1483   (byte 3 9) ; #b101
1484   (byte 1 8) ; double/single precission
1485   (byte 8 0)) ; offset
1486
1487 ;; Define a load/store multiple floating point instruction. PRECISION is
1488 ;; :SINGLE for single precision values and :DOUBLE for double precision values.
1489 ;; DIRECTION has to be either :LOAD or :STORE.
1490 ;; If INC-OFFSET is true, the offset part of the instruction will be incremented by 1
1491 ;; indicating in the double case a load/store unknown instruction.
1492 (defmacro define-load-store-multiple-fp-instruction (name precision direction &optional inc-offset)
1493   (let ((precision-flag (ecase precision
1494                           (:single 0)
1495                           (:double 1)))
1496         (direction-flag (ecase direction
1497                           (:load 1)
1498                           (:store 0))))
1499     `(define-instruction ,name (segment &rest args)
1500        (:emitter
1501         (with-condition-defaulted (args (condition address base-reg reg-count))
1502           (let* ((mode (cond
1503                          ((consp address)
1504                           (cdr address))
1505                          (t :unindexed)))
1506                  (p (ecase mode
1507                       ((:unindexed :increment) 0)
1508                       ((:decrement) 1)))
1509                  (u (ecase mode
1510                       ((:unindexed :increment) 1)
1511                       ((:decrement) 0)))
1512                  (w (ecase mode
1513                       ((:unindexed) 0)
1514                       ((:increment :decrement) 1))))
1515             (emit-fp-ls-instruction segment
1516                                     (conditional-opcode condition)
1517                                     #b110
1518                                     p
1519                                     u
1520                                     (low-bit-float-reg base-reg)
1521                                     w
1522                                     ,direction-flag
1523                                     (tn-offset address)
1524                                     (high-bits-float-reg base-reg)
1525                                     #b101
1526                                     ,precision-flag
1527                                     ,(ecase precision
1528                                        (:single 'reg-count)
1529                                        (:double `(+ (* 2 reg-count)
1530                                                     ,(if inc-offset 1 0)))))))))))
1531
1532 ;; multiple single precision
1533 (define-load-store-multiple-fp-instruction fstms :single :store)
1534 (define-load-store-multiple-fp-instruction fldms :single :load)
1535 ;; multiple double precision
1536 (define-load-store-multiple-fp-instruction fstmd :double :store)
1537 (define-load-store-multiple-fp-instruction fldmd :double :load)
1538 ;; multiple double precision registers of unknown content (needs up to 2 * reg-count + 1 words of space)
1539 (define-load-store-multiple-fp-instruction fstmx :double :store t)
1540 (define-load-store-multiple-fp-instruction fldmx :double :load t)
1541
1542 ;; KLUDGE: this group of pseudo-instructions are fragile (no error
1543 ;; handling for the various ways to mis-use them), have no support for
1544 ;; predication, and use the somewhat-broken interface for the
1545 ;; load-store-multiple-fp instructions above.
1546 (define-instruction-macro load-complex-single (dest memory-operand)
1547   `(inst fldms (memory-operand-base ,memory-operand) ,dest 2))
1548 (define-instruction-macro load-complex-double (dest memory-operand)
1549   `(inst fldmd (memory-operand-base ,memory-operand) ,dest 2))
1550 (define-instruction-macro store-complex-single (src memory-operand)
1551   `(inst fstms (memory-operand-base ,memory-operand) ,src 2))
1552 (define-instruction-macro store-complex-double (src memory-operand)
1553   `(inst fstmd (memory-operand-base ,memory-operand) ,src 2))
1554
1555 ;; Define a load/store one floating point instruction. PRECISION is
1556 ;; :SINGLE for single precision values and :DOUBLE for double precision values.
1557 ;; DIRECTION has to be either :LOAD or :STORE.
1558 (defmacro define-load-store-one-fp-instruction (name precision direction)
1559   (let ((precision-flag (ecase precision
1560                           (:single 0)
1561                           (:double 1)))
1562         (direction-flag (ecase direction
1563                           (:load 1)
1564                           (:store 0))))
1565     `(define-instruction ,name (segment &rest args)
1566        (:emitter
1567         (with-condition-defaulted (args (condition float-reg memory-operand))
1568           (let ((base (memory-operand-base memory-operand))
1569                 (offset (memory-operand-offset memory-operand))
1570                 (direction (memory-operand-direction memory-operand)))
1571             (aver (eq (memory-operand-mode memory-operand) :offset))
1572             (aver (and (integerp offset)
1573                        (zerop (logand offset 3))))
1574             ;; FIXME: Should support LABEL bases.
1575             (aver (tn-p base))
1576             (emit-fp-ls-instruction segment
1577                                     (conditional-opcode condition)
1578                                     #b110
1579                                     1
1580                                     (if (eq direction :up) 1 0)
1581                                     (low-bit-float-reg float-reg)
1582                                     0
1583                                     ,direction-flag
1584                                     (tn-offset base)
1585                                     (high-bits-float-reg float-reg)
1586                                     #b101
1587                                     ,precision-flag
1588                                     (ash offset -2))))))))
1589
1590 (define-load-store-one-fp-instruction fsts :single :store)
1591 (define-load-store-one-fp-instruction flds :single :load)
1592 (define-load-store-one-fp-instruction fstd :double :store)
1593 (define-load-store-one-fp-instruction fldd :double :load)
1594
1595
1596 ;; single register transfer instructions
1597
1598 (define-bitfield-emitter emit-fp-srt-instruction 32
1599   (byte 4 28) ; cond
1600   (byte 4 24) ; #b1110
1601   (byte 3 21) ; opc
1602   (byte 1 20) ; L
1603
1604   (byte 4 16) ; Fn
1605   (byte 4 12) ; Rd
1606   (byte 3 9) ; #b101
1607   (byte 1 8) ; precision
1608
1609   (byte 1 7) ; N
1610   (byte 7 0)) ; #b0010000
1611
1612 (define-bitfield-emitter emit-conditional-instruction 32
1613   (byte 4 28)                           ; cond
1614   (byte 28 0))                          ; op
1615
1616 ;;; This has the same encoding as FMRX R15, FPSCR
1617 (define-instruction fmstat (segment &rest args)
1618   (:printer conditional
1619             ((op #xEF1FA10)))
1620   (:emitter
1621    (with-condition-defaulted (args (condition))
1622      (emit-conditional-instruction  segment
1623                                     (conditional-opcode condition)
1624                                     #xEF1FA10))))
1625
1626 (defun system-reg-encoding (float-reg)
1627   (ecase float-reg
1628     (:fpsid #b0000)
1629     (:fpscr #b0001)
1630     (:fpexc #b1000)))
1631
1632 (defmacro define-single-reg-transfer-fp-instruction (name precision direction opcode &optional system-reg)
1633   (let ((precision-flag (ecase precision
1634                           (:single 0)
1635                           (:double 1)))
1636         (direction-flag (ecase direction
1637                           (:to-arm 1)
1638                           (:from-arm 0))))
1639     `(define-instruction ,name (segment &rest args)
1640        (:printer ,(if system-reg
1641                       'fp-srt-sys
1642                       'fp-srt)
1643                  ((opc ,opcode)
1644                   (l ,direction-flag)
1645                   (size ,precision-flag))
1646                  ',(if (eq direction :to-arm)
1647                       '(:name cond :tab rd ", " fn)
1648                       '(:name cond :tab fn ", " rd)))
1649        (:emitter
1650         (with-condition-defaulted (args (condition ,@(if (eq direction :to-arm)
1651                                                          '(arm-reg float-reg)
1652                                                          '(float-reg arm-reg))))
1653           (emit-fp-srt-instruction segment
1654                                    (conditional-opcode condition)
1655                                    #b1110
1656                                    ,opcode
1657                                    ,direction-flag
1658                                    ,(if system-reg
1659                                         '(system-reg-encoding float-reg)
1660                                         '(high-bits-float-reg float-reg))
1661                                    (tn-offset arm-reg)
1662                                    #b101
1663                                    ,precision-flag
1664                                    ,(if system-reg
1665                                         0
1666                                         '(low-bit-float-reg float-reg))
1667                                    #b0010000))))))
1668
1669 (define-single-reg-transfer-fp-instruction fmsr :single :from-arm #b000)
1670 (define-single-reg-transfer-fp-instruction fmrs :single :to-arm #b000)
1671 (define-single-reg-transfer-fp-instruction fmdlr :double :from-arm #b000)
1672 (define-single-reg-transfer-fp-instruction fmrdl :double :to-arm #b000)
1673 (define-single-reg-transfer-fp-instruction fmdhr :double :from-arm #b001)
1674 (define-single-reg-transfer-fp-instruction fmrdh :double :to-arm #b001)
1675 (define-single-reg-transfer-fp-instruction fmxr :single :from-arm #b111 t)
1676 (define-single-reg-transfer-fp-instruction fmrx :single :to-arm #b111 t)
1677
1678 (define-bitfield-emitter emit-fp-trt-instruction 32
1679   (byte 4 28) ; cond
1680   (byte 7 21) ; #b1100010
1681   (byte 1 20) ; L
1682   (byte 4 16) ; Rn
1683   (byte 4 12) ; Rd
1684   (byte 3 9) ; #b101
1685   (byte 1 8) ; precision
1686   (byte 2 6) ; #b00
1687   (byte 1 5) ; M
1688   (byte 1 4) ; #b1
1689   (byte 4 0)) ; Fm
1690
1691 (defmacro define-two-reg-transfer-fp-instruction (name precision direction)
1692   (let ((precision-flag (ecase precision
1693                           (:single 0)
1694                           (:double 1)))
1695         (direction-flag (ecase direction
1696                           (:to-arm 1)
1697                           (:from-arm 0))))
1698     `(define-instruction ,name (segment &rest args)
1699        (:printer fp-trt
1700                  ((l ,direction-flag)
1701                   (size ,precision-flag))
1702                  ',(if (eq direction :to-arm)
1703                        '(:name cond :tab rd ", " rn ", " fm)
1704                        '(:name cond :tab fm ", " rd ", " rn )))
1705        (:emitter
1706         (with-condition-defaulted (args (condition ,@(if (eq direction :to-arm)
1707                                                          '(arm-reg-1 arm-reg-2 float-reg)
1708                                                          '(float-reg arm-reg-1 arm-reg-2))))
1709           (emit-fp-trt-instruction segment
1710                                    (conditional-opcode condition)
1711                                    #b1100010
1712                                    ,direction-flag
1713                                    (tn-offset arm-reg-2)
1714                                    (tn-offset arm-reg-1)
1715                                    #b101
1716                                    ,precision-flag
1717                                    #b00
1718                                    (low-bit-float-reg float-reg)
1719                                    #b1
1720                                    (high-bits-float-reg float-reg)))))))
1721
1722 (define-two-reg-transfer-fp-instruction fmsrr :single :from-arm)
1723 (define-two-reg-transfer-fp-instruction fmrrs :single :to-arm)
1724 (define-two-reg-transfer-fp-instruction fmdrr :double :from-arm)
1725 (define-two-reg-transfer-fp-instruction fmrrd :double :to-arm)