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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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(define-instruction adr (segment code label &optional (offset 0))
1326  (:vop-var vop)
1327  (:emitter
1328   (emit-back-patch
1329    segment 4
1330    (lambda (segment position)
1331      (assemble (segment vop)
1332        (let ((offset (+ (- (label-position label)
1333                            (+ position 8))
1334                         offset)))
1335          (if (plusp offset)
1336              (inst add code pc-tn offset)
1337              (inst sub code pc-tn (- offset)))))))))
1338
1339;; data processing floating point instructions
1340(define-bitfield-emitter emit-fp-dp-instruction 32
1341  (byte 4 28) ; cond
1342  (byte 4 24) ; #b1110
1343  (byte 1 23) ; p
1344  (byte 1 22) ; D
1345  (byte 1 21) ; q
1346  (byte 1 20) ; r
1347  (byte 4 16) ; Fn || extension op
1348  (byte 4 12) ; Fd
1349  (byte 3 9) ; #b101
1350  (byte 1 8) ; double/single precission
1351  (byte 1 7) ; N || extension op
1352  (byte 1 6) ; s
1353  (byte 1 5) ; M
1354  (byte 1 4) ; #b0
1355  (byte 4 0)) ; Fm
1356
1357(defun low-bit-float-reg (reg-tn)
1358  (logand 1 (tn-offset reg-tn)))
1359
1360(defun high-bits-float-reg (reg-tn)
1361  (ash (tn-offset reg-tn) -1))
1362
1363(defmacro define-binary-fp-data-processing-instruction (name precision p q r s)
1364  (let ((precision-flag (ecase precision
1365                          (:single 0)
1366                          (:double 1))))
1367    `(define-instruction ,name (segment &rest args)
1368       (:printer fp-binary ((p ,p)
1369                            (q ,q)
1370                            (r ,r)
1371                            (s ,s)
1372                            (size ,precision-flag)))
1373       (:emitter
1374        (with-condition-defaulted (args (condition dest op-n op-m))
1375          (emit-fp-dp-instruction segment
1376                                  (conditional-opcode condition)
1377                                  #b1110
1378                                  ,p
1379                                  (low-bit-float-reg dest)
1380                                  ,q
1381                                  ,r
1382                                  (high-bits-float-reg op-n)
1383                                  (high-bits-float-reg dest)
1384                                  #b101
1385                                  ,precision-flag
1386                                  (low-bit-float-reg op-n)
1387                                  ,s
1388                                  (low-bit-float-reg op-m)
1389                                  #b0
1390                                  (high-bits-float-reg op-m)))))))
1391
1392(defmacro define-binary-fp-data-processing-instructions (root p q r s)
1393  `(progn
1394     (define-binary-fp-data-processing-instruction ,(symbolicate root 's) :single ,p ,q ,r ,s)
1395     (define-binary-fp-data-processing-instruction ,(symbolicate root 'd) :double ,p ,q ,r ,s)))
1396
1397(define-binary-fp-data-processing-instructions fmac  0 0 0 0)
1398(define-binary-fp-data-processing-instructions fnmac 0 0 0 1)
1399(define-binary-fp-data-processing-instructions fmsc  0 0 1 0)
1400(define-binary-fp-data-processing-instructions fnmsc 0 0 1 1)
1401(define-binary-fp-data-processing-instructions fmul  0 1 0 0)
1402(define-binary-fp-data-processing-instructions fnmul 0 1 0 1)
1403(define-binary-fp-data-processing-instructions fadd  0 1 1 0)
1404(define-binary-fp-data-processing-instructions fsub  0 1 1 1)
1405(define-binary-fp-data-processing-instructions fdiv  1 0 0 0)
1406
1407;;; op-m-sbz means that it should-be-zero, and only one register is supplied.
1408(defmacro define-unary-fp-data-processing-instruction (name precision fn n
1409                                                       &key op-m-sbz)
1410  (let ((precision-flag (ecase precision
1411                          (:single 0)
1412                          (:double 1))))
1413    `(define-instruction ,name (segment &rest args)
1414       (:printer ,(if op-m-sbz
1415                      'fp-unary-one-op
1416                      'fp-unary)
1417                 ((size ,precision-flag)
1418                  (n ,n)
1419                  (opc ,fn)))
1420       (:emitter
1421        (with-condition-defaulted (args (condition dest
1422                                                   ,@(unless op-m-sbz
1423                                                       '(op-m))))
1424          (emit-fp-dp-instruction segment
1425                                  (conditional-opcode condition)
1426                                  #b1110
1427                                  #b1
1428                                  (low-bit-float-reg dest)
1429                                  #b1
1430                                  #b1
1431                                  ,fn
1432                                  (high-bits-float-reg dest)
1433                                  #b101
1434                                  ,precision-flag
1435                                  ,n
1436                                  #b1
1437                                  ,(if op-m-sbz
1438                                       0
1439                                       '(low-bit-float-reg op-m))
1440                                  #b0
1441                                  ,(if op-m-sbz
1442                                       0
1443                                       '(high-bits-float-reg op-m))))))))
1444
1445(defmacro define-unary-fp-data-processing-instructions (root fn n &key op-m-sbz)
1446  `(progn
1447     (define-unary-fp-data-processing-instruction ,(symbolicate root 's) :single ,fn ,n
1448       :op-m-sbz ,op-m-sbz)
1449     (define-unary-fp-data-processing-instruction ,(symbolicate root 'd) :double ,fn ,n
1450       :op-m-sbz ,op-m-sbz)))
1451
1452(define-unary-fp-data-processing-instructions fcpy   #b0000 0)
1453(define-unary-fp-data-processing-instructions fabs   #b0000 1)
1454(define-unary-fp-data-processing-instructions fneg   #b0001 0)
1455(define-unary-fp-data-processing-instructions fsqrt  #b0001 1)
1456(define-unary-fp-data-processing-instructions fcmp   #b0100 0)
1457(define-unary-fp-data-processing-instructions fcmpe  #b0100 1)
1458(define-unary-fp-data-processing-instructions fcmpz  #b0101 0  :op-m-sbz t)
1459(define-unary-fp-data-processing-instructions fcmpez #b0101 1  :op-m-sbz t)
1460(define-unary-fp-data-processing-instructions fuito  #b1000 0)
1461(define-unary-fp-data-processing-instructions fsito  #b1000 1)
1462(define-unary-fp-data-processing-instructions ftoui  #b1100 0)
1463(define-unary-fp-data-processing-instructions ftouiz #b1100 1)
1464(define-unary-fp-data-processing-instructions ftosi  #b1101 0)
1465(define-unary-fp-data-processing-instructions ftosiz #b1101 1)
1466
1467(define-unary-fp-data-processing-instruction fcvtds :single #b0111 1)
1468(define-unary-fp-data-processing-instruction fcvtsd :double #b0111 1)
1469
1470;;; Load/Store Float Instructions
1471
1472(define-bitfield-emitter emit-fp-ls-instruction 32
1473  (byte 4 28) ; cond
1474  (byte 3 25) ; #b110
1475  (byte 1 24) ; P
1476  (byte 1 23) ; U
1477  (byte 1 22) ; D
1478  (byte 1 21) ; W
1479  (byte 1 20) ; L
1480  (byte 4 16) ; Rn
1481  (byte 4 12) ; Fd
1482  (byte 3 9) ; #b101
1483  (byte 1 8) ; double/single precission
1484  (byte 8 0)) ; offset
1485
1486;; Define a load/store multiple floating point instruction. PRECISION is
1487;; :SINGLE for single precision values and :DOUBLE for double precision values.
1488;; DIRECTION has to be either :LOAD or :STORE.
1489;; If INC-OFFSET is true, the offset part of the instruction will be incremented by 1
1490;; indicating in the double case a load/store unknown instruction.
1491(defmacro define-load-store-multiple-fp-instruction (name precision direction &optional inc-offset)
1492  (let ((precision-flag (ecase precision
1493                          (:single 0)
1494                          (:double 1)))
1495        (direction-flag (ecase direction
1496                          (:load 1)
1497                          (:store 0))))
1498    `(define-instruction ,name (segment &rest args)
1499       (:emitter
1500        (with-condition-defaulted (args (condition address base-reg reg-count))
1501          (let* ((mode (cond
1502                         ((consp address)
1503                          (cdr address))
1504                         (t :unindexed)))
1505                 (p (ecase mode
1506                      ((:unindexed :increment) 0)
1507                      ((:decrement) 1)))
1508                 (u (ecase mode
1509                      ((:unindexed :increment) 1)
1510                      ((:decrement) 0)))
1511                 (w (ecase mode
1512                      ((:unindexed) 0)
1513                      ((:increment :decrement) 1))))
1514            (emit-fp-ls-instruction segment
1515                                    (conditional-opcode condition)
1516                                    #b110
1517                                    p
1518                                    u
1519                                    (low-bit-float-reg base-reg)
1520                                    w
1521                                    ,direction-flag
1522                                    (tn-offset address)
1523                                    (high-bits-float-reg base-reg)
1524                                    #b101
1525                                    ,precision-flag
1526                                    ,(ecase precision
1527                                       (:single 'reg-count)
1528                                       (:double `(+ (* 2 reg-count)
1529                                                    ,(if inc-offset 1 0)))))))))))
1530
1531;; multiple single precision
1532(define-load-store-multiple-fp-instruction fstms :single :store)
1533(define-load-store-multiple-fp-instruction fldms :single :load)
1534;; multiple double precision
1535(define-load-store-multiple-fp-instruction fstmd :double :store)
1536(define-load-store-multiple-fp-instruction fldmd :double :load)
1537;; multiple double precision registers of unknown content (needs up to 2 * reg-count + 1 words of space)
1538(define-load-store-multiple-fp-instruction fstmx :double :store t)
1539(define-load-store-multiple-fp-instruction fldmx :double :load t)
1540
1541;; KLUDGE: this group of pseudo-instructions are fragile (no error
1542;; handling for the various ways to mis-use them), have no support for
1543;; predication, and use the somewhat-broken interface for the
1544;; load-store-multiple-fp instructions above.
1545(define-instruction-macro load-complex-single (dest memory-operand)
1546  `(inst fldms (memory-operand-base ,memory-operand) ,dest 2))
1547(define-instruction-macro load-complex-double (dest memory-operand)
1548  `(inst fldmd (memory-operand-base ,memory-operand) ,dest 2))
1549(define-instruction-macro store-complex-single (src memory-operand)
1550  `(inst fstms (memory-operand-base ,memory-operand) ,src 2))
1551(define-instruction-macro store-complex-double (src memory-operand)
1552  `(inst fstmd (memory-operand-base ,memory-operand) ,src 2))
1553
1554;; Define a load/store one floating point instruction. PRECISION is
1555;; :SINGLE for single precision values and :DOUBLE for double precision values.
1556;; DIRECTION has to be either :LOAD or :STORE.
1557(defmacro define-load-store-one-fp-instruction (name precision direction)
1558  (let ((precision-flag (ecase precision
1559                          (:single 0)
1560                          (:double 1)))
1561        (direction-flag (ecase direction
1562                          (:load 1)
1563                          (:store 0))))
1564    `(define-instruction ,name (segment &rest args)
1565       (:emitter
1566        (with-condition-defaulted (args (condition float-reg memory-operand))
1567          (let ((base (memory-operand-base memory-operand))
1568                (offset (memory-operand-offset memory-operand))
1569                (direction (memory-operand-direction memory-operand)))
1570            (aver (eq (memory-operand-mode memory-operand) :offset))
1571            (aver (and (integerp offset)
1572                       (zerop (logand offset 3))))
1573            ;; FIXME: Should support LABEL bases.
1574            (aver (tn-p base))
1575            (emit-fp-ls-instruction segment
1576                                    (conditional-opcode condition)
1577                                    #b110
1578                                    1
1579                                    (if (eq direction :up) 1 0)
1580                                    (low-bit-float-reg float-reg)
1581                                    0
1582                                    ,direction-flag
1583                                    (tn-offset base)
1584                                    (high-bits-float-reg float-reg)
1585                                    #b101
1586                                    ,precision-flag
1587                                    (ash offset -2))))))))
1588
1589(define-load-store-one-fp-instruction fsts :single :store)
1590(define-load-store-one-fp-instruction flds :single :load)
1591(define-load-store-one-fp-instruction fstd :double :store)
1592(define-load-store-one-fp-instruction fldd :double :load)
1593
1594
1595;; single register transfer instructions
1596
1597(define-bitfield-emitter emit-fp-srt-instruction 32
1598  (byte 4 28) ; cond
1599  (byte 4 24) ; #b1110
1600  (byte 3 21) ; opc
1601  (byte 1 20) ; L
1602
1603  (byte 4 16) ; Fn
1604  (byte 4 12) ; Rd
1605  (byte 3 9) ; #b101
1606  (byte 1 8) ; precision
1607
1608  (byte 1 7) ; N
1609  (byte 7 0)) ; #b0010000
1610
1611(define-bitfield-emitter emit-conditional-instruction 32
1612  (byte 4 28)                           ; cond
1613  (byte 28 0))                          ; op
1614
1615;;; This has the same encoding as FMRX R15, FPSCR
1616(define-instruction fmstat (segment &rest args)
1617  (:printer conditional
1618            ((op #xEF1FA10)))
1619  (:emitter
1620   (with-condition-defaulted (args (condition))
1621     (emit-conditional-instruction  segment
1622                                    (conditional-opcode condition)
1623                                    #xEF1FA10))))
1624
1625(defun system-reg-encoding (float-reg)
1626  (ecase float-reg
1627    (:fpsid #b0000)
1628    (:fpscr #b0001)
1629    (:fpexc #b1000)))
1630
1631(defmacro define-single-reg-transfer-fp-instruction (name precision direction opcode &optional system-reg)
1632  (let ((precision-flag (ecase precision
1633                          (:single 0)
1634                          (:double 1)))
1635        (direction-flag (ecase direction
1636                          (:to-arm 1)
1637                          (:from-arm 0))))
1638    `(define-instruction ,name (segment &rest args)
1639       (:printer ,(if system-reg
1640                      'fp-srt-sys
1641                      'fp-srt)
1642                 ((opc ,opcode)
1643                  (l ,direction-flag)
1644                  (size ,precision-flag))
1645                 ',(if (eq direction :to-arm)
1646                      '(:name cond :tab rd ", " fn)
1647                      '(:name cond :tab fn ", " rd)))
1648       (:emitter
1649        (with-condition-defaulted (args (condition ,@(if (eq direction :to-arm)
1650                                                         '(arm-reg float-reg)
1651                                                         '(float-reg arm-reg))))
1652          (emit-fp-srt-instruction segment
1653                                   (conditional-opcode condition)
1654                                   #b1110
1655                                   ,opcode
1656                                   ,direction-flag
1657                                   ,(if system-reg
1658                                        '(system-reg-encoding float-reg)
1659                                        '(high-bits-float-reg float-reg))
1660                                   (tn-offset arm-reg)
1661                                   #b101
1662                                   ,precision-flag
1663                                   ,(if system-reg
1664                                        0
1665                                        '(low-bit-float-reg float-reg))
1666                                   #b0010000))))))
1667
1668(define-single-reg-transfer-fp-instruction fmsr :single :from-arm #b000)
1669(define-single-reg-transfer-fp-instruction fmrs :single :to-arm #b000)
1670(define-single-reg-transfer-fp-instruction fmdlr :double :from-arm #b000)
1671(define-single-reg-transfer-fp-instruction fmrdl :double :to-arm #b000)
1672(define-single-reg-transfer-fp-instruction fmdhr :double :from-arm #b001)
1673(define-single-reg-transfer-fp-instruction fmrdh :double :to-arm #b001)
1674(define-single-reg-transfer-fp-instruction fmxr :single :from-arm #b111 t)
1675(define-single-reg-transfer-fp-instruction fmrx :single :to-arm #b111 t)
1676
1677(define-bitfield-emitter emit-fp-trt-instruction 32
1678  (byte 4 28) ; cond
1679  (byte 7 21) ; #b1100010
1680  (byte 1 20) ; L
1681  (byte 4 16) ; Rn
1682  (byte 4 12) ; Rd
1683  (byte 3 9) ; #b101
1684  (byte 1 8) ; precision
1685  (byte 2 6) ; #b00
1686  (byte 1 5) ; M
1687  (byte 1 4) ; #b1
1688  (byte 4 0)) ; Fm
1689
1690(defmacro define-two-reg-transfer-fp-instruction (name precision direction)
1691  (let ((precision-flag (ecase precision
1692                          (:single 0)
1693                          (:double 1)))
1694        (direction-flag (ecase direction
1695                          (:to-arm 1)
1696                          (:from-arm 0))))
1697    `(define-instruction ,name (segment &rest args)
1698       (:printer fp-trt
1699                 ((l ,direction-flag)
1700                  (size ,precision-flag))
1701                 ',(if (eq direction :to-arm)
1702                       '(:name cond :tab rd ", " rn ", " fm)
1703                       '(:name cond :tab fm ", " rd ", " rn )))
1704       (:emitter
1705        (with-condition-defaulted (args (condition ,@(if (eq direction :to-arm)
1706                                                         '(arm-reg-1 arm-reg-2 float-reg)
1707                                                         '(float-reg arm-reg-1 arm-reg-2))))
1708          (emit-fp-trt-instruction segment
1709                                   (conditional-opcode condition)
1710                                   #b1100010
1711                                   ,direction-flag
1712                                   (tn-offset arm-reg-2)
1713                                   (tn-offset arm-reg-1)
1714                                   #b101
1715                                   ,precision-flag
1716                                   #b00
1717                                   (low-bit-float-reg float-reg)
1718                                   #b1
1719                                   (high-bits-float-reg float-reg)))))))
1720
1721(define-two-reg-transfer-fp-instruction fmsrr :single :from-arm)
1722(define-two-reg-transfer-fp-instruction fmrrs :single :to-arm)
1723(define-two-reg-transfer-fp-instruction fmdrr :double :from-arm)
1724(define-two-reg-transfer-fp-instruction fmrrd :double :to-arm)
1725