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