src/compiler/hppa/insts.lisp

   1 (in-package "SB!VM")
   2
   3 ;;; (def-assembler-params
   4 ;;;  :scheduler-p nil)
   5 (eval-when (:compile-toplevel :load-toplevel :execute)
   6   (setf sb!assem:*assem-scheduler-p* nil))
   7
   8 \f
   9 ;;;; Utility functions.
  10
  11 (defun reg-tn-encoding (tn)
  12   (declare (type tn tn))
  13   (sc-case tn
  14     (null null-offset)
  15     (zero zero-offset)
  16     (t
  17      (assert (eq (sb-name (sc-sb (tn-sc tn))) 'registers))
  18      (tn-offset tn))))
  19
  20 (defun fp-reg-tn-encoding (tn)
  21   (declare (type tn tn))
  22   (sc-case tn
  23     (fp-single-zero (values 0 nil))
  24     (single-reg (values (tn-offset tn) nil))
  25     (fp-double-zero (values 0 t))
  26     (double-reg (values (tn-offset tn) t))))
  27
  28 (defconstant-eqx compare-conditions
  29   '(:never := :< :<= :<< :<<= :sv :od :tr :<> :>= :> :>>= :>> :nsv :ev)
  30   #'equalp)
  31
  32 (deftype compare-condition ()
  33   `(member nil ,@compare-conditions))
  34
  35 (defun compare-condition (cond)
  36   (declare (type compare-condition cond))
  37   (if cond
  38       (let ((result (or (position cond compare-conditions :test #'eq)
  39                         (error "Bogus Compare/Subtract condition: ~S" cond))))
  40         (values (ldb (byte 3 0) result)
  41                 (logbitp 3 result)))
  42       (values 0 nil)))
  43
  44 (defconstant-eqx add-conditions
  45   '(:never := :< :<= :nuv :znv :sv :od :tr :<> :>= :> :uv :vnz :nsv :ev)
  46   #'equalp)
  47
  48 (deftype add-condition ()
  49   `(member nil ,@add-conditions))
  50
  51 (defun add-condition (cond)
  52     (declare (type add-condition cond))
  53   (if cond
  54       (let ((result (or (position cond add-conditions :test #'eq)
  55                         (error "Bogus Add condition: ~S" cond))))
  56         (values (ldb (byte 3 0) result)
  57                 (logbitp 3 result)))
  58       (values 0 nil)))
  59
  60 (defconstant-eqx logical-conditions
  61   '(:never := :< :<= nil nil nil :od :tr :<> :>= :> nil nil nil :ev)
  62   #'equalp)
  63
  64 (deftype logical-condition ()
  65   `(member nil ,@(remove nil logical-conditions)))
  66
  67 (defun logical-condition (cond)
  68     (declare (type logical-condition cond))
  69   (if cond
  70       (let ((result (or (position cond logical-conditions :test #'eq)
  71                         (error "Bogus Logical condition: ~S" cond))))
  72         (values (ldb (byte 3 0) result)
  73                 (logbitp 3 result)))
  74       (values 0 nil)))
  75
  76 (defconstant-eqx unit-conditions
  77   '(:never nil :sbz :shz :sdc :sbc :shc :tr nil :nbz :nhz :ndc :nbc :nhc)
  78   #'equalp)
  79
  80 (deftype unit-condition ()
  81   `(member nil ,@(remove nil unit-conditions)))
  82
  83 (defun unit-condition (cond)
  84   (declare (type unit-condition cond))
  85   (if cond
  86       (let ((result (or (position cond unit-conditions :test #'eq)
  87                         (error "Bogus Unit condition: ~S" cond))))
  88         (values (ldb (byte 3 0) result)
  89                 (logbitp 3 result)))
  90       (values 0 nil)))
  91
  92 (defconstant-eqx extract/deposit-conditions
  93   '(:never := :< :od :tr :<> :>= :ev)
  94   #'equalp)
  95
  96 (deftype extract/deposit-condition ()
  97   `(member nil ,@extract/deposit-conditions))
  98
  99 (defun extract/deposit-condition (cond)
 100   (declare (type extract/deposit-condition cond))
 101   (if cond
 102       (or (position cond extract/deposit-conditions :test #'eq)
 103           (error "Bogus Extract/Deposit condition: ~S" cond))
 104       0))
 105
 106
 107 (defun space-encoding (space)
 108   (declare (type (unsigned-byte 3) space))
 109   (dpb (ldb (byte 2 0) space)
 110        (byte 2 1)
 111        (ldb (byte 1 2) space)))
 112
 113 \f
 114 ;;;; Initial disassembler setup.
 115
 116 (setf sb!disassem:*disassem-inst-alignment-bytes* 4)
 117
 118 (defvar *disassem-use-lisp-reg-names* t)
 119
 120 (defparameter reg-symbols
 121   (map 'vector
 122        #'(lambda (name)
 123            (cond ((null name) nil)
 124                  (t (make-symbol (concatenate 'string "$" name)))))
 125        *register-names*))
 126
 127 (sb!disassem:define-arg-type reg
 128   :printer #'(lambda (value stream dstate)
 129                (declare (stream stream) (fixnum value))
 130                (let ((regname (aref reg-symbols value)))
 131                  (princ regname stream)
 132                  (sb!disassem:maybe-note-associated-storage-ref
 133                   value
 134                   'registers
 135                   regname
 136                   dstate))))
 137
 138 (defparameter float-reg-symbols
 139   #.(coerce
 140      (loop for n from 0 to 31 collect (make-symbol (format nil "$F~d" n)))
 141      'vector))
 142
 143 (sb!disassem:define-arg-type fp-reg
 144   :printer #'(lambda (value stream dstate)
 145                (declare (stream stream) (fixnum value))
 146                (let ((regname (aref float-reg-symbols value)))
 147                  (princ regname stream)
 148                  (sb!disassem:maybe-note-associated-storage-ref
 149                   value
 150                   'float-registers
 151                   regname
 152                   dstate))))
 153
 154 (sb!disassem:define-arg-type fp-fmt-0c
 155   :printer #'(lambda (value stream dstate)
 156                (declare (ignore dstate) (stream stream) (fixnum value))
 157                (ecase value
 158                  (0 (format stream "~A" '\,SGL))
 159                  (1 (format stream "~A" '\,DBL))
 160                  (3 (format stream "~A" '\,QUAD)))))
 161
 162 (defun low-sign-extend (x n)
 163   (let ((normal (dpb x (byte 1 (1- n)) (ldb (byte (1- n) 1) x))))
 164     (if (logbitp 0 x)
 165         (logior (ash -1 (1- n)) normal)
 166         normal)))
 167
 168 (defun sign-extend (x n)
 169   (if (logbitp (1- n) x)
 170       (logior (ash -1 (1- n)) x)
 171       x))
 172
 173 (defun assemble-bits (x list)
 174   (let ((result 0)
 175         (offset 0))
 176     (dolist (e (reverse list))
 177       (setf result (logior result (ash (ldb e x) offset)))
 178       (incf offset (byte-size e)))
 179     result))
 180
 181 (defmacro define-imx-decode (name bits)
 182   `(sb!disassem:define-arg-type ,name
 183      :printer #'(lambda (value stream dstate)
 184                   (declare (ignore dstate) (stream stream) (fixnum value))
 185                   (format stream "~S" (low-sign-extend value ,bits)))))
 186
 187 (define-imx-decode im5 5)
 188 (define-imx-decode im11 11)
 189 (define-imx-decode im14 14)
 190
 191 (sb!disassem:define-arg-type im3
 192   :printer #'(lambda (value stream dstate)
 193                (declare (ignore dstate) (stream stream) (fixnum value))
 194                (format stream "~S" (assemble-bits value `(,(byte 1 0)
 195                                                           ,(byte 2 1))))))
 196
 197 (sb!disassem:define-arg-type im21
 198   :printer #'(lambda (value stream dstate)
 199                (declare (ignore dstate) (stream stream) (fixnum value))
 200                (format stream "~S"
 201                        (assemble-bits value `(,(byte 1 0) ,(byte 11 1)
 202                                               ,(byte 2 14) ,(byte 5 16)
 203                                               ,(byte 2 12))))))
 204
 205 (sb!disassem:define-arg-type cp
 206   :printer #'(lambda (value stream dstate)
 207                (declare (ignore dstate) (stream stream) (fixnum value))
 208                (format stream "~S" (- 31 value))))
 209
 210 (sb!disassem:define-arg-type clen
 211   :printer #'(lambda (value stream dstate)
 212                (declare (ignore dstate) (stream stream) (fixnum value))
 213                (format stream "~S" (- 32 value))))
 214
 215 (sb!disassem:define-arg-type compare-condition
 216   :printer #("" \,= \,< \,<= \,<< \,<<= \,SV \,OD \,TR \,<> \,>=
 217              \,> \,>>= \,>> \,NSV \,EV))
 218
 219 (sb!disassem:define-arg-type compare-condition-false
 220   :printer #(\,TR \,<> \,>= \,> \,>>= \,>> \,NSV \,EV
 221              "" \,= \,< \,<= \,<< \,<<= \,SV \,OD))
 222
 223 (sb!disassem:define-arg-type add-condition
 224   :printer #("" \,= \,< \,<= \,NUV \,ZNV \,SV \,OD \,TR \,<> \,>= \,> \,UV
 225              \,VNZ \,NSV \,EV))
 226
 227 (sb!disassem:define-arg-type add-condition-false
 228   :printer #(\,TR \,<> \,>= \,> \,UV \,VNZ \,NSV \,EV
 229              "" \,= \,< \,<= \,NUV \,ZNV \,SV \,OD))
 230
 231 (sb!disassem:define-arg-type logical-condition
 232   :printer #("" \,= \,< \,<= "" "" "" \,OD \,TR \,<> \,>= \,> "" "" "" \,EV))
 233
 234 (sb!disassem:define-arg-type unit-condition
 235   :printer #("" "" \,SBZ \,SHZ \,SDC \,SBC \,SHC \,TR "" \,NBZ \,NHZ \,NDC
 236              \,NBC \,NHC))
 237
 238 (sb!disassem:define-arg-type extract/deposit-condition
 239   :printer #("" \,= \,< \,OD \,TR \,<> \,>= \,EV))
 240
 241 (sb!disassem:define-arg-type extract/deposit-condition-false
 242   :printer #(\,TR \,<> \,>= \,EV "" \,= \,< \,OD))
 243
 244 (sb!disassem:define-arg-type nullify
 245   :printer #("" \,N))
 246
 247 (sb!disassem:define-arg-type fcmp-cond
 248   :printer #(\FALSE? \FALSE \? \!<=> \= \=T \?= \!<> \!?>= \< \?<
 249                      \!>= \!?> \<= \?<= \!> \!?<= \> \?>\ \!<= \!?< \>=
 250                      \?>= \!< \!?= \<> \!= \!=T \!? \<=> \TRUE? \TRUE))
 251
 252 (sb!disassem:define-arg-type integer
 253   :printer #'(lambda (value stream dstate)
 254                (declare (ignore dstate) (stream stream) (fixnum value))
 255                (format stream "~S" value)))
 256
 257 (sb!disassem:define-arg-type space
 258   :printer #("" |1,| |2,| |3,|))
 259
 260 \f
 261 ;;;; Define-instruction-formats for disassembler.
 262
 263 (sb!disassem:define-instruction-format
 264     (load/store 32)
 265   (op   :field (byte 6 26))
 266   (b    :field (byte 5 21) :type 'reg)
 267   (t/r  :field (byte 5 16) :type 'reg)
 268   (s    :field (byte 2 14) :type 'space)
 269   (im14 :field (byte 14 0) :type 'im14))
 270
 271 (defconstant-eqx cmplt-index-print '((:cond ((u :constant 1) '\,S))
 272                                  (:cond ((m :constant 1) '\,M)))
 273   #'equalp)
 274
 275 (defconstant-eqx cmplt-disp-print '((:cond ((m :constant 1)
 276                                   (:cond ((s :constant 0) '\,MA)
 277                                          (t '\,MB)))))
 278   #'equalp)
 279
 280 (defconstant-eqx cmplt-store-print '((:cond ((s :constant 0) '\,B)
 281                                          (t '\,E))
 282                                   (:cond ((m :constant 1) '\,M)))
 283   #'equalp)
 284
 285 (sb!disassem:define-instruction-format
 286     (extended-load/store 32)
 287   (op1     :field (byte 6 26) :value 3)
 288   (b       :field (byte 5 21) :type 'reg)
 289   (x/im5/r :field (byte 5 16) :type 'reg)
 290   (s       :field (byte 2 14) :type 'space)
 291   (u       :field (byte 1 13))
 292   (op2     :field (byte 3 10))
 293   (ext4/c  :field (byte 4 6))
 294   (m       :field (byte 1 5))
 295   (t/im5   :field (byte 5 0) :type 'reg))
 296
 297 (sb!disassem:define-instruction-format
 298     (ldil 32 :default-printer '(:name :tab im21 "," t))
 299   (op    :field (byte 6 26))
 300   (t   :field (byte 5 21) :type 'reg)
 301   (im21 :field (byte 21 0) :type 'im21))
 302
 303 (sb!disassem:define-instruction-format
 304     (branch17 32)
 305   (op1 :field (byte 6 26))
 306   (t   :field (byte 5 21) :type 'reg)
 307   (w   :fields `(,(byte 5 16) ,(byte 11 2) ,(byte 1 0))
 308        :use-label
 309        #'(lambda (value dstate)
 310            (declare (type sb!disassem:disassem-state dstate) (list value))
 311            (let ((x (logior (ash (first value) 12) (ash (second value) 1)
 312                             (third value))))
 313              (+ (ash (sign-extend
 314                       (assemble-bits x `(,(byte 1 0) ,(byte 5 12) ,(byte 1 1)
 315                                          ,(byte 10 2))) 17) 2)
 316                 (sb!disassem:dstate-cur-addr dstate) 8))))
 317   (op2 :field (byte 3 13))
 318   (n   :field (byte 1 1) :type 'nullify))
 319
 320 (sb!disassem:define-instruction-format
 321     (branch12 32)
 322   (op1 :field (byte 6 26))
 323   (r2  :field (byte 5 21) :type 'reg)
 324   (r1  :field (byte 5 16) :type 'reg)
 325   (w   :fields `(,(byte 11 2) ,(byte 1 0))
 326        :use-label
 327        #'(lambda (value dstate)
 328            (declare (type sb!disassem:disassem-state dstate) (list value))
 329            (let ((x (logior (ash (first value) 1) (second value))))
 330              (+ (ash (sign-extend
 331                       (assemble-bits x `(,(byte 1 0) ,(byte 1 1) ,(byte 10 2)))
 332                       12) 2)
 333                 (sb!disassem:dstate-cur-addr dstate) 8))))
 334   (c   :field (byte 3 13))
 335   (n   :field (byte 1 1) :type 'nullify))
 336
 337 (sb!disassem:define-instruction-format
 338     (branch 32)
 339   (op1 :field (byte 6 26))
 340   (t   :field (byte 5 21) :type 'reg)
 341   (x   :field (byte 5 16) :type 'reg)
 342   (op2 :field (byte 3 13))
 343   (x1  :field (byte 11 2))
 344   (n   :field (byte 1 1) :type 'nullify)
 345   (x2  :field (byte 1 0)))
 346
 347 (sb!disassem:define-instruction-format
 348      (r3-inst 32 :default-printer '(:name c :tab r1 "," r2 "," t))
 349   (r3 :field (byte 6 26) :value 2)
 350   (r2 :field (byte 5 21) :type 'reg)
 351   (r1 :field (byte 5 16) :type 'reg)
 352   (c  :field (byte 3 13))
 353   (f  :field (byte 1 12))
 354   (op :field (byte 7 5))
 355   (t  :field (byte 5 0) :type 'reg))
 356
 357 (sb!disassem:define-instruction-format
 358     (imm-inst 32 :default-printer '(:name c :tab im11 "," r "," t))
 359   (op   :field (byte 6 26))
 360   (r    :field (byte 5 21) :type 'reg)
 361   (t    :field (byte 5 16) :type 'reg)
 362   (c    :field (byte 3 13))
 363   (f    :field (byte 1 12))
 364   (o    :field (byte 1 11))
 365   (im11 :field (byte 11 0) :type 'im11))
 366
 367 (sb!disassem:define-instruction-format
 368     (extract/deposit-inst 32)
 369   (op1    :field (byte 6 26))
 370   (r2     :field (byte 5 21) :type 'reg)
 371   (r1     :field (byte 5 16) :type 'reg)
 372   (c      :field (byte 3 13) :type 'extract/deposit-condition)
 373   (op2    :field (byte 3 10))
 374   (cp     :field (byte 5 5) :type 'cp)
 375   (t/clen :field (byte 5 0) :type 'clen))
 376
 377 (sb!disassem:define-instruction-format
 378     (break 32 :default-printer '(:name :tab im13 "," im5))
 379   (op1  :field (byte 6 26) :value 0)
 380   (im13 :field (byte 13 13))
 381   (q2   :field (byte 8 5) :value 0)
 382   (im5  :field (byte 5 0)))
 383
 384 (defun snarf-error-junk (sap offset &optional length-only)
 385   (let* ((length (sb!sys:sap-ref-8 sap offset))
 386          (vector (make-array length :element-type '(unsigned-byte 8))))
 387     (declare (type sb!sys:system-area-pointer sap)
 388              (type (unsigned-byte 8) length)
 389              (type (simple-array (unsigned-byte 8) (*)) vector))
 390     (cond (length-only
 391            (values 0 (1+ length) nil nil))
 392           (t
 393            (sb!kernel:copy-from-system-area sap (* n-byte-bits (1+ offset))
 394                                          vector (* n-word-bits
 395                                                    vector-data-offset)
 396                                          (* length n-byte-bits))
 397            (collect ((sc-offsets)
 398                      (lengths))
 399              (lengths 1)                ; the length byte
 400              (let* ((index 0)
 401                     (error-number (sb!c:read-var-integer vector index)))
 402                (lengths index)
 403                (loop
 404                  (when (>= index length)
 405                    (return))
 406                  (let ((old-index index))
 407                    (sc-offsets (sb!c:read-var-integer vector index))
 408                    (lengths (- index old-index))))
 409                (values error-number
 410                        (1+ length)
 411                        (sc-offsets)
 412                        (lengths))))))))
 413
 414 (defun break-control (chunk inst stream dstate)
 415   (declare (ignore inst))
 416   (flet ((nt (x) (if stream (sb!disassem:note x dstate))))
 417     (case (break-im5 chunk dstate)
 418       (#.sb!vm:error-trap
 419        (nt "Error trap")
 420        (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
 421       (#.sb!vm:cerror-trap
 422        (nt "Cerror trap")
 423        (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
 424       (#.sb!vm:breakpoint-trap
 425        (nt "Breakpoint trap"))
 426       (#.sb!vm:pending-interrupt-trap
 427        (nt "Pending interrupt trap"))
 428       (#.sb!vm:halt-trap
 429        (nt "Halt trap"))
 430       (#.sb!vm:fun-end-breakpoint-trap
 431        (nt "Function end breakpoint trap"))
 432     )))
 433
 434 (sb!disassem:define-instruction-format
 435     (system-inst 32)
 436   (op1 :field (byte 6 26) :value 0)
 437   (r1  :field (byte 5 21) :type 'reg)
 438   (r2  :field (byte 5 16) :type 'reg)
 439   (s   :field (byte 3 13))
 440   (op2 :field (byte 8 5))
 441   (r3  :field (byte 5 0) :type 'reg))
 442
 443 (sb!disassem:define-instruction-format
 444     (fp-load/store 32)
 445   (op :field (byte 6 26))
 446   (b  :field (byte 5 21) :type 'reg)
 447   (x  :field (byte 5 16) :type 'reg)
 448   (s  :field (byte 2 14) :type 'space)
 449   (u  :field (byte 1 13))
 450   (x1 :field (byte 1 12))
 451   (x2 :field (byte 2 10))
 452   (x3 :field (byte 1 9))
 453   (x4 :field (byte 3 6))
 454   (m  :field (byte 1 5))
 455   (t  :field (byte 5 0) :type 'fp-reg))
 456
 457 (sb!disassem:define-instruction-format
 458     (fp-class-0-inst 32)
 459   (op1 :field (byte 6 26))
 460   (r   :field (byte 5 21) :type 'fp-reg)
 461   (x1  :field (byte 5 16) :type 'fp-reg)
 462   (op2 :field (byte 3 13))
 463   (fmt :field (byte 2 11) :type 'fp-fmt-0c)
 464   (x2  :field (byte 2 9))
 465   (x3  :field (byte 3 6))
 466   (x4  :field (byte 1 5))
 467   (t   :field (byte 5 0) :type 'fp-reg))
 468
 469 (sb!disassem:define-instruction-format
 470     (fp-class-1-inst 32)
 471   (op1 :field (byte 6 26))
 472   (r   :field (byte 5 21) :type 'fp-reg)
 473   (x1  :field (byte 4 17) :value 0)
 474   (x2  :field (byte 2 15))
 475   (df  :field (byte 2 13) :type 'fp-fmt-0c)
 476   (sf  :field (byte 2 11) :type 'fp-fmt-0c)
 477   (x3  :field (byte 2 9) :value 1)
 478   (x4  :field (byte 3 6) :value 0)
 479   (x5  :field (byte 1 5) :value 0)
 480   (t   :field (byte 5 0) :type 'fp-reg))
 481
 482
 483 \f
 484 ;;;; Load and Store stuff.
 485
 486 (define-bitfield-emitter emit-load/store 32
 487   (byte 6 26)
 488   (byte 5 21)
 489   (byte 5 16)
 490   (byte 2 14)
 491   (byte 14 0))
 492
 493
 494 (defun im14-encoding (segment disp)
 495   (declare (type (or fixup (signed-byte 14))))
 496   (cond ((fixup-p disp)
 497          (note-fixup segment :load disp)
 498          (assert (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
 499          0)
 500         (t
 501          (dpb (ldb (byte 13 0) disp)
 502               (byte 13 1)
 503               (ldb (byte 1 13) disp)))))
 504
 505 (macrolet ((define-load-inst (name opcode)
 506                `(define-instruction ,name (segment disp base reg)
 507                  (:declare (type tn reg base)
 508                   (type (or fixup (signed-byte 14)) disp))
 509                  (:printer load/store ((op ,opcode) (s 0))
 510                   '(:name :tab im14 "(" s b ")," t/r))
 511                  (:emitter
 512                   (emit-load/store segment ,opcode
 513                    (reg-tn-encoding base) (reg-tn-encoding reg) 0
 514                    (im14-encoding segment disp)))))
 515            (define-store-inst (name opcode)
 516                `(define-instruction ,name (segment reg disp base)
 517                  (:declare (type tn reg base)
 518                   (type (or fixup (signed-byte 14)) disp))
 519                  (:printer load/store ((op ,opcode) (s 0))
 520                   '(:name :tab t/r "," im14 "(" s b ")"))
 521                  (:emitter
 522                   (emit-load/store segment ,opcode
 523                    (reg-tn-encoding base) (reg-tn-encoding reg) 0
 524                    (im14-encoding segment disp))))))
 525   (define-load-inst ldw #x12)
 526   (define-load-inst ldh #x11)
 527   (define-load-inst ldb #x10)
 528   (define-load-inst ldwm #x13)
 529   (define-load-inst ldo #x0D)
 530
 531   (define-store-inst stw #x1A)
 532   (define-store-inst sth #x19)
 533   (define-store-inst stb #x18)
 534   (define-store-inst stwm #x1B))
 535
 536 (define-bitfield-emitter emit-extended-load/store 32
 537   (byte 6 26) (byte 5 21) (byte 5 16) (byte 2 14) (byte 1 13)
 538   (byte 3 10) (byte 4 6) (byte 1 5) (byte 5 0))
 539
 540 (macrolet ((define-load-indexed-inst (name opcode)
 541               `(define-instruction ,name (segment index base reg &key modify scale)
 542                 (:declare (type tn reg base index)
 543                  (type (member t nil) modify scale))
 544                 (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'reg)
 545                                                (op2 0))
 546                  `(:name ,@cmplt-index-print :tab x/im5/r
 547                                               "(" s b ")" t/im5))
 548                 (:emitter
 549                  (emit-extended-load/store
 550                   segment #x03 (reg-tn-encoding base) (reg-tn-encoding index)
 551                   0 (if scale 1 0) 0 ,opcode (if modify 1 0)
 552                   (reg-tn-encoding reg))))))
 553   (define-load-indexed-inst ldwx 2)
 554   (define-load-indexed-inst ldhx 1)
 555   (define-load-indexed-inst ldbx 0)
 556   (define-load-indexed-inst ldcwx 7))
 557
 558 (defun short-disp-encoding (segment disp)
 559   (declare (type (or fixup (signed-byte 5)) disp))
 560   (cond ((fixup-p disp)
 561          (note-fixup segment :load-short disp)
 562          (assert (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
 563          0)
 564         (t
 565          (dpb (ldb (byte 4 0) disp)
 566               (byte 4 1)
 567               (ldb (byte 1 4) disp)))))
 568
 569 (macrolet ((define-load-short-inst (name opcode)
 570                `(define-instruction ,name (segment base disp reg &key modify)
 571                  (:declare (type tn base reg)
 572                   (type (or fixup (signed-byte 5)) disp)
 573                   (type (member :before :after nil) modify))
 574                  (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'im5)
 575                                                 (op2 4))
 576                   `(:name ,@cmplt-disp-print :tab x/im5/r
 577                     "(" s b ")" t/im5))
 578                  (:emitter
 579                   (multiple-value-bind
 580                         (m a)
 581                       (ecase modify
 582                         ((nil) (values 0 0))
 583                         (:after (values 1 0))
 584                         (:before (values 1 1)))
 585                     (emit-extended-load/store segment #x03 (reg-tn-encoding base)
 586                                               (short-disp-encoding segment disp)
 587                                               0 a 4 ,opcode m
 588                                               (reg-tn-encoding reg))))))
 589            (define-store-short-inst (name opcode)
 590                `(define-instruction ,name (segment reg base disp &key modify)
 591                  (:declare (type tn reg base)
 592                   (type (or fixup (signed-byte 5)) disp)
 593                   (type (member :before :after nil) modify))
 594                  (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'im5)
 595                                                 (op2 4))
 596                   `(:name ,@cmplt-disp-print :tab x/im5/r
 597                     "," t/im5 "(" s b ")"))
 598                  (:emitter
 599                   (multiple-value-bind
 600                         (m a)
 601                       (ecase modify
 602                         ((nil) (values 0 0))
 603                         (:after (values 1 0))
 604                         (:before (values 1 1)))
 605                     (emit-extended-load/store segment #x03 (reg-tn-encoding base)
 606                                               (short-disp-encoding segment disp)
 607                                               0 a 4 ,opcode m
 608                                               (reg-tn-encoding reg)))))))
 609   (define-load-short-inst ldws 2)
 610   (define-load-short-inst ldhs 1)
 611   (define-load-short-inst ldbs 0)
 612   (define-load-short-inst ldcws 7)
 613
 614   (define-store-short-inst stws 10)
 615   (define-store-short-inst sths 9)
 616   (define-store-short-inst stbs 8))
 617
 618 (define-instruction stbys (segment reg base disp where &key modify)
 619   (:declare (type tn reg base)
 620             (type (signed-byte 5) disp)
 621             (type (member :begin :end) where)
 622             (type (member t nil) modify))
 623   (:printer extended-load/store ((ext4/c #xC) (t/im5 nil :type 'im5) (op2 4))
 624             `(:name ,@cmplt-store-print :tab x/im5/r "," t/im5 "(" s b ")"))
 625   (:emitter
 626    (emit-extended-load/store segment #x03 (reg-tn-encoding base)
 627                              (reg-tn-encoding reg) 0
 628                              (ecase where (:begin 0) (:end 1))
 629                              4 #xC (if modify 1 0)
 630                              (short-disp-encoding segment disp))))
 631
 632 \f
 633 ;;;; Immediate Instructions.
 634
 635 (define-bitfield-emitter emit-ldil 32
 636   (byte 6 26)
 637   (byte 5 21)
 638   (byte 21 0))
 639
 640 (defun immed-21-encoding (segment value)
 641   (declare (type (or fixup (signed-byte 21) (unsigned-byte 21)) value))
 642   (cond ((fixup-p value)
 643          (note-fixup segment :hi value)
 644          (assert (or (null (fixup-offset value)) (zerop (fixup-offset value))))
 645          0)
 646         (t
 647          (logior (ash (ldb (byte 5 2) value) 16)
 648                  (ash (ldb (byte 2 7) value) 14)
 649                  (ash (ldb (byte 2 0) value) 12)
 650                  (ash (ldb (byte 11 9) value) 1)
 651                  (ldb (byte 1 20) value)))))
 652
 653 (define-instruction ldil (segment value reg)
 654   (:declare (type tn reg)
 655             (type (or (signed-byte 21) (unsigned-byte 21) fixup) value))
 656   (:printer ldil ((op #x08)))
 657   (:emitter
 658    (emit-ldil segment #x08 (reg-tn-encoding reg)
 659               (immed-21-encoding segment value))))
 660
 661 (define-instruction addil (segment value reg)
 662   (:declare (type tn reg)
 663             (type (or (signed-byte 21) (unsigned-byte 21) fixup) value))
 664   (:printer ldil ((op #x0A)))
 665   (:emitter
 666    (emit-ldil segment #x0A (reg-tn-encoding reg)
 667               (immed-21-encoding segment value))))
 668
 669 \f
 670 ;;;; Branch instructions.
 671
 672 (define-bitfield-emitter emit-branch 32
 673   (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
 674   (byte 11 2) (byte 1 1) (byte 1 0))
 675
 676 (defun label-relative-displacement (label posn &optional delta-if-after)
 677    (declare (type label label) (type index posn))
 678   (ash (- (if delta-if-after
 679               (label-position label posn delta-if-after)
 680               (label-position label))
 681           (+ posn 8)) -2))
 682
 683 (defun decompose-branch-disp (segment disp)
 684   (declare (type (or fixup (signed-byte 17)) disp))
 685   (cond ((fixup-p disp)
 686          (note-fixup segment :branch disp)
 687          (assert (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
 688          (values 0 0 0))
 689         (t
 690          (values (ldb (byte 5 11) disp)
 691                  (dpb (ldb (byte 10 0) disp)
 692                       (byte 10 1)
 693                       (ldb (byte 1 10) disp))
 694                  (ldb (byte 1 16) disp)))))
 695
 696 (defun emit-relative-branch (segment opcode link sub-opcode target nullify)
 697   (declare (type (unsigned-byte 6) opcode)
 698            (type (unsigned-byte 5) link)
 699            (type (unsigned-byte 1) sub-opcode)
 700            (type label target)
 701            (type (member t nil) nullify))
 702   (emit-back-patch segment 4
 703     #'(lambda (segment posn)
 704         (let ((disp (label-relative-displacement target posn)))
 705           (assert (<= (- (ash 1 16)) disp (1- (ash 1 16))))
 706           (multiple-value-bind
 707               (w1 w2 w)
 708               (decompose-branch-disp segment disp)
 709             (emit-branch segment opcode link w1 sub-opcode w2
 710                          (if nullify 1 0) w))))))
 711
 712 (define-instruction b (segment target &key nullify)
 713   (:declare (type label target) (type (member t nil) nullify))
 714   (:emitter
 715    (emit-relative-branch segment #x3A 0 0 target nullify)))
 716
 717 (define-instruction bl (segment target reg &key nullify)
 718   (:declare (type tn reg) (type label target) (type (member t nil) nullify))
 719   (:printer branch17 ((op1 #x3A) (op2 0)) '(:name n :tab w "," t))
 720   (:emitter
 721    (emit-relative-branch segment #x3A (reg-tn-encoding reg) 0 target nullify)))
 722
 723 (define-instruction gateway (segment target reg &key nullify)
 724   (:declare (type tn reg) (type label target) (type (member t nil) nullify))
 725   (:printer branch17 ((op1 #x3A) (op2 1)) '(:name n :tab w "," t))
 726   (:emitter
 727    (emit-relative-branch segment #x3A (reg-tn-encoding reg) 1 target nullify)))
 728
 729 ;;; BLR is useless because we have no way to generate the offset.
 730
 731 (define-instruction bv (segment base &key nullify offset)
 732   (:declare (type tn base)
 733             (type (member t nil) nullify)
 734             (type (or tn null) offset))
 735   (:printer branch ((op1 #x3A) (op2 6)) '(:name n :tab x "(" t ")"))
 736   (:emitter
 737    (emit-branch segment #x3A (reg-tn-encoding base)
 738                 (if offset (reg-tn-encoding offset) 0)
 739                 6 0 (if nullify 1 0) 0)))
 740
 741 (define-instruction be (segment disp space base &key nullify)
 742   (:declare (type (or fixup (signed-byte 17)) disp)
 743             (type tn base)
 744             (type (unsigned-byte 3) space)
 745             (type (member t nil) nullify))
 746   (:printer branch17 ((op1 #x38) (op2 nil :type 'im3))
 747             '(:name n :tab w "(" op2 "," t ")"))
 748   (:emitter
 749    (multiple-value-bind
 750        (w1 w2 w)
 751        (decompose-branch-disp segment disp)
 752      (emit-branch segment #x38 (reg-tn-encoding base) w1
 753                   (space-encoding space) w2 (if nullify 1 0) w))))
 754
 755 (define-instruction ble (segment disp space base &key nullify)
 756   (:declare (type (or fixup (signed-byte 17)) disp)
 757             (type tn base)
 758             (type (unsigned-byte 3) space)
 759             (type (member t nil) nullify))
 760   (:printer branch17 ((op1 #x39) (op2 nil :type 'im3))
 761             '(:name n :tab w "(" op2 "," t ")"))
 762   (:emitter
 763    (multiple-value-bind
 764        (w1 w2 w)
 765        (decompose-branch-disp segment disp)
 766      (emit-branch segment #x39 (reg-tn-encoding base) w1
 767                   (space-encoding space) w2 (if nullify 1 0) w))))
 768
 769 (defun emit-conditional-branch (segment opcode r2 r1 cond target nullify)
 770   (emit-back-patch segment 4
 771     #'(lambda (segment posn)
 772         (let ((disp (label-relative-displacement target posn)))
 773           (assert (<= (- (ash 1 11)) disp (1- (ash 1 11))))
 774           (let ((w1 (logior (ash (ldb (byte 10 0) disp) 1)
 775                             (ldb (byte 1 10) disp)))
 776                 (w (ldb (byte 1 11) disp)))
 777             (emit-branch segment opcode r2 r1 cond w1 (if nullify 1 0) w))))))
 778
 779 (defun im5-encoding (value)
 780   (declare (type (signed-byte 5) value)
 781            #+nil (values (unsigned-byte 5)))
 782   (dpb (ldb (byte 4 0) value)
 783        (byte 4 1)
 784        (ldb (byte 1 4) value)))
 785
 786 (macrolet ((define-branch-inst (r-name r-opcode i-name i-opcode cond-kind)
 787                (let* ((conditional (symbolicate cond-kind "-CONDITION"))
 788                       (false-conditional (symbolicate conditional "-FALSE")))
 789                  `(progn
 790                    (define-instruction ,r-name (segment cond r1 r2 target &key nullify)
 791                      (:declare (type ,conditional cond)
 792                       (type tn r1 r2)
 793                       (type label target)
 794                       (type (member t nil) nullify))
 795                      (:printer branch12 ((op1 ,r-opcode) (c nil :type ',conditional))
 796                       '(:name c n :tab r1 "," r2 "," w))
 797                      ,@(unless (= r-opcode #x32)
 798                                `((:printer branch12 ((op1 ,(+ 2 r-opcode))
 799                                                      (c nil :type ',false-conditional))
 800                                   '(:name c n :tab r1 "," r2 "," w))))
 801                      (:emitter
 802                       (multiple-value-bind
 803                             (cond-encoding false)
 804                           (,conditional cond)
 805                         (emit-conditional-branch
 806                          segment (if false ,(+ r-opcode 2) ,r-opcode)
 807                          (reg-tn-encoding r2) (reg-tn-encoding r1)
 808                          cond-encoding target nullify))))
 809                    (define-instruction ,i-name (segment cond imm reg target &key nullify)
 810                      (:declare (type ,conditional cond)
 811                       (type (signed-byte 5) imm)
 812                       (type tn reg)
 813                       (type (member t nil) nullify))
 814                      (:printer branch12 ((op1 ,i-opcode) (r1 nil :type 'im5)
 815                                          (c nil :type ',conditional))
 816                       '(:name c n :tab r1 "," r2 "," w))
 817                      ,@(unless (= r-opcode #x32)
 818                                `((:printer branch12 ((op1 ,(+ 2 i-opcode)) (r1 nil :type 'im5)
 819                                                      (c nil :type ',false-conditional))
 820                                   '(:name c n :tab r1 "," r2 "," w))))
 821                      (:emitter
 822                       (multiple-value-bind
 823                             (cond-encoding false)
 824                           (,conditional cond)
 825                         (emit-conditional-branch
 826                          segment (if false (+ ,i-opcode 2) ,i-opcode)
 827                          (reg-tn-encoding reg) (im5-encoding imm)
 828                          cond-encoding target nullify))))))))
 829   (define-branch-inst movb #x32 movib #x33 extract/deposit)
 830   (define-branch-inst comb #x20 comib #x21 compare)
 831   (define-branch-inst addb #x28 addib #x29 add))
 832
 833 (define-instruction bb (segment cond reg posn target &key nullify)
 834   (:declare (type (member t nil) cond nullify)
 835             (type tn reg)
 836             (type (or (member :variable) (unsigned-byte 5)) posn))
 837   (:printer branch12 ((op1 30) (c nil :type 'extract/deposit-condition))
 838                       '('BVB c n :tab r1 "," w))
 839   (:emitter
 840    (multiple-value-bind
 841        (opcode posn-encoding)
 842        (if (eq posn :variable)
 843            (values #x30 0)
 844            (values #x31 posn))
 845      (emit-conditional-branch segment opcode posn-encoding
 846                               (reg-tn-encoding reg)
 847                               (if cond 2 6) target nullify))))
 848
 849 \f
 850 ;;;; Computation Instructions
 851
 852 (define-bitfield-emitter emit-r3-inst 32
 853   (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
 854   (byte 1 12) (byte 7 5) (byte 5 0))
 855
 856 (macrolet ((define-r3-inst (name cond-kind opcode)
 857                `(define-instruction ,name (segment r1 r2 res &optional cond)
 858                  (:declare (type tn res r1 r2))
 859                  (:printer r3-inst ((op ,opcode) (c nil :type ',(symbolicate
 860                                                                  cond-kind
 861                                                                  "-CONDITION"))))
 862                  ,@(when (= opcode #x12)
 863                          `((:printer r3-inst ((op ,opcode) (r2 0)
 864                                               (c nil :type ',(symbolicate cond-kind
 865                                                                           "-CONDITION")))
 866                             `('COPY :tab r1 "," t))))
 867                  (:emitter
 868                   (multiple-value-bind
 869                         (cond false)
 870                       (,(symbolicate cond-kind "-CONDITION") cond)
 871                     (emit-r3-inst segment #x02 (reg-tn-encoding r2) (reg-tn-encoding r1)
 872                                   cond (if false 1 0) ,opcode
 873                                   (reg-tn-encoding res)))))))
 874   (define-r3-inst add add #x30)
 875   (define-r3-inst addl add #x50)
 876   (define-r3-inst addo add #x70)
 877   (define-r3-inst addc add #x38)
 878   (define-r3-inst addco add #x78)
 879   (define-r3-inst sh1add add #x32)
 880   (define-r3-inst sh1addl add #x52)
 881   (define-r3-inst sh1addo add #x72)
 882   (define-r3-inst sh2add add #x34)
 883   (define-r3-inst sh2addl add #x54)
 884   (define-r3-inst sh2addo add #x74)
 885   (define-r3-inst sh3add add #x36)
 886   (define-r3-inst sh3addl add #x56)
 887   (define-r3-inst sh3addo add #x76)
 888   (define-r3-inst sub compare #x20)
 889   (define-r3-inst subo compare #x60)
 890   (define-r3-inst subb compare #x28)
 891   (define-r3-inst subbo compare #x68)
 892   (define-r3-inst subt compare #x26)
 893   (define-r3-inst subto compare #x66)
 894   (define-r3-inst ds compare #x22)
 895   (define-r3-inst comclr compare #x44)
 896   (define-r3-inst or logical #x12)
 897   (define-r3-inst xor logical #x14)
 898   (define-r3-inst and logical #x10)
 899   (define-r3-inst andcm logical #x00)
 900   (define-r3-inst uxor unit #x1C)
 901   (define-r3-inst uaddcm unit #x4C)
 902   (define-r3-inst uaddcmt unit #x4E)
 903   (define-r3-inst dcor unit #x5C)
 904   (define-r3-inst idcor unit #x5E))
 905
 906 (define-bitfield-emitter emit-imm-inst 32
 907   (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
 908   (byte 1 12) (byte 1 11) (byte 11 0))
 909
 910 (defun im11-encoding (value)
 911   (declare (type (signed-byte 11) value)
 912            #+nil (values (unsigned-byte 11)))
 913   (dpb (ldb (byte 10 0) value)
 914        (byte 10 1)
 915        (ldb (byte 1 10) value)))
 916
 917 (macrolet ((define-imm-inst (name cond-kind opcode subcode)
 918                `(define-instruction ,name (segment imm src dst &optional cond)
 919                  (:declare (type tn dst src)
 920                   (type (signed-byte 11) imm))
 921                  (:printer imm-inst ((op ,opcode) (o ,subcode)
 922                                      (c nil :type
 923                                         ',(symbolicate cond-kind "-CONDITION"))))
 924                  (:emitter
 925                   (multiple-value-bind
 926                         (cond false)
 927                       (,(symbolicate cond-kind "-CONDITION") cond)
 928                     (emit-imm-inst segment ,opcode (reg-tn-encoding src)
 929                                    (reg-tn-encoding dst) cond
 930                                    (if false 1 0) ,subcode
 931                                    (im11-encoding imm)))))))
 932   (define-imm-inst addi add #x2D 0)
 933   (define-imm-inst addio add #x2D 1)
 934   (define-imm-inst addit add #x2C 0)
 935   (define-imm-inst addito add #x2C 1)
 936   (define-imm-inst subi compare #x25 0)
 937   (define-imm-inst subio compare #x25 1)
 938   (define-imm-inst comiclr compare #x24 0))
 939
 940 (define-bitfield-emitter emit-extract/deposit-inst 32
 941   (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
 942   (byte 3 10) (byte 5 5) (byte 5 0))
 943
 944 (define-instruction shd (segment r1 r2 count res &optional cond)
 945   (:declare (type tn res r1 r2)
 946             (type (or (member :variable) (integer 0 31)) count))
 947   (:printer extract/deposit-inst ((op1 #x34) (op2 2) (t/clen nil :type 'reg))
 948             '(:name c :tab r1 "," r2 "," cp "," t/clen))
 949   (:printer extract/deposit-inst ((op1 #x34) (op2 0) (t/clen nil :type 'reg))
 950             '('VSHD c :tab r1 "," r2 "," t/clen))
 951   (:emitter
 952    (etypecase count
 953      ((member :variable)
 954       (emit-extract/deposit-inst segment #x34
 955                                  (reg-tn-encoding r2) (reg-tn-encoding r1)
 956                                  (extract/deposit-condition cond)
 957                                  0 0 (reg-tn-encoding res)))
 958      ((integer 0 31)
 959       (emit-extract/deposit-inst segment #x34
 960                                  (reg-tn-encoding r2) (reg-tn-encoding r1)
 961                                  (extract/deposit-condition cond)
 962                                  2 (- 31 count)
 963                                  (reg-tn-encoding res))))))
 964
 965 (macrolet ((define-extract-inst (name opcode)
 966                `(define-instruction ,name (segment src posn len res &optional cond)
 967                  (:declare (type tn res src)
 968                   (type (or (member :variable) (integer 0 31)) posn)
 969                   (type (integer 1 32) len))
 970                  (:printer extract/deposit-inst ((op1 #x34) (cp nil :type 'integer)
 971                                                  (op2 ,opcode))
 972                   '(:name c :tab r2 "," cp "," t/clen "," r1))
 973                  (:printer extract/deposit-inst ((op1 #x34) (op2 ,(- opcode 2)))
 974                   '('V :name c :tab r2 "," t/clen "," r1))
 975                  (:emitter
 976                   (etypecase posn
 977                     ((member :variable)
 978                      (emit-extract/deposit-inst segment #x34 (reg-tn-encoding src)
 979                                                 (reg-tn-encoding res)
 980                                                 (extract/deposit-condition cond)
 981                                                 ,(- opcode 2) 0 (- 32 len)))
 982                     ((integer 0 31)
 983                      (emit-extract/deposit-inst segment #x34 (reg-tn-encoding src)
 984                                                 (reg-tn-encoding res)
 985                                                 (extract/deposit-condition cond)
 986                                                 ,opcode posn (- 32 len))))))))
 987   (define-extract-inst extru 6)
 988   (define-extract-inst extrs 7))
 989
 990 (macrolet ((define-deposit-inst (name opcode)
 991                `(define-instruction ,name (segment src posn len res &optional cond)
 992                  (:declare (type tn res)
 993                   (type (or tn (signed-byte 5)) src)
 994                   (type (or (member :variable) (integer 0 31)) posn)
 995                   (type (integer 1 32) len))
 996                  (:printer extract/deposit-inst ((op1 #x35) (op2 ,opcode))
 997                   ',(let ((base '('VDEP c :tab r1 "," t/clen "," r2)))
 998                          (if (= opcode 0) (cons ''Z base) base)))
 999                  (:printer extract/deposit-inst ((op1 #x35) (op2 ,(+ 2 opcode)))
1000                   ',(let ((base '('DEP c :tab r1 "," cp "," t/clen "," r2)))
1001                          (if (= opcode 0) (cons ''Z base) base)))
1002                  (:printer extract/deposit-inst ((op1 #x35) (r1 nil :type 'im5)
1003                                                  (op2 ,(+ 4 opcode)))
1004                   ',(let ((base '('VDEPI c :tab r1 "," t/clen "," r2)))
1005                          (if (= opcode 0) (cons ''Z base) base)))
1006                  (:printer extract/deposit-inst ((op1 #x35) (r1 nil :type 'im5)
1007                                                  (op2 ,(+ 6 opcode)))
1008                   ',(let ((base '('DEPI c :tab r1 "," cp "," t/clen "," r2)))
1009                          (if (= opcode 0) (cons ''Z base) base)))
1010                  (:emitter
1011                   (multiple-value-bind
1012                         (opcode src-encoding)
1013                       (etypecase src
1014                         (tn
1015                          (values ,opcode (reg-tn-encoding src)))
1016                         ((signed-byte 5)
1017                          (values ,(+ opcode 4) (im5-encoding src))))
1018                     (multiple-value-bind
1019                           (opcode posn-encoding)
1020                         (etypecase posn
1021                           ((member :variable)
1022                            (values opcode 0))
1023                           ((integer 0 31)
1024                            (values (+ opcode 2) (- 31 posn))))
1025                       (emit-extract/deposit-inst segment #x35 (reg-tn-encoding res)
1026                                                  src-encoding
1027                                                  (extract/deposit-condition cond)
1028                                                  opcode posn-encoding (- 32 len))))))))
1029
1030   (define-deposit-inst dep 1)
1031   (define-deposit-inst zdep 0))
1032
1033
1034 \f
1035 ;;;; System Control Instructions.
1036
1037 (define-bitfield-emitter emit-break 32
1038   (byte 6 26) (byte 13 13) (byte 8 5) (byte 5 0))
1039
1040 (define-instruction break (segment &optional (im5 0) (im13 0))
1041   (:declare (type (unsigned-byte 13) im13)
1042             (type (unsigned-byte 5) im5))
1043   (:printer break () :default :control #'break-control)
1044   (:emitter
1045    (emit-break segment 0 im13 0 im5)))
1046
1047 (define-bitfield-emitter emit-system-inst 32
1048   (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 8 5) (byte 5 0))
1049
1050 (define-instruction ldsid (segment res base &optional (space 0))
1051   (:declare (type tn res base)
1052             (type (integer 0 3) space))
1053   (:printer system-inst ((op2 #x85) (c nil :type 'space)
1054                          (s nil  :printer #(0 0 1 1 2 2 3 3)))
1055             `(:name :tab "(" s r1 ")," r3))
1056   (:emitter
1057    (emit-system-inst segment 0 (reg-tn-encoding base) 0 (ash space 1) #x85
1058                      (reg-tn-encoding res))))
1059
1060 (define-instruction mtsp (segment reg space)
1061   (:declare (type tn reg) (type (integer 0 7) space))
1062   (:printer system-inst ((op2 #xC1)) '(:name :tab r2 "," s))
1063   (:emitter
1064    (emit-system-inst segment 0 0 (reg-tn-encoding reg) (space-encoding space)
1065                      #xC1 0)))
1066
1067 (define-instruction mfsp (segment space reg)
1068   (:declare (type tn reg) (type (integer 0 7) space))
1069   (:printer system-inst ((op2 #x25) (c nil :type 'space)) '(:name :tab s r3))
1070   (:emitter
1071    (emit-system-inst segment 0 0 0 (space-encoding space) #x25
1072                      (reg-tn-encoding reg))))
1073
1074 (deftype control-reg ()
1075   '(or (unsigned-byte 5) (member :sar)))
1076
1077 (defun control-reg (reg)
1078   (declare (type control-reg reg)
1079            #+nil (values (unsigned-byte 32)))
1080   (if (typep reg '(unsigned-byte 5))
1081       reg
1082       (ecase reg
1083         (:sar 11))))
1084
1085 (define-instruction mtctl (segment reg ctrl-reg)
1086   (:declare (type tn reg) (type control-reg ctrl-reg))
1087   (:printer system-inst ((op2 #xC2)) '(:name :tab r2 "," r1))
1088   (:emitter
1089    (emit-system-inst segment 0 (control-reg ctrl-reg) (reg-tn-encoding reg)
1090                      0 #xC2 0)))
1091
1092 (define-instruction mfctl (segment ctrl-reg reg)
1093   (:declare (type tn reg) (type control-reg ctrl-reg))
1094   (:printer system-inst ((op2 #x45)) '(:name :tab r1 "," r3))
1095   (:emitter
1096    (emit-system-inst segment 0 (control-reg ctrl-reg) 0 0 #x45
1097                      (reg-tn-encoding reg))))
1098
1099
1100 \f
1101 ;;;; Floating point instructions.
1102
1103 (define-bitfield-emitter emit-fp-load/store 32
1104   (byte 6 26) (byte 5 21) (byte 5 16) (byte 2 14) (byte 1 13) (byte 1 12)
1105   (byte 2 10) (byte 1 9) (byte 3 6) (byte 1 5) (byte 5 0))
1106
1107 (define-instruction fldx (segment index base result &key modify scale side)
1108   (:declare (type tn index base result)
1109             (type (member t nil) modify scale)
1110             (type (member nil 0 1) side))
1111   (:printer fp-load/store ((op #x0b) (x1 0) (x2 0) (x3 0))
1112             `('FLDDX ,@cmplt-index-print :tab x "(" s b ")" "," t))
1113   (:printer fp-load/store ((op #x09) (x1 0) (x2 0) (x3 0))
1114             `('FLDWX ,@cmplt-index-print :tab x "(" s b ")" "," t))
1115   (:emitter
1116    (multiple-value-bind
1117        (result-encoding double-p)
1118        (fp-reg-tn-encoding result)
1119      (when side
1120        (assert double-p)
1121        (setf double-p nil))
1122      (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
1123                          (reg-tn-encoding index) 0 (if scale 1 0) 0 0 0
1124                          (or side 0) (if modify 1 0) result-encoding))))
1125
1126 (define-instruction fstx (segment value index base &key modify scale side)
1127   (:declare (type tn index base value)
1128             (type (member t nil) modify scale)
1129             (type (member nil 0 1) side))
1130   (:printer fp-load/store ((op #x0b) (x1 0) (x2 0) (x3 1))
1131             `('FSTDX ,@cmplt-index-print :tab t "," x "(" s b ")"))
1132   (:printer fp-load/store ((op #x09) (x1 0) (x2 0) (x3 1))
1133             `('FSTWX ,@cmplt-index-print :tab t "," x "(" s b ")"))
1134   (:emitter
1135    (multiple-value-bind
1136        (value-encoding double-p)
1137        (fp-reg-tn-encoding value)
1138      (when side
1139        (assert double-p)
1140        (setf double-p nil))
1141      (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
1142                          (reg-tn-encoding index) 0 (if scale 1 0) 0 0 1
1143                          (or side 0) (if modify 1 0) value-encoding))))
1144
1145 (define-instruction flds (segment disp base result &key modify side)
1146   (:declare (type tn base result)
1147             (type (signed-byte 5) disp)
1148             (type (member :before :after nil) modify)
1149             (type (member nil 0 1) side))
1150   (:printer fp-load/store ((op #x0b) (x nil :type 'im5) (x1 1) (x2 0) (x3 0))
1151             `('FLDDS ,@cmplt-disp-print :tab x "(" s b ")," t))
1152   (:printer fp-load/store ((op #x09) (x nil :type 'im5) (x1 1) (x2 0) (x3 0))
1153             `('FLDWS ,@cmplt-disp-print :tab x "(" s b ")," t))
1154   (:emitter
1155    (multiple-value-bind
1156        (result-encoding double-p)
1157        (fp-reg-tn-encoding result)
1158      (when side
1159        (assert double-p)
1160        (setf double-p nil))
1161      (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
1162                          (short-disp-encoding segment disp) 0
1163                          (if (eq modify :before) 1 0) 1 0 0
1164                          (or side 0) (if modify 1 0) result-encoding))))
1165
1166 (define-instruction fsts (segment value disp base &key modify side)
1167   (:declare (type tn base value)
1168             (type (signed-byte 5) disp)
1169             (type (member :before :after nil) modify)
1170             (type (member nil 0 1) side))
1171   (:printer fp-load/store ((op #x0b) (x nil :type 'im5) (x1 1) (x2 0) (x3 1))
1172             `('FSTDS ,@cmplt-disp-print :tab t "," x "(" s b ")"))
1173   (:printer fp-load/store ((op #x09) (x nil :type 'im5) (x1 1) (x2 0) (x3 1))
1174             `('FSTWS ,@cmplt-disp-print :tab t "," x "(" s b ")"))
1175   (:emitter
1176    (multiple-value-bind
1177        (value-encoding double-p)
1178        (fp-reg-tn-encoding value)
1179      (when side
1180        (assert double-p)
1181        (setf double-p nil))
1182      (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
1183                          (short-disp-encoding segment disp) 0
1184                          (if (eq modify :before) 1 0) 1 0 1
1185                          (or side 0) (if modify 1 0) value-encoding))))
1186
1187
1188 (define-bitfield-emitter emit-fp-class-0-inst 32
1189   (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 2 11) (byte 2 9)
1190   (byte 3 6) (byte 1 5) (byte 5 0))
1191
1192 (define-bitfield-emitter emit-fp-class-1-inst 32
1193   (byte 6 26) (byte 5 21) (byte 4 17) (byte 2 15) (byte 2 13) (byte 2 11)
1194   (byte 2 9) (byte 3 6) (byte 1 5) (byte 5 0))
1195
1196 ;;; Note: classes 2 and 3 are similar enough to class 0 that we don't need
1197 ;;; seperate emitters.
1198
1199 (defconstant-eqx funops '(:copy :abs :sqrt :rnd)
1200   #'equalp)
1201
1202 (deftype funop ()
1203   `(member ,@funops))
1204
1205 (define-instruction funop (segment op from to)
1206   (:declare (type funop op)
1207             (type tn from to))
1208   (:printer fp-class-0-inst ((op1 #x0C) (op2 2) (x2 0))
1209             '('FCPY fmt :tab r "," t))
1210   (:printer fp-class-0-inst ((op1 #x0C) (op2 3) (x2 0))
1211             '('FABS fmt  :tab r "," t))
1212   (:printer fp-class-0-inst ((op1 #x0C) (op2 4) (x2 0))
1213             '('FSQRT fmt :tab r "," t))
1214   (:printer fp-class-0-inst ((op1 #x0C) (op2 5) (x2 0))
1215             '('FRND fmt :tab r "," t))
1216   (:emitter
1217    (multiple-value-bind
1218        (from-encoding from-double-p)
1219        (fp-reg-tn-encoding from)
1220      (multiple-value-bind
1221          (to-encoding to-double-p)
1222          (fp-reg-tn-encoding to)
1223        (assert (eq from-double-p to-double-p))
1224        (emit-fp-class-0-inst segment #x0C from-encoding 0
1225                              (+ 2 (or (position op funops)
1226                                       (error "Bogus FUNOP: ~S" op)))
1227                              (if to-double-p 1 0) 0 0 0 to-encoding)))))
1228
1229 (macrolet ((define-class-1-fp-inst (name subcode)
1230                `(define-instruction ,name (segment from to)
1231                  (:declare (type tn from to))
1232                  (:printer fp-class-1-inst ((op1 #x0C) (x2 ,subcode))
1233                   '(:name sf df :tab r "," t))
1234                  (:emitter
1235                   (multiple-value-bind
1236                         (from-encoding from-double-p)
1237                       (fp-reg-tn-encoding from)
1238                     (multiple-value-bind
1239                           (to-encoding to-double-p)
1240                         (fp-reg-tn-encoding to)
1241                       (emit-fp-class-1-inst segment #x0C from-encoding 0 ,subcode
1242                                             (if to-double-p 1 0) (if from-double-p 1 0)
1243                                             1 0 0 to-encoding)))))))
1244
1245   (define-class-1-fp-inst fcnvff 0)
1246   (define-class-1-fp-inst fcnvxf 1)
1247   (define-class-1-fp-inst fcnvfx 2)
1248   (define-class-1-fp-inst fcnvfxt 3))
1249
1250 (define-instruction fcmp (segment cond r1 r2)
1251   (:declare (type (unsigned-byte 5) cond)
1252             (type tn r1 r2))
1253   (:printer fp-class-0-inst ((op1 #x0C) (op2 0) (x2 2) (t nil :type 'fcmp-cond))
1254             '(:name fmt t :tab r "," x1))
1255   (:emitter
1256    (multiple-value-bind
1257        (r1-encoding r1-double-p)
1258        (fp-reg-tn-encoding r1)
1259      (multiple-value-bind
1260          (r2-encoding r2-double-p)
1261          (fp-reg-tn-encoding r2)
1262        (assert (eq r1-double-p r2-double-p))
1263        (emit-fp-class-0-inst segment #x0C r1-encoding r2-encoding 0
1264                              (if r1-double-p 1 0) 2 0 0 cond)))))
1265
1266 (define-instruction ftest (segment)
1267   (:printer fp-class-0-inst ((op1 #x0c) (op2 1) (x2 2)) '(:name))
1268   (:emitter
1269    (emit-fp-class-0-inst segment #x0C 0 0 1 0 2 0 1 0)))
1270
1271 (defconstant-eqx fbinops '(:add :sub :mpy :div)
1272   #'equalp)
1273
1274 (deftype fbinop ()
1275   `(member ,@fbinops))
1276
1277 (define-instruction fbinop (segment op r1 r2 result)
1278   (:declare (type fbinop op)
1279             (type tn r1 r2 result))
1280   (:printer fp-class-0-inst ((op1 #x0C) (op2 0) (x2 3))
1281             '('FADD fmt :tab r "," x1 "," t))
1282   (:printer fp-class-0-inst ((op1 #x0C) (op2 1) (x2 3))
1283             '('FSUB fmt :tab r "," x1 "," t))
1284   (:printer fp-class-0-inst ((op1 #x0C) (op2 2) (x2 3))
1285             '('FMPY fmt :tab r "," x1 "," t))
1286   (:printer fp-class-0-inst ((op1 #x0C) (op2 3) (x2 3))
1287             '('FDIV fmt :tab r "," x1 "," t))
1288   (:emitter
1289    (multiple-value-bind
1290        (r1-encoding r1-double-p)
1291        (fp-reg-tn-encoding r1)
1292      (multiple-value-bind
1293          (r2-encoding r2-double-p)
1294          (fp-reg-tn-encoding r2)
1295        (assert (eq r1-double-p r2-double-p))
1296        (multiple-value-bind
1297            (result-encoding result-double-p)
1298            (fp-reg-tn-encoding result)
1299          (assert (eq r1-double-p result-double-p))
1300          (emit-fp-class-0-inst segment #x0C r1-encoding r2-encoding
1301                                (or (position op fbinops)
1302                                    (error "Bogus FBINOP: ~S" op))
1303                                (if r1-double-p 1 0) 3 0 0
1304                                result-encoding))))))
1305
1306
1307 \f
1308 ;;;; Instructions built out of other insts.
1309
1310 (define-instruction-macro move (src dst &optional cond)
1311   `(inst or ,src zero-tn ,dst ,cond))
1312
1313 (define-instruction-macro nop (&optional cond)
1314   `(inst or zero-tn zero-tn zero-tn ,cond))
1315
1316 (define-instruction li (segment value reg)
1317   (:declare (type tn reg)
1318             (type (or fixup (signed-byte 32) (unsigned-byte 32)) value))
1319   (:vop-var vop)
1320   (:emitter
1321    (assemble (segment vop)
1322      (etypecase value
1323        (fixup
1324         (inst ldil value reg)
1325         (inst ldo value reg reg))
1326        ((signed-byte 14)
1327         (inst ldo value zero-tn reg))
1328        ((or (signed-byte 32) (unsigned-byte 32))
1329         (let ((hi (ldb (byte 21 11) value))
1330               (lo (ldb (byte 11 0) value)))
1331           (inst ldil hi reg)
1332           (unless (zerop lo)
1333             (inst ldo lo reg reg))))))))
1334
1335 (define-instruction-macro sll (src count result &optional cond)
1336   (once-only ((result result) (src src) (count count) (cond cond))
1337     `(inst zdep ,src (- 31 ,count) (- 32 ,count) ,result ,cond)))
1338
1339 (define-instruction-macro sra (src count result &optional cond)
1340   (once-only ((result result) (src src) (count count) (cond cond))
1341     `(inst extrs ,src (- 31 ,count) (- 32 ,count) ,result ,cond)))
1342
1343 (define-instruction-macro srl (src count result &optional cond)
1344   (once-only ((result result) (src src) (count count) (cond cond))
1345     `(inst extru ,src (- 31 ,count) (- 32 ,count) ,result ,cond)))
1346
1347 (defun maybe-negate-cond (cond negate)
1348   (if negate
1349       (multiple-value-bind
1350           (value negate)
1351           (compare-condition cond)
1352         (if negate
1353             (nth value compare-conditions)
1354             (nth (+ value 8) compare-conditions)))
1355       cond))
1356
1357 (define-instruction bc (segment cond not-p r1 r2 target)
1358   (:declare (type compare-condition cond)
1359             (type (member t nil) not-p)
1360             (type tn r1 r2)
1361             (type label target))
1362   (:vop-var vop)
1363   (:emitter
1364    (emit-chooser segment 8 2
1365      #'(lambda (segment posn delta)
1366          (let ((disp (label-relative-displacement target posn delta)))
1367            (when (<= 0 disp (1- (ash 1 11)))
1368              (assemble (segment vop)
1369                (inst comb (maybe-negate-cond cond not-p) r1 r2 target
1370                      :nullify t))
1371              t)))
1372      #'(lambda (segment posn)
1373          (let ((disp (label-relative-displacement target posn)))
1374            (assemble (segment vop)
1375              (cond ((<= (- (ash 1 11)) disp (1- (ash 1 11)))
1376                     (inst comb (maybe-negate-cond cond not-p) r1 r2 target)
1377                     (inst nop))
1378                    (t
1379                     (inst comclr r1 r2 zero-tn
1380                           (maybe-negate-cond cond (not not-p)))
1381                     (inst b target :nullify t)))))))))
1382
1383 (define-instruction bci (segment cond not-p imm reg target)
1384   (:declare (type compare-condition cond)
1385             (type (member t nil) not-p)
1386             (type (signed-byte 11) imm)
1387             (type tn reg)
1388             (type label target))
1389   (:vop-var vop)
1390   (:emitter
1391    (emit-chooser segment 8 2
1392      #'(lambda (segment posn delta-if-after)
1393          (let ((disp (label-relative-displacement target posn delta-if-after)))
1394            (when (and (<= 0 disp (1- (ash 1 11)))
1395                       (<= (- (ash 1 4)) imm (1- (ash 1 4))))
1396              (assemble (segment vop)
1397                (inst comib (maybe-negate-cond cond not-p) imm reg target
1398                      :nullify t))
1399              t)))
1400      #'(lambda (segment posn)
1401          (let ((disp (label-relative-displacement target posn)))
1402            (assemble (segment vop)
1403              (cond ((and (<= (- (ash 1 11)) disp (1- (ash 1 11)))
1404                          (<= (- (ash 1 4)) imm (1- (ash 1 4))))
1405                     (inst comib (maybe-negate-cond cond not-p) imm reg target)
1406                     (inst nop))
1407                    (t
1408                     (inst comiclr imm reg zero-tn
1409                           (maybe-negate-cond cond (not not-p)))
1410                     (inst b target :nullify t)))))))))
1411
1412 \f
1413 ;;;; Instructions to convert between code ptrs, functions, and lras.
1414
1415 (defun emit-compute-inst (segment vop src label temp dst calc)
1416   (emit-chooser
1417       ;; We emit either 12 or 4 bytes, so we maintain 3 byte alignments.
1418       segment 12 3
1419     #'(lambda (segment posn delta-if-after)
1420         (let ((delta (funcall calc label posn delta-if-after)))
1421           (when (<= (- (ash 1 10)) delta (1- (ash 1 10)))
1422             (emit-back-patch segment 4
1423                              #'(lambda (segment posn)
1424                                  (assemble (segment vop)
1425                                    (inst addi (funcall calc label posn 0) src
1426                                          dst))))
1427             t)))
1428     #'(lambda (segment posn)
1429         (let ((delta (funcall calc label posn 0)))
1430           ;; Note: if we used addil/ldo to do this in 2 instructions then the
1431           ;; intermediate value would be tagged but pointing into space.
1432           (assemble (segment vop)
1433             (inst ldil (ldb (byte 21 11) delta) temp)
1434             (inst ldo (ldb (byte 11 0) delta) temp temp)
1435             (inst add src temp dst))))))
1436
1437 ;; code = fn - header - label-offset + other-pointer-tag
1438 (define-instruction compute-code-from-fn (segment src label temp dst)
1439   (:declare (type tn src dst temp)
1440             (type label label))
1441   (:vop-var vop)
1442   (:emitter
1443    (emit-compute-inst segment vop src label temp dst
1444                       #'(lambda (label posn delta-if-after)
1445                           (- other-pointer-lowtag
1446                              (label-position label posn delta-if-after)
1447                              (component-header-length))))))
1448
1449 ;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
1450 (define-instruction compute-code-from-lra (segment src label temp dst)
1451   (:declare (type tn src dst temp)
1452             (type label label))
1453   (:vop-var vop)
1454   (:emitter
1455    (emit-compute-inst segment vop src label temp dst
1456                       #'(lambda (label posn delta-if-after)
1457                           (- (+ (label-position label posn delta-if-after)
1458                                 (component-header-length)))))))
1459
1460 ;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
1461 (define-instruction compute-lra-from-code (segment src label temp dst)
1462   (:declare (type tn src dst temp)
1463             (type label label))
1464   (:vop-var vop)
1465   (:emitter
1466    (emit-compute-inst segment vop src label temp dst
1467                       #'(lambda (label posn delta-if-after)
1468                           (+ (label-position label posn delta-if-after)
1469                              (component-header-length))))))
1470
1471 \f
1472 ;;;; Data instructions.
1473
1474 (define-instruction byte (segment byte)
1475   (:emitter
1476    (emit-byte segment byte)))
1477
1478 (define-bitfield-emitter emit-halfword 16
1479   (byte 16 0))
1480
1481 (define-instruction halfword (segment halfword)
1482   (:emitter
1483    (emit-halfword segment halfword)))
1484
1485 (define-bitfield-emitter emit-word 32
1486   (byte 32 0))
1487
1488 (define-instruction word (segment word)
1489   (:emitter
1490    (emit-word segment word)))
1491
1492 (define-instruction fun-header-word (segment)
1493   (:emitter
1494    (emit-back-patch
1495     segment 4
1496     #'(lambda (segment posn)
1497         (emit-word segment
1498                    (logior simple-fun-header-widetag
1499                            (ash (+ posn (component-header-length))
1500                                 (- n-widetag-bits word-shift))))))))
1501
1502 (define-instruction lra-header-word (segment)
1503   (:emitter
1504    (emit-back-patch
1505     segment 4
1506     #'(lambda (segment posn)
1507         (emit-word segment
1508                    (logior return-pc-header-widetag
1509                            (ash (+ posn (component-header-length))
1510                                 (- n-widetag-bits word-shift))))))))