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