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!ARM64-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
18            add-sub-immediate-p fixnum-add-sub-immediate-p
19            negative-add-sub-immediate-p
20            encode-logical-immediate fixnum-encode-logical-immediate
21            ldr-str-offset-encodable ldp-stp-offset-p
22            bic-mask extend lsl lsr asr ror @) 'sb!vm)
23  ;; Imports from SB-VM into this package
24  (import '(sb!vm::*register-names*
25            sb!vm::add-sub-immediate
26            sb!vm::32-bit-reg sb!vm::single-reg sb!vm::double-reg
27            sb!vm::complex-single-reg sb!vm::complex-double-reg
28            sb!vm::tmp-tn sb!vm::zr-tn sb!vm::nsp-offset)))
29
30(setf *disassem-inst-alignment-bytes* 4)
31
32
33(defparameter *conditions*
34  '((:eq . 0)
35    (:ne . 1)
36    (:cs . 2) (:hs . 2)
37    (:cc . 3) (:lo . 3)
38    (:mi . 4)
39    (:pl . 5)
40    (:vs . 6)
41    (:vc . 7)
42    (:hi . 8)
43    (:ls . 9)
44    (:ge . 10)
45    (:lt . 11)
46    (:gt . 12)
47    (:le . 13)
48    (:al . 14)))
49
50(defparameter *condition-name-vec*
51  (let ((vec (make-array 16 :initial-element nil)))
52    (dolist (cond *conditions*)
53      (when (null (aref vec (cdr cond)))
54        (setf (aref vec (cdr cond)) (car cond))))
55    vec))
56
57;;; Set assembler parameters. (In CMU CL, this was done with
58;;; a call to a macro DEF-ASSEMBLER-PARAMS.)
59(eval-when (:compile-toplevel :load-toplevel :execute)
60  (setf *assem-scheduler-p* nil))
61
62(defun conditional-opcode (condition)
63  (cdr (assoc condition *conditions* :test #'eq)))
64
65(defun invert-condition (condition)
66  (aref *condition-name-vec*
67        (logxor 1 (conditional-opcode condition))))
68
69;;;; disassembler field definitions
70
71(defun current-instruction (dstate &optional (offset 0))
72  (sap-ref-int (dstate-segment-sap dstate)
73               (+ (dstate-cur-offs dstate) offset)
74               n-word-bytes
75               (dstate-byte-order dstate)))
76
77(defun 32-bit-register-p (dstate)
78  (not (logbitp 31 (current-instruction dstate))))
79
80(eval-when (:compile-toplevel :load-toplevel :execute)
81  (defun print-shift (value stream dstate)
82    (declare (ignore dstate))
83    (destructuring-bind (kind amount) value
84      (when (plusp amount)
85        (princ ", " stream)
86        (princ (ecase kind
87                 (#b00 "LSL")
88                 (#b01 "LSR")
89                 (#b10 "ASR")
90                 (#b11 "ROR"))
91               stream)
92        (format stream " #~d" amount))))
93
94  (defun print-wide-shift (value stream dstate)
95    (declare (ignore dstate))
96    (when (plusp value)
97      (format stream ", LSL #~d" (* value 16))))
98
99  (defun print-2-bit-shift (value stream dstate)
100    (declare (ignore dstate))
101    (when (= value 1)
102      (princ ", LSL #12" stream)))
103
104  (defun print-extend (value stream dstate)
105    (destructuring-bind (kind amount) value
106      (let* ((inst (current-instruction dstate))
107             (rd (ldb (byte 5 0) inst))
108             (rn (ldb (byte 5 5) inst)))
109        (princ ", " stream)
110        (princ (if (and (= kind #b011)
111                        (or (= rd nsp-offset)
112                            (= rn nsp-offset)))
113                   "LSL"
114                   (ecase kind
115                     (#b000 "UXTB")
116                     (#b001 "UXTH")
117                     (#b010 "UXTW")
118                     (#b011 "UXTX")
119                     (#b100 "SXTB")
120                     (#b101 "SXTH")
121                     (#b110 "SXTW")
122                     (#b111 "SXTX")))
123               stream))
124      (when (plusp amount)
125        (format stream " #~d" amount))))
126
127  (defun print-ldr-str-extend (value stream dstate)
128    (declare (ignore dstate))
129    (destructuring-bind (kind amount) value
130      (unless (and (= kind #b011)
131                   (zerop amount))
132        (princ ", " stream)
133        (princ (ecase kind
134                 (#b010 "UXTW")
135                 (#b011 "LSL")
136                 (#b110 "SXTW")
137                 (#b111 "SXTX"))
138               stream))
139      (when (plusp amount)
140        (princ " #3" stream))))
141
142  (defun print-immediate (value stream dstate)
143    (declare (ignore dstate))
144    (format stream "#~D" value))
145
146  (defun print-test-branch-immediate (value stream dstate)
147    (declare (ignore dstate))
148    (format stream "#~D"
149            (dpb (car value) (byte 1 5) (car value))))
150
151  (defun decode-scaled-immediate (value)
152    (destructuring-bind (size opc value simd) value
153      (if (= simd 1)
154          (ash value (logior (ash opc 2) size))
155          (ash value size))))
156
157  (defun print-scaled-immediate (value stream dstate)
158    (declare (ignore dstate))
159    (format stream "#~D" (if (consp value)
160                             (decode-scaled-immediate value)
161                             (ash value 3))))
162
163  (defun print-logical-immediate (value stream dstate)
164    (declare (ignore dstate))
165    (format stream "#~D" (apply #'decode-logical-immediate value)))
166
167  (defun print-imm-writeback (value stream dstate)
168    (declare (ignore dstate))
169    (destructuring-bind (imm mode) value
170      (let ((imm (sign-extend imm 9)))
171        (if (zerop imm)
172            (princ "]" stream)
173            (ecase mode
174              (#b00
175               (format stream ", #~D]" imm))
176              (#b01
177               (format stream "], #~D" imm))
178              (#b11
179               (format stream ", #~D]!" imm)))))))
180
181  (defun decode-pair-scaled-immediate (opc value simd)
182    (ash (sign-extend value 7)
183         (+ 2 (ash opc (- (logxor 1 simd))))))
184
185  (defun print-pair-imm-writeback (value stream dstate)
186    (declare (ignore dstate))
187    (destructuring-bind (mode &rest imm) value
188      (let ((imm (apply #'decode-pair-scaled-immediate imm)))
189        (if (zerop imm)
190            (princ "]" stream)
191            (ecase mode
192              (#b01
193               (format stream "], #~D" imm))
194              (#b10
195               (format stream ", #~D]" imm))
196              (#b11
197               (format stream ", #~D]!" imm)))))))
198
199  (defun print-w-reg (value stream dstate)
200    (declare (ignore dstate))
201    (princ "W" stream)
202    (princ (aref *register-names* value) stream))
203
204  (defun print-x-reg (value stream dstate)
205    (declare (ignore dstate))
206    (princ (aref *register-names* value) stream))
207
208  (defun print-reg (value stream dstate)
209    (when (32-bit-register-p dstate)
210      (princ "W" stream))
211    (princ (aref *register-names* value) stream))
212
213  (defun print-x-reg-sp (value stream dstate)
214    (declare (ignore dstate))
215    (if (= value nsp-offset)
216        (princ "NSP" stream)
217        (princ (aref *register-names* value) stream)))
218
219  (defun print-reg-sp (value stream dstate)
220    (when (32-bit-register-p dstate)
221      (princ "W" stream))
222    (if (= value nsp-offset)
223        (princ "NSP" stream)
224        (princ (aref *register-names* value) stream)))
225
226  (defun print-reg-float-reg (value stream dstate)
227    (let* ((inst (current-instruction dstate))
228           (v (ldb (byte 1 26) inst)))
229      (if (= (length value) 3)
230          (destructuring-bind (size opc reg) value
231            (cond ((zerop v)
232                   (when (= size #b10)
233                     (princ "W" stream))
234                   (princ (svref *register-names* reg) stream))
235                  (t
236                   (format stream "~a~d"
237                           (cond ((and (= size #b10)
238                                       (= opc #b0))
239                                  "S")
240                                 ((and (= size #b11)
241                                       (= opc #b0))
242                                  "D")
243                                 ((and (= size #b00)
244                                       (= opc #b1))
245                                  "Q"))
246                           reg))))
247          (destructuring-bind (size reg) value
248            (cond ((zerop v)
249                   (when (zerop size)
250                     (princ "W" stream))
251                   (princ (svref *register-names* reg) stream))
252                  (t
253                   (format stream "~a~d"
254                           (case size
255                             (#b00 "S")
256                             (#b01 "D")
257                             (#b10 "Q"))
258                           reg)))))))
259
260  (defun print-float-reg (value stream dstate)
261    (multiple-value-bind (type value)
262        (if (consp value)
263            (values (car value) (cadr value))
264            (values (ldb (byte 1 22) (current-instruction dstate))
265                    value))
266      (format stream "~a~d"
267              (if (= type 1)
268                  "D"
269                  "S")
270              value)))
271
272  (defun print-simd-reg (value stream dstate)
273    (declare (ignore dstate))
274    (destructuring-bind (size offset) value
275      (format stream "V~d.~a" offset
276              (if (zerop size)
277                  "8B"
278                  "16B"))))
279
280  (defun lowest-set-bit-index (integer-value)
281    (max 0 (1- (integer-length (logand integer-value (- integer-value))))))
282
283  (defun print-simd-copy-reg (value stream dstate)
284    (declare (ignore dstate))
285    (destructuring-bind (offset imm5 &optional imm4) value
286      (let ((index (lowest-set-bit-index imm5)))
287       (format stream "V~d.~a[~a]" offset
288               (char "BHSD" index)
289               (if imm4
290                   (ash imm4 (- index))
291                   (ash imm5 (- (1+ index))))))))
292
293  (defun print-sys-reg (value stream dstate)
294    (declare (ignore dstate))
295    (princ (decode-sys-reg value) stream))
296
297  (defun print-cond (value stream dstate)
298    (declare (ignore dstate))
299    (princ (svref *condition-name-vec* value) stream))
300
301  (defun use-label (value dstate)
302    (let ((value (if (consp value)
303                     (logior (ldb (byte 2 0) (car value))
304                             (ash (cadr value) 2))
305                     (ash value 2))))
306      (+ value (dstate-cur-addr dstate))))
307
308
309  (defun annotate-ldr-str (register offset dstate)
310    (case register
311      (#.sb!vm::code-offset
312       (note-code-constant offset dstate))
313      (#.sb!vm::null-offset
314       (let ((offset (+ sb!vm::nil-value offset)))
315         (maybe-note-assembler-routine offset nil dstate)
316         (maybe-note-static-symbol (logior offset other-pointer-lowtag)
317                                                dstate)))
318      #!+sb-thread
319      (#.sb!vm::thread-offset
320       (let* ((thread-slots
321               (load-time-value
322                (primitive-object-slots
323                 (find 'sb!vm::thread *primitive-objects*
324                       :key #'primitive-object-name)) t))
325              (slot (find (ash offset (- word-shift)) thread-slots
326                          :key #'slot-offset)))
327         (when slot
328           (note (lambda (stream)
329                   (format stream "thread.~(~A~)" (slot-name slot)))
330                 dstate))))))
331
332  (defun find-value-from-previos-inst (register dstate)
333    ;; Needs to be MOVZ REGISTER, imm, LSL #0
334    ;; Should cover most offsets in sane code
335    (let ((inst (current-instruction dstate -4)))
336      (when (and (= (ldb (byte 9 23) inst) #b110100101) ;; MOVZ
337                 (= (ldb (byte 5 0) inst) register)
338                 (= (ldb (byte 2 21) inst) 0)) ;; LSL #0
339        (ldb (byte 16 5) inst))))
340
341  (defun annotate-ldr-str-reg (value stream dstate)
342    (declare (ignore stream))
343    (let* ((inst (current-instruction dstate))
344           (float (ldb-test (byte 1 26) inst)))
345      (unless float
346        (let ((value (find-value-from-previos-inst value dstate)))
347          (when value
348            (annotate-ldr-str (ldb (byte 5 5) inst) value dstate))))))
349
350  (defun annotate-ldr-str-imm (value stream dstate)
351    (declare (ignore stream))
352    (let* ((inst (current-instruction dstate))
353           (float-reg (ldb-test (byte 1 26) inst)))
354      (unless float-reg
355        (annotate-ldr-str (ldb (byte 5 5) inst)
356                          (if (consp value)
357                              (decode-scaled-immediate value)
358                              value)
359                          dstate)))))
360
361
362(progn
363
364  (define-arg-type shift :printer #'print-shift)
365
366  (define-arg-type 2-bit-shift :printer #'print-2-bit-shift)
367
368  (define-arg-type wide-shift :printer #'print-wide-shift)
369
370  (define-arg-type extend :printer #'print-extend)
371
372  (define-arg-type ldr-str-extend :printer #'print-ldr-str-extend)
373
374  (define-arg-type scaled-immediate :printer #'print-scaled-immediate)
375
376  (define-arg-type immediate :sign-extend t :printer #'print-immediate)
377
378  (define-arg-type unsigned-immediate :printer #'print-immediate)
379
380  (define-arg-type logical-immediate :printer #'print-logical-immediate)
381
382  (define-arg-type imm-writeback :printer #'print-imm-writeback)
383
384  (define-arg-type pair-imm-writeback :printer #'print-pair-imm-writeback)
385
386  (define-arg-type test-branch-immediate :printer #'print-test-branch-immediate)
387
388  (define-arg-type reg :printer #'print-reg)
389
390  (define-arg-type x-reg :printer #'print-x-reg)
391
392  (define-arg-type x-reg-sp :printer #'print-x-reg-sp)
393
394  (define-arg-type w-reg :printer #'print-w-reg)
395
396  (define-arg-type reg-sp :printer #'print-reg-sp)
397
398  (define-arg-type reg-float-reg :printer #'print-reg-float-reg)
399
400  (define-arg-type float-reg :printer #'print-float-reg)
401
402  (define-arg-type simd-reg :printer #'print-simd-reg)
403
404  (define-arg-type simd-copy-reg :printer #'print-simd-copy-reg)
405
406  (define-arg-type sys-reg :printer #'print-sys-reg)
407
408  (define-arg-type cond :printer #'print-cond)
409
410  (define-arg-type ldr-str-annotation :printer #'annotate-ldr-str-imm)
411
412  (define-arg-type ldr-str-reg-annotation :printer #'annotate-ldr-str-reg)
413
414  (define-arg-type label :sign-extend t :use-label #'use-label))
415
416;;;; special magic to support decoding internal-error and related traps
417(defun snarf-error-junk (sap offset &optional length-only)
418  (let* ((inst (sap-ref-32 sap (- offset 4)))
419         (error-number (ldb (byte 8 13) inst))
420         (length (sb!kernel::error-length error-number))
421         (index offset))
422    (declare (type sb!sys:system-area-pointer sap)
423             (type (unsigned-byte 8) length))
424    (cond (length-only
425           (loop repeat length do (sb!c::sap-read-var-integerf sap index))
426           (values 0 (- index offset) nil nil))
427          (t
428           (collect ((sc-offsets)
429                     (lengths))
430             (loop repeat length do
431                  (let ((old-index index))
432                    (sc-offsets (sb!c::sap-read-var-integerf sap index))
433                    (lengths (- index old-index))))
434             (values error-number
435                     (- index offset)
436                     (sc-offsets)
437                     (lengths)))))))
438
439(defun brk-control (chunk inst stream dstate)
440  (declare (ignore inst chunk))
441  (let ((code (ldb (byte 8 5) (current-instruction dstate))))
442    (flet ((nt (x) (if stream (note x dstate))))
443      (case code
444        (#.halt-trap
445         (nt "Halt trap"))
446        (#.pending-interrupt-trap
447         (nt "Pending interrupt trap"))
448        (#.error-trap
449         (nt "Error trap")
450         (handle-break-args #'snarf-error-junk stream dstate))
451        (#.cerror-trap
452         (nt "Cerror trap")
453         (handle-break-args #'snarf-error-junk stream dstate))
454        (#.breakpoint-trap
455         (nt "Breakpoint trap"))
456        (#.fun-end-breakpoint-trap
457         (nt "Function end breakpoint trap"))
458        (#.single-step-around-trap
459         (nt "Single step around trap"))
460        (#.single-step-before-trap
461         (nt "Single step before trap"))
462        (#.invalid-arg-count-trap
463         (nt "Invalid argument count trap"))))))
464
465;;;; primitive emitters
466
467(define-bitfield-emitter emit-word 32
468  (byte 32 0))
469
470(define-bitfield-emitter emit-dword 64
471  (byte 64 0))
472
473;;;; miscellaneous hackery
474
475(defun register-p (thing)
476  (and (tn-p thing)
477       (eq (sb-name (sc-sb (tn-sc thing))) 'sb!vm::registers)))
478
479(defun fp-register-p (thing)
480  (and (tn-p thing)
481       (eq (sb-name (sc-sb (tn-sc thing))) 'sb!vm::float-registers)))
482
483(defun reg-size (tn)
484  (if (sc-is tn 32-bit-reg)
485      0
486      1))
487
488(defmacro assert-same-size (&rest things)
489  `(assert (= ,@(loop for thing in things
490                      collect `(reg-size ,thing)))
491           ,things
492           "Registers should have the same size: ~@{~a~%, ~}" ,@things))
493
494(define-instruction byte (segment byte)
495  (:emitter
496   (emit-byte segment byte)))
497
498(define-instruction word (segment word)
499  (:emitter
500   (etypecase word
501     (fixup
502      (note-fixup segment :absolute word)
503      (emit-word segment 0))
504     (integer
505      (emit-word segment word)))))
506
507(define-instruction dword (segment word)
508  (:emitter
509   (etypecase word
510     (fixup
511      (note-fixup segment :absolute word)
512      (emit-dword segment 0))
513     (integer
514      (emit-dword segment word)))))
515
516(defun emit-header-data (segment type)
517  (emit-back-patch segment
518                   8
519                   (lambda (segment posn)
520                     (emit-dword segment
521                                 (logior type
522                                         (ash (+ posn
523                                                 (component-header-length))
524                                              (- n-widetag-bits
525                                                 word-shift)))))))
526
527(define-instruction simple-fun-header-word (segment)
528  (:emitter
529   (emit-header-data segment simple-fun-header-widetag)))
530
531(define-instruction lra-header-word (segment)
532  (:emitter
533   (emit-header-data segment return-pc-header-widetag)))
534
535;;;; Addressing mode 1 support
536
537;;; Addressing mode 1 has some 11 formats.  These are immediate,
538;;; register, and nine shift/rotate functions based on one or more
539;;; registers.  As the mnemonics used for these functions are not
540;;; currently used, we simply define them as constructors for a
541;;; shifter-operand structure, similar to the make-ea function in the
542;;; x86 backend.
543
544(defstruct shifter-operand
545  register
546  function-code
547  operand)
548
549
550(defun lsl (register operand)
551  (aver (register-p register))
552  (aver (or (register-p operand)
553            (typep operand '(integer 0 63))))
554
555  (make-shifter-operand :register register :function-code 0 :operand operand))
556
557(defun lsr (register operand)
558  (aver (register-p register))
559  (aver (or (register-p operand)
560            (typep operand '(integer 0 63))))
561
562  (make-shifter-operand :register register :function-code 1 :operand operand))
563
564(defun asr (register operand)
565  (aver (register-p register))
566  (aver (or (register-p operand)
567            (typep operand '(integer 1 63))))
568
569  (make-shifter-operand :register register :function-code 2 :operand operand))
570
571(defun ror (register operand)
572  ;; ROR is a special case: the encoding for ROR with an immediate
573  ;; shift of 32 (0) is actually RRX.
574  (aver (register-p register))
575  (aver (or (register-p operand)
576            (typep operand '(integer 1 63))))
577
578  (make-shifter-operand :register register :function-code 3 :operand operand))
579
580(defun rrx (register)
581  ;; RRX is a special case: it is encoded as ROR with an immediate
582  ;; shift of 32 (0), and has no operand.
583  (aver (register-p register))
584  (make-shifter-operand :register register :function-code 3 :operand 0))
585
586(defstruct (extend
587            (:constructor extend (register kind &optional (operand 0))))
588  (register nil :type tn)
589  kind
590  (operand 0 :type (integer 0 63)))
591
592(define-condition cannot-encode-immediate-operand (error)
593  ((value :initarg :value)))
594
595(defun encode-shifted-register (operand)
596  (etypecase operand
597    (tn
598     (values 0 0 operand))
599    (shifter-operand
600     (values (shifter-operand-function-code operand)
601             (shifter-operand-operand operand)
602             (shifter-operand-register operand)))))
603
604
605;;;; Addressing mode 2 support
606
607;;; Addressing mode 2 ostensibly has 9 formats.  These are formed from
608;;; a cross product of three address calculations and three base
609;;; register writeback modes.  As one of the address calculations is a
610;;; scaled register calculation identical to the mode 1 register shift
611;;; by constant, we reuse the shifter-operand structure and its public
612;;; constructors.
613
614(defstruct memory-operand
615  base
616  offset
617  mode)
618
619;;; The @ function is used to encode a memory addressing mode.  The
620;;; parameters for the base form are a base register, an optional
621;;; offset (either an integer, a register tn or a shifter-operand
622;;; structure with a constant shift amount, optionally within a unary
623;;; - form), and a base register writeback mode (either :offset,
624;;; :pre-index, or :post-index).  The alternative form uses a label as
625;;; the base register, and accepts only (optionally negated) integers
626;;; as offsets, and requires a mode of :offset.
627(defun @ (base &optional (offset 0) (mode :offset))
628  (when (label-p base)
629    (aver (eq mode :offset))
630    (aver (integerp offset)))
631
632  (when (shifter-operand-p offset)
633    (aver (integerp (shifter-operand-operand offset))))
634
635  (make-memory-operand :base base :offset offset
636                       :mode mode))
637
638
639;;;; Data-processing instructions
640
641
642(defmacro def-emitter (name &rest specs)
643  (collect ((arg-names) (arg-types))
644    (let* ((total-bits 32)
645           (overall-mask (ash -1 total-bits))
646           (num-bytes (truncate total-bits assembly-unit-bits))
647           (bytes (make-array num-bytes :initial-element nil)))
648      (dolist (spec-expr specs)
649        (destructuring-bind (arg size pos) spec-expr
650          (when (ldb-test (byte size pos) overall-mask)
651            (error "The byte spec ~S either overlaps another byte spec, or ~
652                    extends past the end."
653                   spec-expr))
654          (setf (ldb (byte size pos) overall-mask) -1)
655          (unless (numberp arg)
656            (arg-names arg)
657            (arg-types `(type (integer ,(ash -1 (1- size))
658                                       ,(1- (ash 1 size)))
659                              ,arg)))
660          (multiple-value-bind (start-byte offset)
661              (floor pos assembly-unit-bits)
662            (let ((end-byte (floor (1- (+ pos size))
663                                   assembly-unit-bits)))
664              (flet ((maybe-ash (expr offset)
665                       (if (zerop offset)
666                           expr
667                           `(ash ,expr ,offset))))
668                (declare (inline maybe-ash))
669                (cond ((zerop size))
670                      ((= start-byte end-byte)
671                       (push (maybe-ash `(ldb (byte ,size 0) ,arg)
672                                        offset)
673                             (svref bytes start-byte)))
674                      (t
675                       (push (maybe-ash
676                              `(ldb (byte ,(- assembly-unit-bits offset) 0)
677                                    ,arg)
678                              offset)
679                             (svref bytes start-byte))
680                       (do ((index (1+ start-byte) (1+ index)))
681                           ((>= index end-byte))
682                         (push
683                          `(ldb (byte ,assembly-unit-bits
684                                      ,(- (* assembly-unit-bits
685                                             (- index start-byte))
686                                          offset))
687                                ,arg)
688                          (svref bytes index)))
689                       (let ((len (rem (+ size offset)
690                                       assembly-unit-bits)))
691                         (push
692                          `(ldb (byte ,(if (zerop len)
693                                           assembly-unit-bits
694                                           len)
695                                      ,(- (* assembly-unit-bits
696                                             (- end-byte start-byte))
697                                          offset))
698                                ,arg)
699                          (svref bytes end-byte))))))))))
700      (unless (= overall-mask -1)
701        (error "There are holes. ~v,'0b"
702               total-bits
703               (ldb (byte total-bits 0) overall-mask)))
704      (let ((forms nil))
705        (dotimes (i num-bytes)
706          (let ((pieces (svref bytes i)))
707            (aver pieces)
708            (push `(emit-byte segment
709                              ,(if (cdr pieces)
710                                   `(logior ,@pieces)
711                                   (car pieces)))
712                  forms)))
713        `(defun ,(symbolicate "EMIT-" name) (segment ,@(arg-names))
714           (declare (type sb!assem:segment segment) ,@(arg-types))
715           ,@(ecase *backend-byte-order*
716               (:little-endian (nreverse forms))
717               (:big-endian forms))
718           nil)))))
719
720(defconstant +64-bit-size+ 1)
721
722(def-emitter add-sub-imm
723  (size 1 31)
724  (op 2 29)
725  (#b10001 5 24)
726  (shift 2 22)
727  (imm 12 10)
728  (rn 5 5)
729  (rd 5 0))
730
731(define-instruction-format (add-sub 32)
732  (op :field (byte 2 29))
733  (rn :field (byte 5 5) :type 'reg-sp)
734  (rd :field (byte 5 0) :type 'reg-sp))
735
736(define-instruction-format
737    (add-sub-imm 32
738     :default-printer '(:name :tab rd ", " rn ", " imm shift)
739     :include add-sub)
740  (op2 :field (byte 5 24) :value #b10001)
741  (shift :field (byte 2 22) :type '2-bit-shift)
742  (imm :field (byte 12 10) :type 'unsigned-immediate))
743
744(define-instruction-format
745    (adds-subs-imm 32
746     :include add-sub-imm
747     :default-printer '(:name :tab rd ", " rn ", " imm shift))
748  (rd :type 'reg))
749
750(define-instruction-format
751    (add-sub-shift-reg 32
752     :default-printer '(:name :tab rd ", " rn ", " rm shift)
753     :include add-sub)
754  (op2 :field (byte 5 24) :value #b01011)
755  (op3 :field (byte 1 21) :value #b0)
756  (shift :fields (list (byte 2 22) (byte 6 10)) :type 'shift)
757  (rm :field (byte 5 16) :type 'reg)
758  (rn :type 'reg)
759  (rd :type 'reg))
760
761(def-emitter add-sub-shift-reg
762  (size 1 31)
763  (op 2 29)
764  (#b01011 5 24)
765  (shift 2 22)
766  (#b0 1 21)
767  (rm 5 16)
768  (imm 6 10)
769  (rn 5 5)
770  (rd 5 0))
771
772(define-instruction-format
773    (add-sub-ext-reg 32
774     :default-printer '(:name :tab rd ", " rn ", " extend)
775     :include add-sub)
776  (op2 :field (byte 8 21) :value #b01011001)
777  (extend :fields (list (byte 3 13) (byte 3 10)) :type 'extend)
778  (rm :field (byte 5 16) :type 'reg)
779  (rd :type 'reg))
780
781(def-emitter add-sub-ext-reg
782  (size 1 31)
783  (op 2 29)
784  (#b01011001 8 21)
785  (rm 5 16)
786  (option 3 13)
787  (imm 3 10)
788  (rn 5 5)
789  (rd 5 0))
790
791(defun add-sub-immediate-p (x)
792  (or (typep x '(unsigned-byte 12))
793      (and (typep x '(unsigned-byte 24))
794           (not (ldb-test (byte 12 0) x)))))
795
796(defun fixnum-add-sub-immediate-p (x)
797  (and (fixnump x)
798       (let ((x (fixnumize x)))
799         (or (typep x '(unsigned-byte 12))
800             (and (typep x '(unsigned-byte 24))
801                  (not (ldb-test (byte 12 0) x)))))))
802
803(defun negative-add-sub-immediate-p (x)
804  (and (typep x '(integer * -1))
805       (let ((x (- x)))
806         (or (typep x '(unsigned-byte 12))
807             (and (typep x '(unsigned-byte 24))
808                  (not (ldb-test (byte 12 0) x)))))))
809
810(defmacro def-add-sub (name op &rest printers)
811  `(define-instruction ,name (segment rd rn rm)
812     ,@printers
813     (:emitter
814      (let ((size (reg-size rn)))
815       (cond ((or (register-p rm)
816                  (shifter-operand-p rm))
817              (multiple-value-bind (shift amount rm) (encode-shifted-register rm)
818                (assert-same-size rd rn rm)
819                (emit-add-sub-shift-reg segment size ,op shift (tn-offset rm)
820                                        amount (tn-offset rn) (tn-offset rd))))
821             ((extend-p rm)
822              (let* ((shift 0)
823                     (extend (ecase (extend-kind rm)
824                               (:uxtb #b00)
825                               (:uxth #b001)
826                               (:uxtw #b010)
827                               (:lsl
828                                (aver (or (= (extend-operand rm) 0)
829                                          (= (extend-operand rm) 3)))
830                                (setf shift 1)
831                                #b011)
832                               (:uxtx #b011)
833                               (:sxtb #b100)
834                               (:sxth #b101)
835                               (:sxtw #b110)
836                               (:sxtx #b111)))
837                     (rm (extend-register rm)))
838                (assert-same-size rd rn rm)
839                (emit-add-sub-ext-reg segment size ,op
840                                      (tn-offset rm)
841                                      extend shift (tn-offset rn) (tn-offset rd))))
842             (t
843              (let ((imm rm)
844                    (shift 0))
845                (when (and (typep imm '(unsigned-byte 24))
846                           (not (zerop imm))
847                           (not (ldb-test (byte 12 0) imm)))
848                  (setf imm (ash imm -12)
849                        shift 1))
850                (assert-same-size rn rd)
851                (emit-add-sub-imm segment size ,op shift imm
852                                  (tn-offset rn) (tn-offset rd)))))))))
853
854(def-add-sub add #b00
855  (:printer add-sub-imm ((op #b00)))
856  (:printer add-sub-ext-reg ((op #b00)))
857  (:printer add-sub-shift-reg ((op #b00))))
858
859(def-add-sub adds #b01
860  (:printer add-sub-imm ((op #b01) (rd nil :type 'reg)))
861  (:printer add-sub-ext-reg ((op #b01) (rd nil :type 'reg)))
862  (:printer add-sub-shift-reg ((op #b01)))
863  (:printer add-sub-imm ((op #b01) (rd #b11111))
864            '('cmn :tab rn ", " imm shift))
865  (:printer add-sub-ext-reg ((op #b01) (rd #b11111))
866            '('cmn :tab rn ", " rm extend))
867  (:printer add-sub-shift-reg ((op #b01) (rd #b11111))
868            '('cmn :tab rn ", " rm shift)))
869
870(def-add-sub sub #b10
871  (:printer add-sub-imm ((op #b10)))
872  (:printer add-sub-ext-reg ((op #b10)))
873  (:printer add-sub-shift-reg ((op #b10)))
874  (:printer add-sub-shift-reg ((op #b10) (rn #b11111))
875            '('neg :tab rd ", " rm shift)))
876
877(def-add-sub subs #b11
878  (:printer add-sub-imm ((op #b11)))
879  (:printer add-sub-ext-reg ((op #b11)))
880  (:printer add-sub-shift-reg ((op #b11)))
881  (:printer add-sub-imm ((op #b11) (rd #b11111))
882            '('cmp :tab rn ", " imm shift))
883  (:printer add-sub-ext-reg ((op #b11) (rd #b11111))
884            '('cmp :tab rn ", " extend))
885  (:printer add-sub-shift-reg ((op #b11) (rd #b11111))
886            '('cmp :tab rn ", " rm shift))
887  (:printer add-sub-shift-reg ((op #b11) (rn #b11111))
888            '('negs :tab rd ", " rm shift)))
889
890(define-instruction-macro cmp (rn rm)
891  `(let ((rn ,rn)
892         (rm ,rm))
893     (inst subs (if (sc-is rn 32-bit-reg)
894                    (32-bit-reg zr-tn)
895                    zr-tn)
896           rn rm)))
897
898(define-instruction-macro cmn (rn rm)
899  `(let ((rn ,rn)
900         (rm ,rm))
901     (inst adds (if (sc-is rn 32-bit-reg)
902                    (32-bit-reg zr-tn)
903                    zr-tn)
904           rn rm)))
905
906(define-instruction-macro neg (rd rm)
907  `(let ((rd ,rd)
908         (rm ,rm))
909     (inst sub rd (if (sc-is rd 32-bit-reg)
910                      (32-bit-reg zr-tn)
911                      zr-tn)
912           rm)))
913
914(define-instruction-macro negs (rd rm)
915  `(let ((rd ,rd)
916         (rm ,rm))
917     (inst subs rd (if (sc-is rd 32-bit-reg)
918                       (32-bit-reg zr-tn)
919                       zr-tn)
920           rm)))
921
922(define-instruction-macro add-sub (rd rm immediate)
923  `(let ((rd ,rd)
924         (rm ,rm)
925         (imm ,immediate))
926     (if (minusp imm)
927         (inst sub rd rm (add-sub-immediate (- imm)))
928         (inst add rd rm (add-sub-immediate imm)))))
929;;;
930
931(def-emitter add-sub-carry
932  (size 1 31)
933  (op 2 29)
934  (#b11010000 8 21)
935  (rm 5 16)
936  (#b000000 6 10)
937  (rn 5 5)
938  (rd 5 0))
939
940(define-instruction-format
941    (add-sub-carry 32 :include add-sub
942                      :default-printer '(:name :tab rd ", " rn ", " rm))
943  (op2 :field (byte 8 21) :value #b11010000)
944  (rm :field (byte 5 16) :type 'reg)
945  (op :field (byte 6 10) :value 0)
946  (rn :type 'reg)
947  (rd :type 'reg))
948
949(defmacro def-add-sub-carry (name opc)
950  `(define-instruction ,name (segment rd rn rm)
951     (:printer add-sub-carry ((op ,opc)))
952     (:emitter
953      (emit-add-sub-carry segment +64-bit-size+ ,opc
954                          (tn-offset rm) (tn-offset rn) (tn-offset rd)))))
955
956(def-add-sub-carry adc #b00)
957(def-add-sub-carry adcs #b01)
958(def-add-sub-carry sbc #b10)
959(def-add-sub-carry sbcs #b11)
960
961;;;
962
963(define-instruction-format (logical 32)
964  (op :field (byte 2 29))
965  (rn :field (byte 5 5) :type 'reg)
966  (rd :field (byte 5 0) :type 'reg))
967
968(def-emitter logical-reg
969  (size 1 31)
970  (opc 2 29)
971  (#b01010 5 24)
972  (shift 2 22)
973  (n 1 21)
974  (rm 5 16)
975  (imm 6 10)
976  (rn 5 5)
977  (rd 5 0))
978
979(define-instruction-format
980    (logical-reg 32
981     :include logical
982     :default-printer '(:name :tab rd ", " rn ", " rm shift))
983  (op2 :field (byte 5 24) :value #b01010)
984  (shift :fields (list (byte 2 22) (byte 6 10)) :type 'shift)
985  (n :field (byte 1 21) :value 0)
986  (rm :field (byte 5 16) :type 'reg))
987
988(def-emitter logical-imm
989  (size 1 31)
990  (opc 2 29)
991  (#b100100 6 23)
992  (n 1 22)
993  (imr 6 16)
994  (ims 6 10)
995  (rn 5 5)
996  (rd 5 0))
997
998(define-instruction-format
999    (logical-imm 32
1000     :include logical
1001     :default-printer '(:name :tab rd  ", " rn ", " imm))
1002  (op2 :field (byte 6 23) :value #b100100)
1003  (imm :fields (list (byte 1 22) (byte 6 16) (byte 6 10))
1004       :type 'logical-immediate)
1005  (rd :type 'reg-sp))
1006
1007(defun sequence-of-ones-p (integer)
1008  (declare (type (unsigned-byte 64) integer))
1009  (and (plusp integer)
1010       (let ((ones (logior (1- integer) integer))) ;; turns zeros on the right into ones
1011         (not (logtest (1+ ones) ;; Turns #b111 into #b1000
1012                       ones))))) ;; And when ANDed will produce 0
1013
1014(defun count-trailing-zeros (integer)
1015  (declare (type (unsigned-byte 64) integer))
1016  (loop for i below 64
1017        until (logbitp 0 integer)
1018        do (setf integer (ash integer -1))
1019        finally (return i)))
1020
1021(defun find-pattern (integer)
1022  (declare (type (unsigned-byte 64) integer)
1023           (optimize speed))
1024  (loop with pattern = integer
1025        for size of-type (integer 0 32) = 32 then (truncate size 2)
1026        for try-pattern of-type (unsigned-byte 32) = (ldb (byte size 0) integer)
1027        while (and (= try-pattern
1028                      (the (unsigned-byte 32) (ldb (byte size size) integer)))
1029                   (> size 1))
1030        do (setf pattern try-pattern)
1031        finally (return (values (* size 2) pattern))))
1032
1033(defun fixnum-encode-logical-immediate (integer)
1034  (and (fixnump integer)
1035       (encode-logical-immediate (fixnumize integer))))
1036
1037(defun encode-logical-immediate (integer)
1038  (let ((integer (ldb (byte 64 0) integer)))
1039    (cond ((or (zerop integer)
1040               (= integer (ldb (byte 64 0) -1)))
1041           nil)
1042          (t
1043           (multiple-value-bind (size pattern) (find-pattern integer)
1044             (values (ldb (byte 1 6) size) ;; 64-bit patterns need to set the N bit to 1
1045                     (cond ((sequence-of-ones-p pattern)
1046                            ;; Simple case of consecutive ones, just needs shifting right
1047                            (mod (- size (count-trailing-zeros pattern)) size))
1048                           ;; Invert the pattern and find consecutive ones there
1049                           ((not (sequence-of-ones-p (ldb (byte size 0)
1050                                                          (lognot pattern))))
1051                            (return-from encode-logical-immediate))
1052                           (t
1053                            ;; Rotate the bits on the left so that they are all consecutive
1054                            (- size (integer-length (ldb (byte size 0) (lognot pattern))))))
1055                     (logior (1- (logcount pattern))
1056                             ;; The size is calculated based on the highest set bit of IMMS inverted.
1057                             ;; Set unused bits to 1 so that the size can be calcuted correctly.
1058                             (ldb (byte 6 0) (ash -1 (integer-length size))))))))))
1059
1060(defun rotate-byte (count size pos integer)
1061  ;; Taken from sb-rotate-byte
1062  (let ((count (nth-value 1 (round count size)))
1063        (mask (1- (ash 1 size))))
1064    (logior (logand integer (lognot (ash mask pos)))
1065            (let ((field (logand (ash mask pos) integer)))
1066              (logand (ash mask pos)
1067                      (if (> count 0)
1068                          (logior (ash field count)
1069                                  (ash field (- count size)))
1070                          (logior (ash field count)
1071                                  (ash field (+ count size)))))))))
1072
1073(defun decode-logical-immediate (n immr imms)
1074  ;; DecodeBitMasks() From the ARM manual
1075  (declare (type bit n)
1076           (type (unsigned-byte 6) imms imms))
1077  (let* ((length (if (zerop n)
1078                     (1- (integer-length (ldb (byte 6 0) (lognot imms))))
1079                     6))
1080         (levels (ldb (byte length 0) -1))
1081         (s (logand imms levels))
1082         (r (logand immr levels))
1083         (bits (ldb (byte (1+ s) 0) -1))
1084         (pattern (rotate-byte (- r) (ash 1 length) 0 bits))
1085         (result 0))
1086    (declare (type (unsigned-byte 64) result))
1087    (loop for i below 64 by (1+ levels)
1088          do (setf (ldb (byte (1+ levels) i) result)
1089                   pattern))
1090    result))
1091
1092(defun emit-logical-reg-inst (segment opc n rd rn rm)
1093  (let* ((shift 0)
1094         (amount 0))
1095    (when (shifter-operand-p rm)
1096      (setf shift (shifter-operand-function-code rm)
1097            amount (shifter-operand-operand rm)))
1098    (emit-logical-reg segment +64-bit-size+ opc
1099                      shift n (tn-offset
1100                               (if (shifter-operand-p rm)
1101                                   (shifter-operand-register rm)
1102                                   rm))
1103                      amount
1104                      (tn-offset rn) (tn-offset rd))))
1105
1106(defmacro def-logical-imm-and-reg (name opc &rest printers)
1107  `(define-instruction ,name (segment rd rn rm)
1108     ,@printers
1109     (:emitter
1110      (if (or (register-p rm)
1111              (shifter-operand-p rm))
1112          (emit-logical-reg-inst segment ,opc 0 rd rn rm)
1113          (multiple-value-bind (n immr imms)
1114              (encode-logical-immediate rm)
1115            (unless n
1116              (error 'cannot-encode-immediate-operand :value rm))
1117            (emit-logical-imm segment +64-bit-size+ ,opc n immr imms (tn-offset rn) (tn-offset rd)))))))
1118
1119(def-logical-imm-and-reg and #b00
1120  (:printer logical-imm ((op #b00) (n 0)))
1121  (:printer logical-reg ((op #b00) (n 0))))
1122(def-logical-imm-and-reg orr #b01
1123  (:printer logical-imm ((op #b01)))
1124  (:printer logical-reg ((op #b01)))
1125  (:printer logical-imm ((op #b01) (rn 31))
1126            '('mov :tab rd  ", " imm))
1127  (:printer logical-reg ((op #b01) (rn 31))
1128                        '('mov :tab rd ", " rm shift)))
1129(def-logical-imm-and-reg eor #b10
1130  (:printer logical-imm ((op #b10)))
1131  (:printer logical-reg ((op #b10))))
1132(def-logical-imm-and-reg ands #b11
1133  (:printer logical-imm ((op #b11)))
1134  (:printer logical-reg ((op #b11)))
1135  (:printer logical-imm ((op #b11) (rd 31))
1136            '('tst :tab rn  ", " imm))
1137  (:printer logical-reg ((op #b11) (rd 31))
1138            '('tst :tab rn ", " rm shift)))
1139
1140(define-instruction-macro tst (rn rm)
1141  `(inst ands zr-tn ,rn ,rm))
1142
1143(defmacro def-logical-reg (name opc &rest printers)
1144  `(define-instruction ,name (segment rd rn rm)
1145     ,@printers
1146     (:emitter
1147      (emit-logical-reg-inst segment ,opc 1 rd rn rm))))
1148
1149(defun bic-mask (x)
1150  (ldb (byte 64 0) (lognot x)))
1151
1152(def-logical-reg bic #b00
1153  (:printer logical-reg ((op #b00) (n 1))))
1154(def-logical-reg orn #b01
1155  (:printer logical-reg ((op #b01) (n 1)))
1156  (:printer logical-reg ((op #b01) (n 1) (rn 31))
1157            '('mvn :tab rd ", " rm shift)))
1158(def-logical-reg eon #b10
1159  (:printer logical-reg ((op #b10) (n 1))))
1160(def-logical-reg bics #b11
1161  (:printer logical-reg ((op #b11) (n 1))))
1162
1163(define-instruction-macro mvn (rd rm)
1164  `(inst orn ,rd zr-tn ,rm))
1165
1166;;;
1167
1168(def-emitter bitfield
1169  (size 1 31)
1170  (opc 2 29)
1171  (#b100110 6 23)
1172  (n 1 22)
1173  (imr 6 16)
1174  (ims 6 10)
1175  (rn 5 5)
1176  (rd 5 0))
1177
1178(define-instruction-format (bitfield 32
1179                            :default-printer
1180                            '(:name :tab rd  ", " rn ", " immr ", " imms))
1181  (op :field (byte 2 29))
1182  (op2 :field (byte 6 23) :value #b100110)
1183  (n :field (byte 1 22) :value +64-bit-size+)
1184  (immr :field (byte 6 16) :type 'unsigned-immediate)
1185  (imms :field (byte 6 10) :type 'unsigned-immediate)
1186  (rn :field (byte 5 5) :type 'reg)
1187  (rd :field (byte 5 0) :type 'reg)
1188  (lsl-alias :fields (list (byte 6 16) (byte 6 10))))
1189
1190
1191(define-instruction sbfm (segment rd rn immr imms)
1192  (:printer bitfield ((op 0)))
1193  (:printer bitfield ((op 0) (imms #b111111))
1194            '('asr :tab rd  ", " rn ", " immr))
1195  (:emitter
1196   (emit-bitfield segment +64-bit-size+ 0 +64-bit-size+
1197                  immr imms (tn-offset rn) (tn-offset rd))))
1198
1199(define-instruction bfm (segment rd rn immr imms)
1200  (:printer bitfield ((op 1)))
1201  (:emitter
1202   (emit-bitfield segment +64-bit-size+ 1 +64-bit-size+
1203                  immr imms (tn-offset rn) (tn-offset rd))))
1204
1205(eval-when (:compile-toplevel :load-toplevel :execute)
1206  (defun print-lsl-alias-name (value stream dstate)
1207    (declare (ignore dstate))
1208    (destructuring-bind (immr imms) value
1209      (princ (if (and (/= imms 63)
1210                      (= (1+ imms) immr))
1211                 'lsl
1212                 'ubfm)
1213             stream)))
1214
1215  (defun print-lsl-alias (value stream dstate)
1216    (declare (ignore dstate))
1217    (destructuring-bind (immr imms) value
1218      (if (and (/= imms 63)
1219               (= (1+ imms) immr))
1220          (format stream "#~d" (- 63 imms))
1221          (format stream "#~d, #~d" immr imms)))))
1222
1223(define-instruction ubfm (segment rd rn immr imms)
1224  (:printer bitfield ((op #b10) (imms #b111111))
1225            '('lsr :tab rd  ", " rn ", " immr))
1226  (:printer bitfield ((op #b10))
1227            ;; This ought to have a better solution.
1228            ;; The whole disassembler ought to be better...
1229            '((:using #'print-lsl-alias-name lsl-alias)
1230              :tab rd  ", " rn ", "
1231              (:using #'print-lsl-alias lsl-alias)))
1232  (:emitter
1233   (emit-bitfield segment +64-bit-size+ #b10 +64-bit-size+
1234                  immr imms (tn-offset rn) (tn-offset rd))))
1235
1236(define-instruction-macro asr (rd rn shift)
1237  `(let ((rd ,rd)
1238         (rn ,rn)
1239         (shift ,shift))
1240     (if (integerp shift)
1241         (inst sbfm rd rn shift 63)
1242         (inst asrv rd rn shift))))
1243
1244(define-instruction-macro lsr (rd rn shift)
1245  `(let ((rd ,rd)
1246         (rn ,rn)
1247         (shift ,shift))
1248     (if (integerp shift)
1249         (inst ubfm rd rn shift 63)
1250         (inst lsrv rd rn shift))))
1251
1252(define-instruction-macro lsl (rd rn shift)
1253  `(let ((rd ,rd)
1254         (rn ,rn)
1255         (shift ,shift))
1256     (if (integerp shift)
1257         (inst ubfm rd rn
1258               (mod (- shift) 64)
1259               (- 63 shift))
1260         (inst lslv rd rn shift))))
1261
1262(define-instruction-macro ror (rd rs shift)
1263  `(let ((rd ,rd)
1264         (rs ,rs)
1265         (shift ,shift))
1266     (if (integerp shift)
1267         (inst extr rd rs rs shift)
1268         (inst rorv rd rs shift))))
1269
1270(define-instruction-macro sxtw (rd rn)
1271  `(inst sbfm ,rd ,rn 0 31))
1272;;;
1273
1274(def-emitter extract
1275  (size 1 31)
1276  (#b00100111 8 23)
1277  (n 1 22)
1278  (#b0 1 21)
1279  (rm 5 16)
1280  (imm 6 10)
1281  (rn 5 5)
1282  (rd 5 0))
1283
1284(define-instruction-format (extract 32)
1285  (op2 :field (byte 8 23) :value #b00100111)
1286  (op3 :field (byte 1 21) :value #b0)
1287  (rm :field (byte 5 16) :type 'reg)
1288  (imm :field (byte 6 10) :type 'unsigned-immediate)
1289  (rn :field (byte 5 5) :type 'reg)
1290  (rd :field (byte 5 0) :type 'reg))
1291
1292(define-instruction extr (segment rd rn rm lsb)
1293  (:printer extract ()
1294            '((:cond
1295                ((rn :same-as rm) 'ror)
1296                (t :name))
1297              :tab rd  ", " rn (:unless (:same-as rn) ", " rm) ", " imm))
1298  (:emitter
1299   (assert-same-size rd rn rm)
1300   (let ((size (reg-size rd)))
1301    (emit-extract segment size size
1302                  (tn-offset rm)
1303                  lsb
1304                  (tn-offset rn)
1305                  (tn-offset rd)))))
1306
1307;;;
1308
1309(def-emitter move-wide
1310  (size 1 31)
1311  (opc 2 29)
1312  (#b100101 6 23)
1313  (hw 2 21)
1314  (imm 16 5)
1315  (rd 5 0))
1316
1317(define-instruction-format (move-wide 32
1318                            :default-printer '(:name :tab rd  ", " imm shift))
1319  (op :field (byte 2 29))
1320  (op2 :field (byte 6 23) :value #b100101)
1321  (shift :field (byte 2 21) :type 'wide-shift)
1322  (imm :field (byte 16 5) :type 'unsigned-immediate)
1323  (rd :field (byte 5 0) :type 'reg))
1324
1325(defmacro process-null-sc (reg)
1326  `(setf ,reg (if (and (tn-p ,reg)
1327                       (eq 'null (sc-name (tn-sc ,reg))))
1328                  sb!vm::null-tn
1329                  ,reg)))
1330
1331(define-instruction-macro mov-sp (rd rm)
1332  `(inst add ,rd ,rm 0))
1333
1334(define-instruction-macro mov (rd rm)
1335  `(let ((rd ,rd)
1336         (rm ,rm))
1337     (process-null-sc rm)
1338     (if (integerp rm)
1339         (sb!vm::load-immediate-word rd rm)
1340         (inst orr rd zr-tn rm))))
1341
1342(define-instruction movn (segment rd imm &optional (shift 0))
1343  (:printer move-wide ((op #b00)))
1344  (:emitter
1345   (aver (not (ldb-test (byte 4 0) shift)))
1346   (emit-move-wide segment +64-bit-size+ #b00 (/ shift 16) imm (tn-offset rd))))
1347
1348(define-instruction movz (segment rd imm &optional (shift 0))
1349  (:printer move-wide ((op #b10)))
1350  (:emitter
1351   (aver (not (ldb-test (byte 4 0) shift)))
1352   (emit-move-wide segment +64-bit-size+ #b10 (/ shift 16) imm (tn-offset rd))))
1353
1354(define-instruction movk (segment rd imm &optional (shift 0))
1355  (:printer move-wide ((op #b11)))
1356  (:emitter
1357   (aver (not (ldb-test (byte 4 0) shift)))
1358   (emit-move-wide segment +64-bit-size+ #b11 (/ shift 16) imm (tn-offset rd))))
1359
1360;;;
1361
1362(def-emitter cond-select
1363  (size 1 31)
1364  (op 1 30)
1365  (#b011010100 9 21)
1366  (rm 5 16)
1367  (cond 4 12)
1368  (op2 2 10)
1369  (rn 5 5)
1370  (rd 5 0))
1371
1372(define-instruction-format
1373    (cond-select 32
1374     :default-printer '(:name :tab rd  ", " rn ", " rm ", " cond))
1375  (op :field (byte 1 30))
1376  (op3 :field (byte 9 21) :value #b011010100)
1377  (rm :field (byte 5 16) :type 'reg)
1378  (cond :field (byte 4 12) :type 'cond)
1379  (op2 :field (byte 2 10))
1380  (rn :field (byte 5 5) :type 'reg)
1381  (rd :field (byte 5 0) :type 'reg))
1382
1383(defmacro def-cond-select (name op op2 &rest printers)
1384  `(define-instruction ,name (segment rd rn rm cond)
1385     (:printer cond-select ((op ,op)
1386                            (op2 ,op2)))
1387     ,@printers
1388     (:emitter
1389      (emit-cond-select segment +64-bit-size+ ,op (tn-offset rm) (conditional-opcode cond)
1390                        ,op2 (tn-offset rn) (tn-offset rd)))))
1391
1392(def-cond-select csel 0 0)
1393(def-cond-select csinc 0 1
1394  (:printer cond-select ((op 0) (op2 1) (rn 31) (rm 31))
1395            '('cset :tab rd  ", " cond)))
1396(def-cond-select csinv 1 0
1397  (:printer cond-select ((op 1) (op2 0) (rn 31) (rm 31))
1398            '('csetm :tab rd  ", " cond)))
1399(def-cond-select csneg 1 1)
1400
1401(define-instruction-macro cset (rd cond)
1402  `(inst csinc ,rd zr-tn zr-tn (invert-condition ,cond)))
1403
1404(define-instruction-macro csetm (rd cond)
1405  `(inst csinv ,rd zr-tn zr-tn (invert-condition ,cond)))
1406;;;
1407
1408(def-emitter cond-compare
1409  (size 1 31)
1410  (op 1 30)
1411  (#b111010010 9 21)
1412  (rm-imm 5 16)
1413  (cond 4 12)
1414  (imm-p 1 11)
1415  (#b0 1 10)
1416  (rn 5 5)
1417  (0 1 4)
1418  (nzcv 4 0))
1419
1420(defmacro def-cond-compare (name op)
1421  `(define-instruction ,name (segment rn rm-imm cond &optional (nzcv 0))
1422     (:emitter
1423      (emit-cond-compare segment +64-bit-size+ ,op
1424                         (if (integerp rm-imm)
1425                             rm-imm
1426                             (tn-offset rm-imm))
1427                         (conditional-opcode cond)
1428                         (if (integerp rm-imm)
1429                             1
1430                             0)
1431                         (tn-offset rn) nzcv))))
1432
1433(def-cond-compare ccmn #b0)
1434(def-cond-compare ccmp #b1)
1435
1436;;;
1437
1438(def-emitter data-processing-1
1439  (size 1 31)
1440  (#b101101011000000000 18 13)
1441  (opcode 3 10)
1442  (rn 5 5)
1443  (rd 5 0))
1444
1445(define-instruction-format (data-processing-1 32
1446                            :default-printer '(:name :tab rd  ", " rn))
1447  (op2 :field (byte 18 13) :value #b101101011000000000)
1448  (op :field (byte 3 10))
1449  (rn :field (byte 5 5) :type 'reg)
1450  (rd :field (byte 5 0) :type 'reg))
1451
1452(defmacro def-data-processing-1 (name opc)
1453  `(define-instruction ,name (segment rd rn)
1454     (:printer data-processing-1 ((op ,opc)))
1455     (:emitter
1456      (emit-data-processing-1 segment +64-bit-size+
1457                              ,opc (tn-offset rn) (tn-offset rd)))))
1458
1459(def-data-processing-1 rbit #b000)
1460(def-data-processing-1 rev16 #b001)
1461(def-data-processing-1 rev32 #b010)
1462(def-data-processing-1 rev #b011)
1463(def-data-processing-1 clz #b100)
1464(def-data-processing-1 cls #b101)
1465
1466;;;
1467
1468(def-emitter data-processing-2
1469  (size 1 31)
1470  (#b0011010110 10 21)
1471  (rm 5 16)
1472  (opcode 6 10)
1473  (rn 5 5)
1474  (rd 5 0))
1475
1476(define-instruction-format (data-processing-2 32
1477                            :default-printer '(:name :tab rd  ", " rn ", " rm))
1478  (op2 :field (byte 10 21) :value #b0011010110)
1479  (rm :field (byte 5 16) :type 'reg)
1480  (op :field (byte 6 10))
1481  (rn :field (byte 5 5) :type 'reg)
1482  (rd :field (byte 5 0) :type 'reg))
1483
1484
1485(defmacro def-data-processing-2 (name opc &optional alias)
1486  `(define-instruction ,name (segment rd rn rm)
1487     (:printer data-processing-2 ((op ,opc))
1488               ,@(and alias
1489                      `('(',alias :tab rd ", " rn ", " rm))))
1490     (:emitter
1491      (assert-same-size rd rn rm)
1492      (emit-data-processing-2 segment (reg-size rd)
1493                              (tn-offset rm)
1494                              ,opc (tn-offset rn) (tn-offset rd)))))
1495
1496(def-data-processing-2 asrv #b001010 asr)
1497(def-data-processing-2 lslv #b001000 lsl)
1498(def-data-processing-2 lsrv #b001001 lsr)
1499(def-data-processing-2 rorv #b001011 ror)
1500
1501
1502(def-data-processing-2 udiv #b00010)
1503(def-data-processing-2 sdiv #b00011)
1504
1505;;;
1506
1507(def-emitter data-processing-3
1508  (size 1 31)
1509  (#b0011011 7 24)
1510  (op31 3 21)
1511  (rm 5 16)
1512  (o0 1 15)
1513  (ra 5 10)
1514  (rn 5 5)
1515  (rd 5 0))
1516
1517(define-instruction-format (data-processing-3 32
1518                            :default-printer
1519                            '(:name :tab rd  ", " rn ", " rm ", " ra))
1520  (op2 :field (byte 7 24) :value #b0011011)
1521  (op31 :field (byte 3 21))
1522  (rm :field (byte 5 16) :type 'reg)
1523  (o0 :field (byte 1 15))
1524  (ra :field (byte 5 10) :type 'reg)
1525  (rn :field (byte 5 5) :type 'reg)
1526  (rd :field (byte 5 0) :type 'reg))
1527
1528(defmacro def-data-processing-3 (name op31 o0 &rest printers)
1529  `(define-instruction ,name (segment rd rn rm ra)
1530     (:printer data-processing-3 ((op31 ,op31) (o0 ,o0)))
1531     ,@printers
1532     (:emitter
1533      (emit-data-processing-3 segment +64-bit-size+ ,op31
1534                              (tn-offset rm)
1535                              ,o0 (tn-offset ra) (tn-offset rn) (tn-offset rd)))))
1536
1537(def-data-processing-3 madd #b000 0
1538  (:printer data-processing-3 ((op31 #b000) (o0 0) (ra 31))
1539            '('mul :tab rd  ", " rn ", " rm )))
1540
1541(def-data-processing-3 smaddl #b001 0
1542  (:printer data-processing-3 ((op31 #b001) (o0 0) (ra 31))
1543            '('smull :tab rd  ", " rn ", " rm )))
1544(def-data-processing-3 umaddl #b101 0
1545  (:printer data-processing-3 ((op31 #b101) (o0 0) (ra 31))
1546            '('umull :tab rd  ", " rn ", " rm )))
1547
1548(def-data-processing-3 msub #b000 1)
1549(def-data-processing-3 smsubl #b001 1)
1550(def-data-processing-3 umsubl #b101 1)
1551
1552(define-instruction-macro mul (rd rn rm)
1553  `(inst madd ,rd ,rn ,rm zr-tn))
1554
1555(define-instruction smulh (segment rd rn rm)
1556  (:printer data-processing-3 ((op31 #b010) (o0 0) (ra 31))
1557            '(:name :tab rd  ", " rn ", " rm))
1558  (:emitter
1559   (emit-data-processing-3 segment +64-bit-size+ #b010 (tn-offset rm)
1560                           0 31 (tn-offset rn) (tn-offset rd))))
1561
1562(define-instruction umulh (segment rd rn rm)
1563  (:printer data-processing-3 ((op31 #b110) (o0 0) (ra 31))
1564            '(:name :tab rd  ", " rn ", " rm))
1565  (:emitter
1566   (emit-data-processing-3 segment +64-bit-size+ #b110 (tn-offset rm)
1567                           0 31 (tn-offset rn) (tn-offset rd))))
1568;;;
1569
1570(define-instruction-format (ldr-str 32)
1571  (size :field (byte 2 30))
1572  (op2 :field (byte 3 27) :value #b111)
1573  (v :field (byte 1 26))
1574  (op3 :field (byte 2 24) :value #b00)
1575  (op :field (byte 2 22))
1576  (rn :field (byte 5 5) :type 'x-reg-sp)
1577  (rt :fields (list (byte 2 30) (byte 1 23) (byte 5 0)) :type 'reg-float-reg)
1578  (ldr-str-annotation :type 'ldr-str-annotation))
1579
1580(def-emitter ldr-str-unsigned-imm
1581  (size 2 30)
1582  (#b111 3 27)
1583  (v 1 26)
1584  (#b01 2 24)
1585  (opc 2 22)
1586  (imm 12 10)
1587  (rn 5 5)
1588  (rt 5 0))
1589
1590(define-instruction-format
1591    (ldr-str-unsigned-imm 32
1592     :default-printer '(:name :tab rt  ", [" rn (:unless (just-imm :constant 0) ", " imm) "]"
1593                        ldr-str-annotation)
1594     :include ldr-str)
1595    (op3 :value #b01)
1596    (just-imm :field (byte 12 10))
1597    (imm :fields (list (byte 2 30) (byte 1 23) (byte 12 10) (byte 1 26))
1598         :type 'scaled-immediate)
1599    (ldr-str-annotation :fields (list (byte 2 30) (byte 1 23) (byte 12 10) (byte 1 26))))
1600
1601(def-emitter ldr-str-unscaled-imm
1602  (size 2 30)
1603  (#b111 3 27)
1604  (v 1 26)
1605  (#b00 2 24)
1606  (opc 2 22)
1607  (#b0 1 21)
1608  (imm 9 12)
1609  (mode 2 10)
1610  (rn 5 5)
1611  (rt 5 0))
1612
1613(define-instruction-format
1614    (ldr-str-unscaled-imm 32
1615     :default-printer '(:name :tab rt  ", [" rn imm-writeback ldr-str-annotation)
1616     :include ldr-str)
1617  (op4 :field (byte 1 21) :value #b0)
1618  (imm-writeback :fields (list (byte 9 12) (byte 2 10)) :type 'imm-writeback)
1619  (ldr-str-annotation :field (byte 9 12)))
1620
1621(def-emitter ldr-str-reg
1622  (size 2 30)
1623  (#b111 3 27)
1624  (v 1 26)
1625  (#b00 2 24)
1626  (opc 2 22)
1627  (#b1 1 21)
1628  (rm 5 16)
1629  (option 3 13)
1630  (s 1 12)
1631  (#b10 2 10)
1632  (rn 5 5)
1633  (rt 5 0))
1634
1635(define-instruction-format
1636    (ldr-str-reg 32
1637     :default-printer '(:name :tab rt  ", [" rn ", " rm option "]" ldr-str-annotation)
1638     :include ldr-str)
1639  (op4 :field (byte 1 21) :value 1)
1640  (rm :field (byte 5 16) :type 'reg)
1641  (option :fields (list (byte 3 13) (byte 1 12)) :type 'ldr-str-extend)
1642  (ldr-str-annotation :field (byte 5 16) :type 'ldr-str-reg-annotation))
1643
1644(def-emitter ldr-literal
1645  (opc 2 30)
1646  (#b011 3 27)
1647  (v 1 26)
1648  (#b00 2 24)
1649  (imm 19 5)
1650  (rt 5 0))
1651
1652(define-instruction-format (ldr-literal 32
1653                            :default-printer '(:name :tab rt ", " label)
1654                            :include ldr-str)
1655  (op2 :value #b011)
1656  (label :field (byte 19 5) :type 'label)
1657  (rt :fields (list (byte 2 30) (byte 5 0))))
1658
1659(defun ldr-str-offset-encodable (offset &optional (size 64))
1660  (or (typep offset '(signed-byte 9))
1661      (multiple-value-bind (qout rem) (truncate offset (truncate size 8))
1662        (and (zerop rem)
1663             (typep qout '(unsigned-byte 12))))))
1664
1665(defun emit-load-store (size opc segment dst address)
1666  (process-null-sc dst)
1667  (let* ((base (memory-operand-base address))
1668         (offset (memory-operand-offset address))
1669         (mode (memory-operand-mode address))
1670         (index-encoding (position mode '(:offset :post-index 0 :pre-index)))
1671         (fp (fp-register-p dst))
1672         (v  (if fp
1673                 1
1674                 0))
1675         (size (cond (fp
1676                      (sc-case dst
1677                        (complex-double-reg
1678                         (setf opc (logior #b10 opc))
1679                         #b00)
1680                        (t
1681                         (logior #b10
1682                                 (fp-reg-type dst)))))
1683                     (size)
1684                     ((sc-is dst 32-bit-reg)
1685                      #b10)
1686                     (t #b11)))
1687         (scale (if fp
1688                    (logior (ash (ldb (byte 1 1) opc) 2)
1689                            size)
1690                    size))
1691         (dst (tn-offset dst)))
1692    (cond ((and (typep offset 'unsigned-byte)
1693                (not (ldb-test (byte scale 0) offset))
1694                (typep (ash offset (- scale)) '(unsigned-byte 12))
1695                (register-p base)
1696                (eq mode :offset))
1697           (emit-ldr-str-unsigned-imm segment size
1698                                      v opc
1699                                      (ash offset (- scale))
1700                                      (tn-offset base)
1701                                      dst))
1702          ((and (eq mode :offset)
1703                (or (register-p offset)
1704                    (extend-p offset)))
1705           (let* ((register (if (extend-p offset)
1706                                (extend-register offset)
1707                                offset))
1708                  (shift (cond ((extend-p offset)
1709                                (aver (or (= (extend-operand offset) 0)
1710                                          (= (extend-operand offset) 3)))
1711                                (ash (extend-operand offset) -1))
1712                               (t
1713                                0)))
1714                  (extend (if (extend-p offset)
1715                              (ecase (extend-kind offset)
1716                                (:uxtw #b010)
1717                                (:lsl
1718                                 #b011)
1719                                (:sxtw #b110)
1720                                (:sxtx #b111))
1721                              #b011)))
1722             (emit-ldr-str-reg segment size
1723                               v opc
1724                               (tn-offset register)
1725                               extend shift
1726                               (tn-offset base)
1727                               dst)))
1728          ((and (typep offset '(signed-byte 9))
1729                (or (register-p base)
1730                    (fp-register-p base)))
1731           (emit-ldr-str-unscaled-imm segment size v
1732                                      opc offset
1733                                      index-encoding
1734                                      (tn-offset base) dst))
1735          (t
1736           (error "Invalid STR/LDR arguments: ~s ~s" dst address)))))
1737
1738(defmacro def-load-store (name size opc &rest printers)
1739  `(define-instruction ,name (segment dst address)
1740     (:printer ldr-str-unsigned-imm ((size ,size) (op ,opc) (v 0)))
1741     (:printer ldr-str-reg ((size ,size) (op ,opc) (v 0)))
1742     (:printer ldr-str-unscaled-imm ((size ,size) (op ,opc) (v 0)))
1743     ,@printers
1744     (:emitter
1745      (emit-load-store ,size ,opc segment dst address))))
1746
1747(def-load-store strb 0 #b00)
1748(def-load-store ldrb 0 #b01)
1749(def-load-store ldrsb 0 #b10)
1750(def-load-store strh 1 #b00)
1751(def-load-store ldrh 1 #b01)
1752(def-load-store ldrsh 1 #b10)
1753(def-load-store ldrsw #b10 #b10)
1754
1755(def-load-store str nil #b00
1756  (:printer ldr-str-unsigned-imm ((op 0)))
1757  (:printer ldr-str-reg ((op 0)))
1758  (:printer ldr-str-unscaled-imm ((op 0)))
1759  ;; 128-bit stores
1760  (:printer ldr-str-unsigned-imm ((size #b00) (op #b10) (v 1)))
1761  (:printer ldr-str-reg ((size #b00) (op #b10) (v 1)))
1762  (:printer ldr-str-unscaled-imm ((size #b00) (op #b10) (v 1))))
1763
1764(define-instruction ldr (segment dst address)
1765  (:printer ldr-str-unsigned-imm ((op #b01)))
1766  (:printer ldr-str-reg ((op #b01)))
1767  (:printer ldr-str-unscaled-imm ((op #b01)))
1768  (:printer ldr-literal ())
1769  ;; 128-bit loads
1770  (:printer ldr-str-unsigned-imm ((op #b11)))
1771  (:printer ldr-str-reg ((op #b11)))
1772  (:printer ldr-str-unscaled-imm ((op #b11)))
1773  (:emitter
1774   (if (label-p address)
1775       (emit-back-patch segment 4
1776                        (lambda (segment posn)
1777                          (emit-ldr-literal segment
1778                                            #b01
1779                                            (if (fp-register-p dst)
1780                                                1
1781                                                0)
1782                                            (ash (- (label-position address) posn) -2)
1783                                            (tn-offset dst))))
1784       (emit-load-store nil 1 segment dst address))))
1785
1786(def-emitter ldr-str-pair
1787  (opc 2 30)
1788  (#b101 3 27)
1789  (v 1 26)
1790  (#b0 1 25)
1791  (op2 2 23)
1792  (l 1 22)
1793  (imm 7 15)
1794  (rt2 5 10)
1795  (rn 5 5)
1796  (rt 5 0))
1797
1798(define-instruction-format
1799    (ldr-str-pair 32
1800     :default-printer '(:name :tab rt ", " rt2 ", [" rn pair-imm-writeback)
1801     :include ldr-str)
1802  (size :field (byte 2 30))
1803  (op2 :value #b101)
1804  (v :field (byte 1 26))
1805  (op3 :field (byte 1 25) :value #b00)
1806  (l :field (byte 1 22))
1807  (pair-imm-writeback :fields (list (byte 2 23) (byte 2 30) (byte 7 15) (byte 1 26))
1808                      :type 'pair-imm-writeback)
1809  (rt2 :fields (list (byte 2 30) (byte 5 10)) :type 'reg-float-reg)
1810  (rt :fields (list (byte 2 30) (byte 5 0))))
1811
1812(defun ldp-stp-offset-p (offset size)
1813  (multiple-value-bind (quot rem) (truncate offset (ecase size
1814                                                     (32 4)
1815                                                     (64 8)
1816                                                     (128 16)))
1817    (and (zerop rem)
1818         (typep quot '(signed-byte 7)))))
1819
1820(defun emit-ldr-str-pair-inst (l segment rt1 rt2 address)
1821  (let* ((base (memory-operand-base address))
1822         (offset (memory-operand-offset address))
1823         (mode (memory-operand-mode address))
1824         (fp (cond ((and (fp-register-p rt1)
1825                         (fp-register-p rt2))
1826                    (assert (and (eq (tn-sc rt1)
1827                                     (tn-sc rt2)))
1828                            (rt1 rt2)
1829                            "Arguments should have the same FP storage class: ~s ~s."
1830                            rt1 rt2)
1831                    t)
1832                   ((or (fp-register-p rt1)
1833                        (fp-register-p rt2))
1834                    (error "Both registers must have the same storage class: ~s ~s."
1835                           rt1 rt2))))
1836         (v  (if fp
1837                 1
1838                 0))
1839         (size 3)
1840         (opc (cond ((not fp)
1841                     #b10)
1842                     (t
1843                      (fp-reg-type rt1)))))
1844    (when fp
1845      (setf size (+ opc 2)))
1846    (assert (not (ldb-test (byte size 0) offset)))
1847    (emit-ldr-str-pair segment opc v
1848                       (ecase mode
1849                         (:post-index #b01)
1850                         (:pre-index #b11)
1851                         (:offset #b10))
1852                       l
1853                       (ash offset (- size))
1854                       (tn-offset rt2) (tn-offset base) (tn-offset rt1))))
1855
1856(define-instruction stp (segment rt1 rt2 address)
1857  (:printer ldr-str-pair ((l 0)))
1858  (:emitter
1859   (emit-ldr-str-pair-inst 0 segment rt1 rt2 address)))
1860
1861(define-instruction ldp (segment rt1 rt2 address)
1862  (:printer ldr-str-pair ((l 1)))
1863  (:emitter
1864   (emit-ldr-str-pair-inst 1 segment rt1 rt2 address)))
1865
1866;;;
1867
1868(def-emitter ldr-str-exclusive
1869  (size 2 30)
1870  (#b001000 6 24)
1871  (o2 1 23)
1872  (l 1 22)
1873  (o1 1 21)
1874  (rs 5 16)
1875  (o0 1 15)
1876  (rt2 5 10)
1877  (rn 5 5)
1878  (rt 5 0))
1879
1880(define-instruction-format (ldr-str-exclusive 32)
1881  (size :field (byte 2 30))
1882  (op2 :field (byte 6 24) :value #b001000)
1883  (o2 :field (byte 1 23))
1884  (l :field (byte 1 22))
1885  (o1 :field (byte 1 21))
1886  (rs :field (byte 5 16) :type 'w-reg)
1887  (o0 :field (byte 1 15))
1888  (rt2 :field (byte 5 5) :type 'reg)
1889  (rn :field (byte 5 5) :type 'x-reg-sp)
1890  (rt :field (byte 5 0) :type 'reg))
1891
1892(defmacro def-store-exclusive (name o0 o1 o2 rs &rest printers)
1893  `(define-instruction ,name (segment ,@(and rs '(rs)) rt rn)
1894     (:printer ldr-str-exclusive ((o0 ,o0) (o1 ,o1) (o2 ,o2) (l 0))
1895               '(:name :tab ,@(and rs '(rs ", ")) rt ", [" rn "]"))
1896     ,@printers
1897     (:emitter
1898      (emit-ldr-str-exclusive segment (logior #b10 (reg-size rt))
1899                              ,o2 0 ,o1
1900                              ,(if rs
1901                                   '(tn-offset rs)
1902                                   31)
1903                              ,o0
1904                              31
1905                              (tn-offset rn)
1906                              (tn-offset rt)))))
1907
1908(def-store-exclusive stxr 0 0 0 t)
1909(def-store-exclusive stlxr 1 0 0 t)
1910(def-store-exclusive stlr 1 0 1 nil)
1911
1912(defmacro def-load-exclusive (name o0 o1 o2 &rest printers)
1913  `(define-instruction ,name (segment rt rn)
1914     (:printer ldr-str-exclusive ((o0 ,o0) (o1 ,o1) (o2 ,o2) (l 1))
1915               '(:name :tab rt ", [" rn "]"))
1916     ,@printers
1917     (:emitter
1918      (emit-ldr-str-exclusive segment (logior #b10 (reg-size rt))
1919                              ,o2 1 ,o1
1920                              31
1921                              ,o0
1922                              31
1923                              (tn-offset rn)
1924                              (tn-offset rt)))))
1925
1926(def-load-exclusive ldxr 0 0 0)
1927(def-load-exclusive ldaxr 1 0 0)
1928(def-load-exclusive ldar 1 0 1)
1929
1930;;;
1931
1932(def-emitter cond-branch
1933  (#b01010100 8 24)
1934  (imm 19 5)
1935  (#b0 1 4)
1936  (cond 4 0))
1937
1938(define-instruction-format (cond-branch 32
1939                            :default-printer '(:name cond :tab target))
1940  (op1 :field (byte 8 24) :value #b01010100)
1941  (target :field (byte 19 5) :type 'label)
1942  (op2 :field (byte 1 4) :value #b0)
1943  (cond :field (byte 4 0) :type 'cond))
1944
1945(def-emitter uncond-branch
1946  (op 1 31)
1947  (#b00101 5 26)
1948  (imm 26 0))
1949
1950(define-instruction-format (uncond-branch 32
1951                            :default-printer '(:name :tab target))
1952  (op :field (byte 1 31))
1953  (op2 :field (byte 5 26) :value #b00101)
1954  (target :field (byte 26 0) :type 'label))
1955
1956(define-instruction b (segment cond-or-label &optional label)
1957  (:printer cond-branch ())
1958  (:printer uncond-branch ((op 0)))
1959  (:emitter
1960   (cond ((and (fixup-p cond-or-label)
1961               (not label))
1962          (note-fixup segment :uncond-branch cond-or-label)
1963          (emit-uncond-branch segment 0 0))
1964         ((and (fixup-p label))
1965          (note-fixup segment :cond-branch cond-or-label)
1966          (emit-cond-branch segment 0 (conditional-opcode cond-or-label)))
1967         (t
1968          (emit-back-patch segment 4
1969                           (cond (label
1970                                  (assert (label-p label))
1971                                  (lambda (segment posn)
1972                                    (emit-cond-branch segment
1973                                                      (ash (- (label-position label) posn) -2)
1974                                                      (conditional-opcode cond-or-label))))
1975                                 (t
1976                                  (assert (label-p cond-or-label))
1977                                  (lambda (segment posn)
1978                                    (emit-uncond-branch segment
1979                                                        0
1980                                                        (ash (- (label-position cond-or-label) posn) -2))))))))))
1981
1982(define-instruction bl (segment label)
1983  (:printer uncond-branch ((op 1)))
1984  (:emitter
1985   (ecase label
1986     (fixup
1987      (note-fixup segment :uncond-branch label)
1988      (emit-uncond-branch segment 1 0))
1989     (label
1990      (emit-back-patch segment 4
1991                       (lambda (segment posn)
1992                         (emit-uncond-branch segment
1993                                             1
1994                                             (ash (- (label-position label) posn) -2))))))))
1995
1996(def-emitter uncond-branch-reg
1997  (#b1101011 7 25)
1998  (opc 4 21)
1999  (#b11111000000 11 10)
2000  (rn 5 5)
2001  (#b00000 5 0))
2002
2003(define-instruction-format (uncond-branch-reg 32
2004                            :default-printer '(:name :tab rn))
2005  (op2 :field (byte 7 25) :value #b1101011)
2006  (op :field (byte 4 21))
2007  (op3 :field (byte 11 10) :value #b11111000000)
2008  (rn :field (byte 5 5) :type 'reg-sp)
2009  (op4 :field (byte 5 0) :value #b00000))
2010
2011(define-instruction br (segment register)
2012  (:printer uncond-branch-reg ((op 0)))
2013  (:emitter
2014   (emit-uncond-branch-reg segment 0 (tn-offset register))))
2015
2016(define-instruction blr (segment register)
2017  (:printer uncond-branch-reg ((op 1)))
2018  (:emitter
2019   (emit-uncond-branch-reg segment 1 (tn-offset register))))
2020
2021(define-instruction ret (segment &optional (register sb!vm::lr-tn))
2022  (:printer uncond-branch-reg ((op #b10)))
2023  (:printer uncond-branch-reg ((op #b10) (rn sb!vm::lr-offset))
2024            '(:name))
2025  (:emitter
2026   (emit-uncond-branch-reg segment #b10 (tn-offset register))))
2027
2028;;;
2029
2030(def-emitter compare-branch-imm
2031  (size 1 31)
2032  (#b011010 6 25)
2033  (op 1 24)
2034  (imm 19 5)
2035  (rt 5 0))
2036
2037(define-instruction-format (compare-branch-imm 32
2038                            :default-printer '(:name :tab rt ", " label))
2039  (size :field (byte 1 31))
2040  (op1 :field (byte 6 25) :value #b011010)
2041  (op  :field (byte 1 24))
2042  (label :field (byte 19 5) :type 'label)
2043  (rt :field (byte 5 0) :type 'reg))
2044
2045(define-instruction cbz (segment rt label)
2046  (:printer compare-branch-imm ((op 0)))
2047  (:emitter
2048   (assert (label-p label))
2049   (emit-back-patch segment 4
2050                    (lambda (segment posn)
2051                      (emit-compare-branch-imm segment
2052                                               +64-bit-size+
2053                                               0
2054                                               (ash (- (label-position label) posn) -2)
2055                                               (tn-offset rt))))))
2056
2057(define-instruction cbnz (segment rt label)
2058  (:printer compare-branch-imm ((op 1)))
2059  (:emitter
2060   (assert (label-p label))
2061   (emit-back-patch segment 4
2062                    (lambda (segment posn)
2063                      (emit-compare-branch-imm segment
2064                                               (reg-size rt)
2065                                               1
2066                                               (ash (- (label-position label) posn) -2)
2067                                               (tn-offset rt))))))
2068
2069(def-emitter test-branch-imm
2070  (b5 1 31)
2071  (#b011011 6 25)
2072  (op 1 24)
2073  (b40 5 19)
2074  (label 14 5)
2075  (rt 5 0))
2076
2077(define-instruction-format (test-branch-imm 32
2078                            :default-printer '(:name :tab rt ", " index ", " label))
2079  (op1 :field (byte 6 25) :value #b011011)
2080  (op  :field (byte 1 24))
2081  (index :fields (list (byte 1 31) (byte 5 19)) :type 'test-branch-immediate)
2082  (label :field (byte 14 5) :type 'label)
2083  (rt :field (byte 5 0) :type 'reg))
2084
2085(define-instruction tbz (segment rt bit label)
2086  (:printer test-branch-imm ((op 0)))
2087  (:emitter
2088   (assert (label-p label))
2089   (check-type bit (integer 0 63))
2090   (emit-back-patch segment 4
2091                    (lambda (segment posn)
2092                      (emit-test-branch-imm segment
2093                                            (ldb (byte 1 5) bit)
2094                                            0
2095                                            (ldb (byte 5 0) bit)
2096                                            (ash (- (label-position label) posn) -2)
2097                                            (tn-offset rt))))))
2098
2099(define-instruction tbnz (segment rt bit label)
2100  (:printer test-branch-imm ((op 1)))
2101  (:emitter
2102   (assert (label-p label))
2103   (check-type bit (integer 0 63))
2104   (emit-back-patch segment 4
2105                    (lambda (segment posn)
2106                      (emit-test-branch-imm segment
2107                                            (ldb (byte 1 5) bit)
2108                                            1
2109                                            (ldb (byte 5 0) bit)
2110                                            (ash (- (label-position label) posn) -2)
2111                                            (tn-offset rt))))))
2112;;;
2113(def-emitter exception
2114  (#b11010100 8 24)
2115  (opc 3 21)
2116  (imm 16 5)
2117  (#b000 3 2)
2118  (ll 2 0))
2119
2120(define-instruction-format (exception 32 :default-printer '(:name :tab imm))
2121  (op2 :field (byte 8 24) :value #b11010100)
2122  (op  :field (byte 3 21))
2123  (imm :field (byte 16 5) :type 'unsigned-immediate)
2124  (ll :field (byte 2 0)))
2125
2126(defmacro def-exception (name opc ll &rest printer-options)
2127  `(define-instruction ,name (segment imm)
2128     (:printer exception ((op ,opc) (ll ,ll))
2129               ,@printer-options)
2130     (:emitter
2131      (emit-exception segment ,opc imm ,ll))))
2132
2133(def-exception brk #b001 #b00
2134  '(:name :tab imm) :control #'brk-control)
2135
2136(def-exception hlt #b010 #b00)
2137
2138;;;
2139
2140(def-emitter pc-relative
2141  (op 1 31)
2142  (immlo 2 29)
2143  (#b10000 5 24)
2144  (immhi 19 5)
2145  (rd 5 0))
2146
2147(define-instruction-format (pc-relative 32
2148                            :default-printer '(:name :tab rd ", " label))
2149  (op :field (byte 1 31))
2150  (op2 :field (byte 5 24) :value #b10000)
2151  (label :fields (list (byte 2 29) (byte 19 5)) :type 'label)
2152  (rd :field (byte 5 0) :type 'x-reg))
2153
2154(defun emit-pc-relative-inst (op segment rd label &optional (offset 0))
2155  (assert (label-p label))
2156  (assert (register-p rd))
2157  (emit-back-patch segment 4
2158                   (lambda (segment posn)
2159                     (let ((offset (+ (- (label-position label) posn)
2160                                      offset)))
2161                       (emit-pc-relative segment
2162                                         op
2163                                         (ldb (byte 2 0) offset)
2164                                         (ldb (byte 19 2) offset)
2165                                         (tn-offset rd))))))
2166
2167(define-instruction adr (segment rd label &optional (offset 0))
2168  (:printer pc-relative ((op 0)))
2169  (:emitter
2170   (emit-pc-relative-inst 0 segment rd label offset)))
2171
2172(define-instruction adrp (segment rd label)
2173  (:printer pc-relative ((op 1)))
2174  (:emitter
2175   (emit-pc-relative-inst 1 segment rd label)))
2176
2177;;;
2178
2179(def-emitter system-reg
2180  (#b1101010100 10 22)
2181  (l 1 21)
2182  (sys-reg 16 5)
2183  (rt 5 0))
2184
2185(define-instruction-format (sys-reg 32)
2186  (op :field (byte 10 22) :value #b1101010100)
2187  (l :field (byte 1 21))
2188  (sys-reg :field (byte 16 5) :type 'sys-reg)
2189  (rt :field (byte 5 0) :type 'x-reg))
2190
2191(defun decode-sys-reg (reg)
2192  (ecase reg
2193    (#b1101101000010000 :nzcv)
2194    (#b1101101000100000 :fpcr)
2195    (#b1101101000100001 :fpsr)
2196    (#b1101110011101000 :ccnt)))
2197
2198(defun encode-sys-reg (reg)
2199  (ecase reg
2200    (:nzcv #b1101101000010000)
2201    (:fpcr #b1101101000100000)
2202    (:fpsr #b1101101000100001)
2203    (:ccnt #b1101110011101000)))
2204
2205(define-instruction msr (segment sys-reg rt)
2206  (:printer sys-reg ((l 0)) '(:name :tab sys-reg ", " rt))
2207  (:emitter
2208   (emit-system-reg segment 0 (encode-sys-reg sys-reg) (tn-offset rt))))
2209
2210(define-instruction mrs (segment rt sys-reg)
2211  (:printer sys-reg ((l 1)) '(:name :tab rt ", " sys-reg))
2212  (:emitter
2213   (emit-system-reg segment 1 (encode-sys-reg sys-reg) (tn-offset rt))))
2214
2215;;;
2216
2217(def-emitter system
2218  (#b11010101000000110011 20 12)
2219  (crm 4 8)
2220  (op 3 5)
2221  (#b11111 5 0))
2222
2223(define-instruction-format (system 32)
2224  (op1 :field (byte 20 12) :value #b11010101000000110011)
2225  (crm :field (byte 4 8))
2226  (op :field (byte 3 5))
2227  (op2 :field (byte 5 0) :value #b11111))
2228
2229
2230(define-instruction clrex (segment &optional (imm 15))
2231  (:printer system ((op #b010))
2232            '(:name (:unless (crm :constant 15) :tab "#" crm)))
2233  (:emitter
2234   (emit-system segment imm  #b010)))
2235
2236(defglobal **mem-bar-kinds**
2237    '((:sy . #b1111)
2238      (:st . #b1110)
2239      (:ld . #b1101)
2240      (:ish . #b1011)
2241      (:ishst . #b1010)
2242      (:ishld . #b1001)
2243      (:nsh . #b0111)
2244      (:nsht . #b0110)
2245      (:osh . #b0011)
2246      (:oshst . #b0010)
2247      (:oshld . #b0001)))
2248
2249(eval-when (:compile-toplevel :load-toplevel :execute)
2250  (defun print-mem-bar-kind (value stream dstate)
2251    (declare (ignore dstate))
2252    (let ((kind (car (rassoc value **mem-bar-kinds**))))
2253      (if kind
2254          (princ kind stream)
2255          (format stream "#~d" value)))))
2256
2257(defmacro def-mem-bar (name op)
2258  `(define-instruction ,name (segment &optional (kind :sy))
2259     (:printer system ((op ,op))
2260               '(:name :tab (:using #'print-mem-bar-kind crm)))
2261     (:emitter
2262      (emit-system segment
2263                   (cond ((integerp kind)
2264                          kind)
2265                         ((cdr (assoc kind **mem-bar-kinds**)))
2266                         (t
2267                          (error "Unknown memory barrier kind: ~s" kind)))
2268                   ,op))))
2269
2270(def-mem-bar dsb #b100)
2271(def-mem-bar dmb #b101)
2272(def-mem-bar isb #b110)
2273
2274;;;
2275
2276(def-emitter hint
2277  (#b110101010000001100100000 24 8)
2278  (imm 3 5)
2279  (#b11111 5 0))
2280
2281(define-instruction-format (hint 32 :default-printer '(:name))
2282  (op1 :field (byte 24 8) :value #b110101010000001100100000)
2283  (imm :field (byte 3 5))
2284  (op2 :field (byte 5 0) :value #b11111))
2285
2286(define-instruction nop (segment)
2287  (:printer hint ((imm 0)))
2288  (:emitter
2289   (emit-hint segment 0)))
2290
2291
2292
2293;;; Floating point
2294
2295(defun fp-reg-type (reg)
2296  (ecase (sc-name (tn-sc reg))
2297    (single-reg
2298     0)
2299    ((double-reg complex-single-reg)
2300     1)
2301    (complex-double-reg
2302     #b10)))
2303
2304(def-emitter fp-compare
2305  (#b00011110 8 24)
2306  (type 2 22)
2307  (#b1 1 21)
2308  (rm 5 16)
2309  (#b001000 6 10)
2310  (rn 5 5)
2311  (e 1 4)
2312  (z 1 3)
2313  (#b000 3 0))
2314
2315(define-instruction-format (fp-compare 32
2316                            :default-printer '(:name :tab rn ", " rm))
2317  (op1 :field (byte 9 23) :value #b000111100)
2318  (type :field (byte 1 22))
2319  (rm :field (byte 5 16) :type 'float-reg)
2320  (op2 :field (byte 6 10) :value #b001000)
2321  (rn :field (byte 5 5) :type 'float-reg)
2322  (op :field (byte 1 4))
2323  (z :field (byte 1 3))
2324  (op3 :field (byte 3 0) :value #b0))
2325
2326(defmacro def-fp-compare (name op)
2327  `(define-instruction ,name (segment rn rm)
2328     (:printer fp-compare ((op ,op)))
2329     (:printer fp-compare ((op ,op) (z 1) (type 0))
2330               '(:name :tab rn ", " 0s0))
2331     (:printer fp-compare ((op ,op) (z 1) (type 1))
2332               '(:name :tab rn ", " 0d0))
2333     (:emitter
2334      (assert (or (eql rm 0)
2335                  (eq (tn-sc rn)
2336                      (tn-sc rm)))
2337              (rn rm)
2338              "Arguments should have the same FP storage class: ~s ~s" rn rm)
2339      (emit-fp-compare segment
2340                       (fp-reg-type rn)
2341                       (if (eql rm 0)
2342                           0
2343                           (tn-offset rm))
2344                       (tn-offset rn)
2345                       ,op
2346                       (if (eql rm 0)
2347                           1
2348                           0)))))
2349
2350(def-fp-compare fcmp #b0)
2351(def-fp-compare fcmpe #b1)
2352
2353(define-instruction-format (fp-data-processing 32)
2354  (rn :field (byte 5 5) :type 'float-reg)
2355  (rd :field (byte 5 0) :type 'float-reg))
2356
2357(def-emitter fp-data-processing-1
2358  (#b000111100 9 23)
2359  (type 1 22)
2360  (#b100 3 19)
2361  (opcode 4 15)
2362  (#b10000 5 10)
2363  (rn 5 5)
2364  (rd 5 0))
2365
2366(define-instruction-format
2367    (fp-data-processing-1 32
2368     :include fp-data-processing
2369     :default-printer '(:name :tab rd ", " rn))
2370  (op2 :field (byte 9 23) :value #b000111100)
2371  (op3 :field (byte 3 19) :value #b100)
2372  (op :field (byte 4 15))
2373  (:op4 :field (byte 5 10) :value #b10000))
2374
2375(def-emitter fp-data-processing-2
2376  (#b000111100 9 23)
2377  (type 1 22)
2378  (#b1 1 21)
2379  (rm 5 16)
2380  (opcode 4 12)
2381  (#b10 2 10)
2382  (rn 5 5)
2383  (rd 5 0))
2384
2385(define-instruction-format
2386    (fp-data-processing-2 32
2387     :include fp-data-processing
2388     :default-printer '(:name :tab rd ", " rn ", " rm))
2389  (op2 :field (byte 9 23) :value #b000111100)
2390  (op3 :field (byte 1 21) :value #b1)
2391  (rm :field (byte 5 16) :type 'float-reg)
2392  (op :field (byte 4 12))
2393  (:op4 :field (byte 2 10) :value #b10))
2394
2395(def-emitter fp-data-processing-3
2396  (#b000111110 9 23)
2397  (type 1 22)
2398  (o1 1 21)
2399  (rm 5 16)
2400  (o2 1 15)
2401  (ra 5 10)
2402  (rn 5 5)
2403  (rd 5 0))
2404
2405(define-instruction-format
2406    (fp-data-processing-3 32
2407     :include fp-data-processing
2408     :default-printer '(:name :tab rd ", " rn ", " rm ", " ra))
2409  (op4 :field (byte 9 23) :value #b000011110)
2410  (op1 :field (byte 1 21))
2411  (op2 :field (byte 1 15))
2412  (rm :field (byte 5 16) :type 'float-reg)
2413  (ra :field (byte 5 10) :type 'float-reg))
2414
2415(def-emitter fp-conversion
2416  (size 1 31)
2417  (#b00111100 8 23)
2418  (type 1 22)
2419  (#b1 1 21)
2420  (opcode 5 16)
2421  (#b00000 6 10)
2422  (rn 5 5)
2423  (rd 5 0))
2424
2425(define-instruction-format (fp-conversion 32
2426                            :include fp-data-processing
2427                            :default-printer '(:name :tab rd ", " rn))
2428  (op2 :field (byte 8 23) :value #b00111100)
2429  (type :field (byte 1 22))
2430  (op1 :field (byte 1 21) :value #b1)
2431  (op :field (byte 5 16))
2432  (op3 :field (byte 6 10) :value #b0))
2433
2434(defmacro def-fp-data-processing-1 (name op)
2435  `(define-instruction ,name (segment rd rn)
2436     (:printer fp-data-processing-1 ((op ,op)))
2437     (:emitter
2438      (assert (and (eq (tn-sc rd)
2439                       (tn-sc rn)))
2440              (rd rn)
2441              "Arguments should have the same FP storage class: ~s ~s." rd rn)
2442      (emit-fp-data-processing-1 segment
2443                                 (fp-reg-type rn)
2444                                 ,op
2445                                 (tn-offset rn)
2446                                 (tn-offset rd)))))
2447
2448(def-fp-data-processing-1 fabs #b0001)
2449(def-fp-data-processing-1 fneg #b0010)
2450(def-fp-data-processing-1 fsqrt #b0011)
2451(def-fp-data-processing-1 frintn #b1000)
2452(def-fp-data-processing-1 frintp #b1001)
2453(def-fp-data-processing-1 frintm #b1010)
2454(def-fp-data-processing-1 frintz #b1011)
2455(def-fp-data-processing-1 frinta #b1100)
2456(def-fp-data-processing-1 frintx #b1110)
2457(def-fp-data-processing-1 frinti #b1111)
2458
2459(define-instruction-format (fcvt 32
2460                            :include fp-data-processing-1
2461                            :default-printer '(:name :tab rd ", " rn))
2462  (op :field (byte 2 17) :value #b01)
2463  (rn :fields (list (byte 1 22) (byte 5 5)))
2464  (rd :fields (list (byte 2 15) (byte 5 0))))
2465
2466(define-instruction fcvt (segment rd rn)
2467  (:printer fcvt ())
2468  (:emitter
2469   (emit-fp-data-processing-1 segment
2470                              (fp-reg-type rn)
2471                              (logior #b100 (fp-reg-type rd))
2472                              (tn-offset rn)
2473                              (tn-offset rd))))
2474
2475(defmacro def-fp-data-processing-2 (name op)
2476  `(define-instruction ,name (segment rd rn rm)
2477     (:printer fp-data-processing-2 ((op ,op)))
2478     (:emitter
2479      (assert (and (eq (tn-sc rd)
2480                       (tn-sc rn))
2481                   (eq (tn-sc rd)
2482                       (tn-sc rm)))
2483              (rd rn rm)
2484              "Arguments should have the same FP storage class: ~s ~s ~s." rd rn rm)
2485      (emit-fp-data-processing-2 segment
2486                                 (fp-reg-type rn)
2487                                 (tn-offset rm)
2488                                 ,op
2489                                 (tn-offset rn)
2490                                 (tn-offset rd)))))
2491
2492(def-fp-data-processing-2 fmul #b0000)
2493(def-fp-data-processing-2 fdiv #b0001)
2494(def-fp-data-processing-2 fadd #b0010)
2495(def-fp-data-processing-2 fsub #b0011)
2496(def-fp-data-processing-2 fmax #b0100)
2497(def-fp-data-processing-2 fmin #b0101)
2498(def-fp-data-processing-2 fmaxnm #b0110)
2499(def-fp-data-processing-2 fminnm #b0111)
2500(def-fp-data-processing-2 fnmul #b1000)
2501
2502(defmacro def-fp-data-processing-3 (name o1 o2)
2503  `(define-instruction ,name (segment rd rn rm ra)
2504     (:printer fp-data-processing-3 ((op1 ,o1) (op2 ,o2)))
2505     (:emitter
2506      (assert (and (eq (tn-sc rd)
2507                       (tn-sc rn))
2508                   (eq (tn-sc rd)
2509                       (tn-sc rm))
2510                   (eq (tn-sc rd)
2511                       (tn-sc ra)))
2512              (rd rn rm ra)
2513              "Arguments should have the same FP storage class: ~s ~s ~s ~s." rd rn rm ra)
2514      (emit-fp-data-processing-3 segment
2515                                 (fp-reg-type rn)
2516                                 ,o1
2517                                 (tn-offset rm)
2518                                 ,o2
2519                                 (tn-offset ra)
2520                                 (tn-offset rn)
2521                                 (tn-offset rd)))))
2522
2523(def-fp-data-processing-3 fmadd 0 0)
2524(def-fp-data-processing-3 fmsub 0 1)
2525(def-fp-data-processing-3 fnmadd 1 0)
2526(def-fp-data-processing-3 fnmsub 1 1)
2527
2528;;;
2529
2530(defmacro def-fp-conversion (name op &optional from-int)
2531  `(define-instruction ,name (segment rd rn)
2532     (:printer fp-conversion ((op ,op) (,(if from-int
2533                                               'rn
2534                                               'rd)
2535                                          nil :type 'reg)))
2536     (:emitter
2537      ,@(if from-int
2538            `((assert (fp-register-p rd)
2539                      (rd)
2540                      "Destination ~d should be an FP register." rd)
2541              (assert (register-p rn)
2542                      (rn)
2543                      "Source ~d should be an integer register." rn))
2544            `((assert (register-p rd)
2545                      (rd)
2546                      "Destination ~d should be an integer register." rn)
2547              (assert (fp-register-p rn)
2548                      (rn)
2549                      "Source ~d should be an FP register." rn)))
2550      (emit-fp-conversion segment
2551                         +64-bit-size+
2552                         (fp-reg-type ,(if from-int
2553                                           'rd
2554                                           'rn))
2555                         ,op
2556                         (tn-offset rn)
2557                         (tn-offset rd)))))
2558
2559(def-fp-conversion fcvtns #b00000)
2560(def-fp-conversion fcvtnu #b00001)
2561(def-fp-conversion scvtf #b00010 t)
2562(def-fp-conversion ucvtf #b00011 t)
2563(def-fp-conversion fcvtas #b00100)
2564(def-fp-conversion fcvtau #b00101)
2565(def-fp-conversion fcvtps #b01000)
2566(def-fp-conversion fcvtpu #b01001)
2567(def-fp-conversion fcvtms #b10000)
2568(def-fp-conversion fcvtmu #b10001)
2569(def-fp-conversion fcvtzs #b11000)
2570(def-fp-conversion fcvtzu #b11001)
2571
2572(define-instruction fmov (segment rd rn)
2573  (:printer fp-conversion ((op #b110) (rd nil :type 'reg)))
2574  (:printer fp-conversion ((op #b111) (rn nil :type 'reg)))
2575  (:printer fp-data-processing-1 ((op #b0)))
2576  (:emitter
2577   (cond ((or (sc-is rd complex-double-reg complex-single-reg)
2578              (sc-is rn complex-double-reg complex-single-reg)))
2579         ((and (fp-register-p rd)
2580               (fp-register-p rn))
2581          (assert (and (eq (tn-sc rd) (tn-sc rn))) (rd rn)
2582                  "Arguments should have the same fp storage class: ~s ~s."
2583                  rd rn)
2584          (emit-fp-data-processing-1 segment (fp-reg-type rn) 0
2585                                     (tn-offset rn) (tn-offset rd)))
2586         ((and (register-p rd)
2587               (fp-register-p rn))
2588          (let* ((type (fp-reg-type rn))
2589                 (128-p (= type #b10)))
2590            (emit-fp-conversion segment (if 128-p
2591                                            1
2592                                            type)
2593                                type
2594                                (if 128-p
2595                                    #b01111
2596                                    #b110)
2597                                (tn-offset rn) (tn-offset rd))))
2598         ((and (register-p rn)
2599               (fp-register-p rd))
2600          (let* ((type (fp-reg-type rd))
2601                 (128-p (= type #b10)))
2602            (emit-fp-conversion segment (if 128-p
2603                                            1
2604                                            type)
2605                                type
2606                                (if 128-p
2607                                    #b01111
2608                                    #b111)
2609                                (tn-offset rn) (tn-offset rd)))))))
2610
2611;;;; Boxed-object computation instructions (for LRA and CODE)
2612
2613;;; Compute the address of a CODE object by parsing the header of a
2614;;; nearby LRA or SIMPLE-FUN.
2615
2616(defun emit-compute (segment vop dest lip compute-delta)
2617  (labels ((multi-instruction-emitter (segment position)
2618             (let* ((delta (funcall compute-delta position))
2619                    (negative (minusp delta))
2620                    (delta (abs delta))
2621                    (low (* (if negative -1 1)
2622                            (ldb (byte 19 0) delta)))
2623                    (high (ldb (byte 16 19) delta)))
2624               ;; ADR
2625               (emit-pc-relative segment 0
2626                                 (ldb (byte 2 0) low)
2627                                 (ldb (byte 19 2) low)
2628                                 (tn-offset lip))
2629               (assemble (segment vop)
2630                 (inst movz tmp-tn high 16)
2631                 (if negative
2632                     (inst sub dest lip (lsl tmp-tn 3))
2633                     (inst add dest lip (lsl tmp-tn 3))))))
2634           (one-instruction-emitter (segment position)
2635             (let ((delta (funcall compute-delta position)))
2636               ;; ADR
2637               (emit-pc-relative segment 0
2638                                 (ldb (byte 2 0) delta)
2639                                 (ldb (byte 19 2) delta)
2640                                 (tn-offset dest))))
2641           (multi-instruction-maybe-shrink (segment posn magic-value)
2642             (when (typep (funcall compute-delta posn magic-value)
2643                          '(signed-byte 19))
2644               (emit-back-patch segment 4
2645                                #'one-instruction-emitter)
2646               t)))
2647    (emit-chooser
2648     segment 12 2
2649     #'multi-instruction-maybe-shrink
2650     #'multi-instruction-emitter)))
2651
2652(define-instruction compute-code (segment code lip object-label)
2653  (:vop-var vop)
2654  (:emitter
2655   (emit-compute segment vop code lip
2656                 (lambda (position &optional magic-value)
2657                   (declare (ignore magic-value))
2658                   (- other-pointer-lowtag
2659                      position
2660                      (component-header-length))))))
2661
2662(define-instruction compute-lra (segment dest lip lra-label)
2663  (:vop-var vop)
2664  (:emitter
2665   (emit-compute segment vop dest lip
2666                 (lambda (position &optional magic-value)
2667                   (- (+ (label-position lra-label
2668                                         (when magic-value position)
2669                                         magic-value)
2670                         other-pointer-lowtag)
2671                      position)))))
2672
2673(define-instruction load-from-label (segment dest label &optional lip)
2674  (:vop-var vop)
2675  (:emitter
2676   (labels ((compute-delta (position &optional magic-value)
2677              (- (label-position label
2678                                 (when magic-value position)
2679                                 magic-value)
2680                 position))
2681            (multi-instruction-emitter (segment position)
2682              (let* ((delta (compute-delta position))
2683                     (negative (minusp delta))
2684                     (low (ldb (byte 19 0) delta))
2685                     (high (ldb (byte 16 19) delta)))
2686               ;; ADR
2687               (emit-pc-relative segment 0
2688                                 (ldb (byte 2 0) low)
2689                                 (ldb (byte 19 2) low)
2690                                 (tn-offset lip))
2691               (assemble (segment vop)
2692                 (inst movz tmp-tn high 16)
2693                 (inst ldr dest (@ lip (extend tmp-tn (if negative
2694                                                          :sxtw
2695                                                          :lsl)
2696                                               3))))))
2697            (one-instruction-emitter (segment position)
2698              (emit-ldr-literal segment
2699                                #b01 0
2700                                (ldb (byte 19 0)
2701                                     (ash (compute-delta position) -2))
2702                                (tn-offset dest)))
2703            (multi-instruction-maybe-shrink (segment posn magic-value)
2704              (let ((delta (compute-delta posn magic-value)))
2705                (when (typep delta '(signed-byte 19))
2706                  (emit-back-patch segment 4
2707                                   #'one-instruction-emitter)
2708                  t))))
2709     (if lip
2710         (emit-chooser
2711          segment 12 2
2712          #'multi-instruction-maybe-shrink
2713          #'multi-instruction-emitter)
2714         (emit-back-patch segment 4 #'one-instruction-emitter)))))
2715
2716;;; SIMD
2717(def-emitter simd-three-diff
2718  (#b0 1 31)
2719  (q 1 30)
2720  (u 1 29)
2721  (#b01110 5 24)
2722  (size 2 22)
2723  (#b1 1 21)
2724  (rm 5 16)
2725  (opc 4 12)
2726  (0 2 10)
2727  (rn 5 5)
2728  (rd 5 0))
2729
2730(def-emitter simd-three-same
2731  (#b0 1 31)
2732  (q 1 30)
2733  (u 1 29)
2734  (#b01110 5 24)
2735  (size 2 22)
2736  (#b1 1 21)
2737  (rm 5 16)
2738  (opc 5 11)
2739  (#b1 1 10)
2740  (rn 5 5)
2741  (rd 5 0))
2742
2743(define-instruction-format (simd-three-same 32
2744                            :default-printer '(:name :tab rd ", " rn ", " rm))
2745  (op3 :field (byte 1 31) :value #b0)
2746  (u :field (byte 1 29))
2747  (op4 :field (byte 5 24) :value #b01110)
2748  (size :field (byte 2 22))
2749  (op5 :field (byte 1 21) :value #b1)
2750  (rm :fields (list (byte 1 30) (byte 5 16)) :type 'simd-reg)
2751  (op :field (byte 5 11))
2752  (op6 :field (byte 1 10) :value #b1)
2753  (rn :fields (list (byte 1 30) (byte 5 5)) :type 'simd-reg)
2754  (rd :fields (list (byte 1 30) (byte 5 0)) :type 'simd-reg))
2755
2756(defun decode-vector-size (size)
2757  (ecase size
2758    (:8b 0)
2759    (:16b 1)))
2760
2761(define-instruction s-orr (segment rd rn rm &optional (size :16b))
2762  (:printer simd-three-same ((u #b0) (size #b10) (op #b00011))
2763            '((:cond
2764                ((rn :same-as rm) 'mov)
2765                (t 'orr))
2766              :tab rd  ", " rn (:unless (:same-as rn) "," rm)))
2767  (:emitter
2768   (emit-simd-three-same segment
2769                         (decode-vector-size size)
2770                         #b0
2771                         #b10
2772                         (tn-offset rm)
2773                         #b00011
2774                         (tn-offset rn)
2775                         (tn-offset rd))))
2776
2777(define-instruction-macro s-mov (rd rn &optional (size :16b))
2778  `(let ((rd ,rd)
2779         (rn ,rn)
2780         (size ,size))
2781     (inst s-orr rd rn rn size)))
2782
2783;;;
2784
2785(def-emitter simd-extract
2786  (#b0 1 31)
2787  (q 1 30)
2788  (#b101110000 9 21)
2789  (rm 5 16)
2790  (#b0 1 15)
2791  (imm4 4 11)
2792  (#b0 1 10)
2793  (rn 5 5)
2794  (rd 5 0))
2795
2796(define-instruction s-ext (segment rd rn rm index &optional (size :16b))
2797  (:emitter
2798   (emit-simd-extract segment
2799                      (decode-vector-size size)
2800                      (tn-offset rm)
2801                      index
2802                      (tn-offset rn)
2803                      (tn-offset rd))))
2804
2805;;;
2806
2807(def-emitter simd-copy
2808  (#b0 1 31)
2809  (q 1 30)
2810  (op 1 29)
2811  (#b01110000 8 21)
2812  (imm5 5 16)
2813  (#b0 1 15)
2814  (imm4 4 11)
2815  (#b1 1 10)
2816  (rn 5 5)
2817  (rd 5 0))
2818
2819(define-instruction-format (simd-copy 32
2820                            :default-printer '(:name :tab rd ", " rn))
2821  (op3 :field (byte 1 31) :value #b0)
2822  (q :field (byte 1 30))
2823  (op :field (byte 1 29))
2824  (op4 :field (byte 8 21) :value #b01110000)
2825  (op5 :field (byte 1 15) :value #b0)
2826  (op6 :field (byte 1 10) :value #b1)
2827  (rn :fields (list (byte 5 5) (byte 5 16) (byte 4 11)) :type 'simd-copy-reg)
2828  (rd :fields (list (byte 5 0) (byte 5 16)) :type 'simd-copy-reg))
2829
2830(define-instruction s-ins (segment rd index1 rn index2 size)
2831  (:printer simd-copy ((q 1) (op 1))
2832            '('ins :tab rd ", " rn))
2833  (:emitter
2834   (let ((size (position size '(:B :H :S :D))))
2835     (emit-simd-copy segment
2836                         1
2837                         1
2838                         (logior (ash index1 (1+ size))
2839                                 (ash 1 size))
2840                         (ash index2 size)
2841                         (tn-offset rn)
2842                         (tn-offset rd)))))
2843
2844;;; Inline constants
2845(defun canonicalize-inline-constant (constant)
2846  (let ((first (car constant))
2847        alignedp)
2848    (when (eql first :aligned)
2849      (setf alignedp t)
2850      (pop constant)
2851      (setf first (car constant)))
2852    (typecase first
2853      ((cons (eql :fixup))
2854       (setf constant (list :fixup (cdr first))))
2855      (single-float (setf constant (list :single-float first)))
2856      (double-float (setf constant (list :double-float first)))
2857      .
2858      #+sb-xc-host
2859      ((complex
2860        ;; It's an error (perhaps) on the host to use simd-pack type.
2861        ;; [and btw it's disconcerting that this isn't an ETYPECASE.]
2862        (error "xc-host can't reference complex float")))
2863      #-sb-xc-host
2864      (((complex single-float)
2865        (setf constant (list :complex-single-float first)))
2866       ((complex double-float)
2867        (setf constant (list :complex-double-float first)))))
2868    (destructuring-bind (type value) constant
2869      (ecase type
2870        ((:byte :word :dword :qword)
2871         (aver (integerp value))
2872         (cons type value))
2873        (:base-char
2874         #!+sb-unicode (aver (typep value 'base-char))
2875         (cons :byte (char-code value)))
2876        (:character
2877         (aver (characterp value))
2878         (cons :dword (char-code value)))
2879        (:single-float
2880         (aver (typep value 'single-float))
2881         (cons (if alignedp :oword :dword)
2882               (ldb (byte 32 0) (single-float-bits value))))
2883        (:double-float
2884         (aver (typep value 'double-float))
2885         (cons (if alignedp :oword :qword)
2886               (ldb (byte 64 0) (logior (ash (double-float-high-bits value) 32)
2887                                        (double-float-low-bits value)))))
2888        (:complex-single-float
2889         (aver (typep value '(complex single-float)))
2890         (cons (if alignedp :oword :qword)
2891               (ldb (byte 64 0)
2892                    (logior (ash (single-float-bits (imagpart value)) 32)
2893                            (ldb (byte 32 0)
2894                                 (single-float-bits (realpart value)))))))
2895        (:complex-double-float
2896         (aver (typep value '(complex double-float)))
2897         (cons :oword
2898               (logior (ash (double-float-high-bits (imagpart value)) 96)
2899                       (ash (double-float-low-bits (imagpart value)) 64)
2900                       (ash (ldb (byte 32 0)
2901                                 (double-float-high-bits (realpart value)))
2902                            32)
2903                       (double-float-low-bits (realpart value)))))
2904        (:fixup
2905         (cons :fixup value))))))
2906
2907(defun inline-constant-value (constant)
2908  (let ((label (gen-label))
2909        (size  (ecase (car constant)
2910                 ((:byte :word :dword :qword) (car constant))
2911                 ((:oword :fixup) :qword))))
2912    (values label (cons size label))))
2913
2914(defun size-nbyte (size)
2915  (ecase size
2916    (:byte  1)
2917    (:word  2)
2918    (:dword 4)
2919    ((:qword :fixup) 8)
2920    (:oword 16)))
2921
2922(defun sort-inline-constants (constants)
2923  (stable-sort constants #'> :key (lambda (constant)
2924                                    (size-nbyte (caar constant)))))
2925
2926(defun emit-inline-constant (constant label)
2927  (let* ((type (car constant))
2928         (size (size-nbyte type)))
2929    (emit-alignment (integer-length (1- size)))
2930    (emit-label label)
2931    (let ((val (cdr constant)))
2932      (case type
2933        (:fixup
2934         (inst word (apply #'make-fixup val)))
2935        (t
2936         (loop repeat size
2937               do (inst byte (ldb (byte 8 0) val))
2938                  (setf val (ash val -8))))))))
2939