src/compiler/hppa/insts.lisp

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