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-ub8-from-system-area sap (1+ offset)
 402                                                 vector 0 length)
 403            (collect ((sc-offsets)
 404                      (lengths))
 405              (lengths 1)                ; the length byte
 406              (let* ((index 0)
 407                     (error-number (sb!c:read-var-integer vector index)))
 408                (lengths index)
 409                (loop
 410                  (when (>= index length)
 411                    (return))
 412                  (let ((old-index index))
 413                    (sc-offsets (sb!c:read-var-integer vector index))
 414                    (lengths (- index old-index))))
 415                (values error-number
 416                        (1+ length)
 417                        (sc-offsets)
 418                        (lengths))))))))
 419
 420 (defun break-control (chunk inst stream dstate)
 421   (declare (ignore inst))
 422   (flet ((nt (x) (if stream (sb!disassem:note x dstate))))
 423     (case (break-im5 chunk dstate)
 424       (#.error-trap
 425        (nt "Error trap")
 426        (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
 427       (#.cerror-trap
 428        (nt "Cerror trap")
 429        (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
 430       (#.breakpoint-trap
 431        (nt "Breakpoint trap"))
 432       (#.pending-interrupt-trap
 433        (nt "Pending interrupt trap"))
 434       (#.halt-trap
 435        (nt "Halt trap"))
 436       (#.fun-end-breakpoint-trap
 437        (nt "Function end breakpoint trap"))
 438     )))
 439
 440 (sb!disassem:define-instruction-format
 441     (system-inst 32)
 442   (op1 :field (byte 6 26) :value 0)
 443   (r1  :field (byte 5 21) :type 'reg)
 444   (r2  :field (byte 5 16) :type 'reg)
 445   (s   :field (byte 3 13))
 446   (op2 :field (byte 8 5))
 447   (r3  :field (byte 5 0) :type 'reg))
 448
 449 (sb!disassem:define-instruction-format
 450     (fp-load/store 32)
 451   (op :field (byte 6 26))
 452   (b  :field (byte 5 21) :type 'reg)
 453   (x  :field (byte 5 16) :type 'reg)
 454   (s  :field (byte 2 14) :type 'space)
 455   (u  :field (byte 1 13))
 456   (x1 :field (byte 1 12))
 457   (x2 :field (byte 2 10))
 458   (x3 :field (byte 1 9))
 459   (x4 :field (byte 3 6))
 460   (m  :field (byte 1 5))
 461   (t  :field (byte 5 0) :type 'fp-reg))
 462
 463 (sb!disassem:define-instruction-format
 464     (fp-class-0-inst 32)
 465   (op1 :field (byte 6 26))
 466   (r   :field (byte 5 21) :type 'fp-reg)
 467   (x1  :field (byte 5 16) :type 'fp-reg)
 468   (op2 :field (byte 3 13))
 469   (fmt :field (byte 2 11) :type 'fp-fmt-0c)
 470   (x2  :field (byte 2 9))
 471   (x3  :field (byte 3 6))
 472   (x4  :field (byte 1 5))
 473   (t   :field (byte 5 0) :type 'fp-reg))
 474
 475 (sb!disassem:define-instruction-format
 476     (fp-class-1-inst 32)
 477   (op1 :field (byte 6 26))
 478   (r   :field (byte 5 21) :type 'fp-reg)
 479   (x1  :field (byte 4 17) :value 0)
 480   (x2  :field (byte 2 15))
 481   (df  :field (byte 2 13) :type 'fp-fmt-0c)
 482   (sf  :field (byte 2 11) :type 'fp-fmt-0c)
 483   (x3  :field (byte 2 9) :value 1)
 484   (x4  :field (byte 3 6) :value 0)
 485   (x5  :field (byte 1 5) :value 0)
 486   (t   :field (byte 5 0) :type 'fp-reg))
 487
 488
 489 \f
 490 ;;;; Load and Store stuff.
 491
 492 (define-bitfield-emitter emit-load/store 32
 493   (byte 6 26)
 494   (byte 5 21)
 495   (byte 5 16)
 496   (byte 2 14)
 497   (byte 14 0))
 498
 499
 500 (defun im14-encoding (segment disp)
 501   (declare (type (or fixup (signed-byte 14))))
 502   (cond ((fixup-p disp)
 503          (note-fixup segment :load disp)
 504          (assert (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
 505          0)
 506         (t
 507          (dpb (ldb (byte 13 0) disp)
 508               (byte 13 1)
 509               (ldb (byte 1 13) disp)))))
 510
 511 (macrolet ((define-load-inst (name opcode)
 512                `(define-instruction ,name (segment disp base reg)
 513                  (:declare (type tn reg base)
 514                   (type (or fixup (signed-byte 14)) disp))
 515                  (:printer load/store ((op ,opcode) (s 0))
 516                   '(:name :tab im14 "(" s b ")," t/r))
 517                  (:emitter
 518                   (emit-load/store segment ,opcode
 519                    (reg-tn-encoding base) (reg-tn-encoding reg) 0
 520                    (im14-encoding segment disp)))))
 521            (define-store-inst (name opcode)
 522                `(define-instruction ,name (segment reg disp base)
 523                  (:declare (type tn reg base)
 524                   (type (or fixup (signed-byte 14)) disp))
 525                  (:printer load/store ((op ,opcode) (s 0))
 526                   '(:name :tab t/r "," im14 "(" s b ")"))
 527                  (:emitter
 528                   (emit-load/store segment ,opcode
 529                    (reg-tn-encoding base) (reg-tn-encoding reg) 0
 530                    (im14-encoding segment disp))))))
 531   (define-load-inst ldw #x12)
 532   (define-load-inst ldh #x11)
 533   (define-load-inst ldb #x10)
 534   (define-load-inst ldwm #x13)
 535   (define-load-inst ldo #x0D)
 536
 537   (define-store-inst stw #x1A)
 538   (define-store-inst sth #x19)
 539   (define-store-inst stb #x18)
 540   (define-store-inst stwm #x1B))
 541
 542 (define-bitfield-emitter emit-extended-load/store 32
 543   (byte 6 26) (byte 5 21) (byte 5 16) (byte 2 14) (byte 1 13)
 544   (byte 3 10) (byte 4 6) (byte 1 5) (byte 5 0))
 545
 546 (macrolet ((define-load-indexed-inst (name opcode)
 547               `(define-instruction ,name (segment index base reg &key modify scale)
 548                 (:declare (type tn reg base index)
 549                  (type (member t nil) modify scale))
 550                 (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'reg)
 551                                                (op2 0))
 552                  `(:name ,@cmplt-index-print :tab x/im5/r
 553                                               "(" s b ")" t/im5))
 554                 (:emitter
 555                  (emit-extended-load/store
 556                   segment #x03 (reg-tn-encoding base) (reg-tn-encoding index)
 557                   0 (if scale 1 0) 0 ,opcode (if modify 1 0)
 558                   (reg-tn-encoding reg))))))
 559   (define-load-indexed-inst ldwx 2)
 560   (define-load-indexed-inst ldhx 1)
 561   (define-load-indexed-inst ldbx 0)
 562   (define-load-indexed-inst ldcwx 7))
 563
 564 (defun short-disp-encoding (segment disp)
 565   (declare (type (or fixup (signed-byte 5)) disp))
 566   (cond ((fixup-p disp)
 567          (note-fixup segment :load-short disp)
 568          (assert (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
 569          0)
 570         (t
 571          (dpb (ldb (byte 4 0) disp)
 572               (byte 4 1)
 573               (ldb (byte 1 4) disp)))))
 574
 575 (macrolet ((define-load-short-inst (name opcode)
 576                `(define-instruction ,name (segment base disp reg &key modify)
 577                  (:declare (type tn base reg)
 578                   (type (or fixup (signed-byte 5)) disp)
 579                   (type (member :before :after nil) modify))
 580                  (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'im5)
 581                                                 (op2 4))
 582                   `(:name ,@cmplt-disp-print :tab x/im5/r
 583                     "(" s b ")" t/im5))
 584                  (:emitter
 585                   (multiple-value-bind
 586                         (m a)
 587                       (ecase modify
 588                         ((nil) (values 0 0))
 589                         (:after (values 1 0))
 590                         (:before (values 1 1)))
 591                     (emit-extended-load/store segment #x03 (reg-tn-encoding base)
 592                                               (short-disp-encoding segment disp)
 593                                               0 a 4 ,opcode m
 594                                               (reg-tn-encoding reg))))))
 595            (define-store-short-inst (name opcode)
 596                `(define-instruction ,name (segment reg base disp &key modify)
 597                  (:declare (type tn reg base)
 598                   (type (or fixup (signed-byte 5)) disp)
 599                   (type (member :before :after nil) modify))
 600                  (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'im5)
 601                                                 (op2 4))
 602                   `(:name ,@cmplt-disp-print :tab x/im5/r
 603                     "," t/im5 "(" s b ")"))
 604                  (:emitter
 605                   (multiple-value-bind
 606                         (m a)
 607                       (ecase modify
 608                         ((nil) (values 0 0))
 609                         (:after (values 1 0))
 610                         (:before (values 1 1)))
 611                     (emit-extended-load/store segment #x03 (reg-tn-encoding base)
 612                                               (short-disp-encoding segment disp)
 613                                               0 a 4 ,opcode m
 614                                               (reg-tn-encoding reg)))))))
 615   (define-load-short-inst ldws 2)
 616   (define-load-short-inst ldhs 1)
 617   (define-load-short-inst ldbs 0)
 618   (define-load-short-inst ldcws 7)
 619
 620   (define-store-short-inst stws 10)
 621   (define-store-short-inst sths 9)
 622   (define-store-short-inst stbs 8))
 623
 624 (define-instruction stbys (segment reg base disp where &key modify)
 625   (:declare (type tn reg base)
 626             (type (signed-byte 5) disp)
 627             (type (member :begin :end) where)
 628             (type (member t nil) modify))
 629   (:printer extended-load/store ((ext4/c #xC) (t/im5 nil :type 'im5) (op2 4))
 630             `(:name ,@cmplt-store-print :tab x/im5/r "," t/im5 "(" s b ")"))
 631   (:emitter
 632    (emit-extended-load/store segment #x03 (reg-tn-encoding base)
 633                              (reg-tn-encoding reg) 0
 634                              (ecase where (:begin 0) (:end 1))
 635                              4 #xC (if modify 1 0)
 636                              (short-disp-encoding segment disp))))
 637
 638 \f
 639 ;;;; Immediate Instructions.
 640
 641 (define-bitfield-emitter emit-ldil 32
 642   (byte 6 26)
 643   (byte 5 21)
 644   (byte 21 0))
 645
 646 (defun immed-21-encoding (segment value)
 647   (declare (type (or fixup (signed-byte 21) (unsigned-byte 21)) value))
 648   (cond ((fixup-p value)
 649          (note-fixup segment :hi value)
 650          (assert (or (null (fixup-offset value)) (zerop (fixup-offset value))))
 651          0)
 652         (t
 653          (logior (ash (ldb (byte 5 2) value) 16)
 654                  (ash (ldb (byte 2 7) value) 14)
 655                  (ash (ldb (byte 2 0) value) 12)
 656                  (ash (ldb (byte 11 9) value) 1)
 657                  (ldb (byte 1 20) value)))))
 658
 659 (define-instruction ldil (segment value reg)
 660   (:declare (type tn reg)
 661             (type (or (signed-byte 21) (unsigned-byte 21) fixup) value))
 662   (:printer ldil ((op #x08)))
 663   (:emitter
 664    (emit-ldil segment #x08 (reg-tn-encoding reg)
 665               (immed-21-encoding segment value))))
 666
 667 (define-instruction addil (segment value reg)
 668   (:declare (type tn reg)
 669             (type (or (signed-byte 21) (unsigned-byte 21) fixup) value))
 670   (:printer ldil ((op #x0A)))
 671   (:emitter
 672    (emit-ldil segment #x0A (reg-tn-encoding reg)
 673               (immed-21-encoding segment value))))
 674
 675 \f
 676 ;;;; Branch instructions.
 677
 678 (define-bitfield-emitter emit-branch 32
 679   (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
 680   (byte 11 2) (byte 1 1) (byte 1 0))
 681
 682 (defun label-relative-displacement (label posn &optional delta-if-after)
 683    (declare (type label label) (type index posn))
 684   (ash (- (if delta-if-after
 685               (label-position label posn delta-if-after)
 686               (label-position label))
 687           (+ posn 8)) -2))
 688
 689 (defun decompose-branch-disp (segment disp)
 690   (declare (type (or fixup (signed-byte 17)) disp))
 691   (cond ((fixup-p disp)
 692          (note-fixup segment :branch disp)
 693          (assert (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
 694          (values 0 0 0))
 695         (t
 696          (values (ldb (byte 5 11) disp)
 697                  (dpb (ldb (byte 10 0) disp)
 698                       (byte 10 1)
 699                       (ldb (byte 1 10) disp))
 700                  (ldb (byte 1 16) disp)))))
 701
 702 (defun emit-relative-branch (segment opcode link sub-opcode target nullify)
 703   (declare (type (unsigned-byte 6) opcode)
 704            (type (unsigned-byte 5) link)
 705            (type (unsigned-byte 1) sub-opcode)
 706            (type label target)
 707            (type (member t nil) nullify))
 708   (emit-back-patch segment 4
 709     #'(lambda (segment posn)
 710         (let ((disp (label-relative-displacement target posn)))
 711           (assert (<= (- (ash 1 16)) disp (1- (ash 1 16))))
 712           (multiple-value-bind
 713               (w1 w2 w)
 714               (decompose-branch-disp segment disp)
 715             (emit-branch segment opcode link w1 sub-opcode w2
 716                          (if nullify 1 0) w))))))
 717
 718 (define-instruction b (segment target &key nullify)
 719   (:declare (type label target) (type (member t nil) nullify))
 720   (:emitter
 721    (emit-relative-branch segment #x3A 0 0 target nullify)))
 722
 723 (define-instruction bl (segment target reg &key nullify)
 724   (:declare (type tn reg) (type label target) (type (member t nil) nullify))
 725   (:printer branch17 ((op1 #x3A) (op2 0)) '(:name n :tab w "," t))
 726   (:emitter
 727    (emit-relative-branch segment #x3A (reg-tn-encoding reg) 0 target nullify)))
 728
 729 (define-instruction gateway (segment target reg &key nullify)
 730   (:declare (type tn reg) (type label target) (type (member t nil) nullify))
 731   (:printer branch17 ((op1 #x3A) (op2 1)) '(:name n :tab w "," t))
 732   (:emitter
 733    (emit-relative-branch segment #x3A (reg-tn-encoding reg) 1 target nullify)))
 734
 735 ;;; BLR is useless because we have no way to generate the offset.
 736
 737 (define-instruction bv (segment base &key nullify offset)
 738   (:declare (type tn base)
 739             (type (member t nil) nullify)
 740             (type (or tn null) offset))
 741   (:printer branch ((op1 #x3A) (op2 6)) '(:name n :tab x "(" t ")"))
 742   (:emitter
 743    (emit-branch segment #x3A (reg-tn-encoding base)
 744                 (if offset (reg-tn-encoding offset) 0)
 745                 6 0 (if nullify 1 0) 0)))
 746
 747 (define-instruction be (segment disp space base &key nullify)
 748   (:declare (type (or fixup (signed-byte 17)) disp)
 749             (type tn base)
 750             (type (unsigned-byte 3) space)
 751             (type (member t nil) nullify))
 752   (:printer branch17 ((op1 #x38) (op2 nil :type 'im3))
 753             '(:name n :tab w "(" op2 "," t ")"))
 754   (:emitter
 755    (multiple-value-bind
 756        (w1 w2 w)
 757        (decompose-branch-disp segment disp)
 758      (emit-branch segment #x38 (reg-tn-encoding base) w1
 759                   (space-encoding space) w2 (if nullify 1 0) w))))
 760
 761 (define-instruction ble (segment disp space base &key nullify)
 762   (:declare (type (or fixup (signed-byte 17)) disp)
 763             (type tn base)
 764             (type (unsigned-byte 3) space)
 765             (type (member t nil) nullify))
 766   (:printer branch17 ((op1 #x39) (op2 nil :type 'im3))
 767             '(:name n :tab w "(" op2 "," t ")"))
 768   (:emitter
 769    (multiple-value-bind
 770        (w1 w2 w)
 771        (decompose-branch-disp segment disp)
 772      (emit-branch segment #x39 (reg-tn-encoding base) w1
 773                   (space-encoding space) w2 (if nullify 1 0) w))))
 774
 775 (defun emit-conditional-branch (segment opcode r2 r1 cond target nullify)
 776   (emit-back-patch segment 4
 777     #'(lambda (segment posn)
 778         (let ((disp (label-relative-displacement target posn)))
 779           (assert (<= (- (ash 1 11)) disp (1- (ash 1 11))))
 780           (let ((w1 (logior (ash (ldb (byte 10 0) disp) 1)
 781                             (ldb (byte 1 10) disp)))
 782                 (w (ldb (byte 1 11) disp)))
 783             (emit-branch segment opcode r2 r1 cond w1 (if nullify 1 0) w))))))
 784
 785 (defun im5-encoding (value)
 786   (declare (type (signed-byte 5) value)
 787            #+nil (values (unsigned-byte 5)))
 788   (dpb (ldb (byte 4 0) value)
 789        (byte 4 1)
 790        (ldb (byte 1 4) value)))
 791
 792 (macrolet ((define-branch-inst (r-name r-opcode i-name i-opcode cond-kind)
 793                (let* ((conditional (symbolicate cond-kind "-CONDITION"))
 794                       (false-conditional (symbolicate conditional "-FALSE")))
 795                  `(progn
 796                    (define-instruction ,r-name (segment cond r1 r2 target &key nullify)
 797                      (:declare (type ,conditional cond)
 798                       (type tn r1 r2)
 799                       (type label target)
 800                       (type (member t nil) nullify))
 801                      (:printer branch12 ((op1 ,r-opcode) (c nil :type ',conditional))
 802                       '(:name c n :tab r1 "," r2 "," w))
 803                      ,@(unless (= r-opcode #x32)
 804                                `((:printer branch12 ((op1 ,(+ 2 r-opcode))
 805                                                      (c nil :type ',false-conditional))
 806                                   '(:name c n :tab r1 "," r2 "," w))))
 807                      (:emitter
 808                       (multiple-value-bind
 809                             (cond-encoding false)
 810                           (,conditional cond)
 811                         (emit-conditional-branch
 812                          segment (if false ,(+ r-opcode 2) ,r-opcode)
 813                          (reg-tn-encoding r2) (reg-tn-encoding r1)
 814                          cond-encoding target nullify))))
 815                    (define-instruction ,i-name (segment cond imm reg target &key nullify)
 816                      (:declare (type ,conditional cond)
 817                       (type (signed-byte 5) imm)
 818                       (type tn reg)
 819                       (type (member t nil) nullify))
 820                      (:printer branch12 ((op1 ,i-opcode) (r1 nil :type 'im5)
 821                                          (c nil :type ',conditional))
 822                       '(:name c n :tab r1 "," r2 "," w))
 823                      ,@(unless (= r-opcode #x32)
 824                                `((:printer branch12 ((op1 ,(+ 2 i-opcode)) (r1 nil :type 'im5)
 825                                                      (c nil :type ',false-conditional))
 826                                   '(:name c n :tab r1 "," r2 "," w))))
 827                      (:emitter
 828                       (multiple-value-bind
 829                             (cond-encoding false)
 830                           (,conditional cond)
 831                         (emit-conditional-branch
 832                          segment (if false (+ ,i-opcode 2) ,i-opcode)
 833                          (reg-tn-encoding reg) (im5-encoding imm)
 834                          cond-encoding target nullify))))))))
 835   (define-branch-inst movb #x32 movib #x33 extract/deposit)
 836   (define-branch-inst comb #x20 comib #x21 compare)
 837   (define-branch-inst addb #x28 addib #x29 add))
 838
 839 (define-instruction bb (segment cond reg posn target &key nullify)
 840   (:declare (type (member t nil) cond nullify)
 841             (type tn reg)
 842             (type (or (member :variable) (unsigned-byte 5)) posn))
 843   (:printer branch12 ((op1 30) (c nil :type 'extract/deposit-condition))
 844                       '('BVB c n :tab r1 "," w))
 845   (:emitter
 846    (multiple-value-bind
 847        (opcode posn-encoding)
 848        (if (eq posn :variable)
 849            (values #x30 0)
 850            (values #x31 posn))
 851      (emit-conditional-branch segment opcode posn-encoding
 852                               (reg-tn-encoding reg)
 853                               (if cond 2 6) target nullify))))
 854
 855 \f
 856 ;;;; Computation Instructions
 857
 858 (define-bitfield-emitter emit-r3-inst 32
 859   (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
 860   (byte 1 12) (byte 7 5) (byte 5 0))
 861
 862 (macrolet ((define-r3-inst (name cond-kind opcode)
 863                `(define-instruction ,name (segment r1 r2 res &optional cond)
 864                  (:declare (type tn res r1 r2))
 865                  (:printer r3-inst ((op ,opcode) (c nil :type ',(symbolicate
 866                                                                  cond-kind
 867                                                                  "-CONDITION"))))
 868                  ,@(when (= opcode #x12)
 869                          `((:printer r3-inst ((op ,opcode) (r2 0)
 870                                               (c nil :type ',(symbolicate cond-kind
 871                                                                           "-CONDITION")))
 872                             `('COPY :tab r1 "," t))))
 873                  (:emitter
 874                   (multiple-value-bind
 875                         (cond false)
 876                       (,(symbolicate cond-kind "-CONDITION") cond)
 877                     (emit-r3-inst segment #x02 (reg-tn-encoding r2) (reg-tn-encoding r1)
 878                                   cond (if false 1 0) ,opcode
 879                                   (reg-tn-encoding res)))))))
 880   (define-r3-inst add add #x30)
 881   (define-r3-inst addl add #x50)
 882   (define-r3-inst addo add #x70)
 883   (define-r3-inst addc add #x38)
 884   (define-r3-inst addco add #x78)
 885   (define-r3-inst sh1add add #x32)
 886   (define-r3-inst sh1addl add #x52)
 887   (define-r3-inst sh1addo add #x72)
 888   (define-r3-inst sh2add add #x34)
 889   (define-r3-inst sh2addl add #x54)
 890   (define-r3-inst sh2addo add #x74)
 891   (define-r3-inst sh3add add #x36)
 892   (define-r3-inst sh3addl add #x56)
 893   (define-r3-inst sh3addo add #x76)
 894   (define-r3-inst sub compare #x20)
 895   (define-r3-inst subo compare #x60)
 896   (define-r3-inst subb compare #x28)
 897   (define-r3-inst subbo compare #x68)
 898   (define-r3-inst subt compare #x26)
 899   (define-r3-inst subto compare #x66)
 900   (define-r3-inst ds compare #x22)
 901   (define-r3-inst comclr compare #x44)
 902   (define-r3-inst or logical #x12)
 903   (define-r3-inst xor logical #x14)
 904   (define-r3-inst and logical #x10)
 905   (define-r3-inst andcm logical #x00)
 906   (define-r3-inst uxor unit #x1C)
 907   (define-r3-inst uaddcm unit #x4C)
 908   (define-r3-inst uaddcmt unit #x4E)
 909   (define-r3-inst dcor unit #x5C)
 910   (define-r3-inst idcor unit #x5E))
 911
 912 (define-bitfield-emitter emit-imm-inst 32
 913   (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
 914   (byte 1 12) (byte 1 11) (byte 11 0))
 915
 916 (defun im11-encoding (value)
 917   (declare (type (signed-byte 11) value)
 918            #+nil (values (unsigned-byte 11)))
 919   (dpb (ldb (byte 10 0) value)
 920        (byte 10 1)
 921        (ldb (byte 1 10) value)))
 922
 923 (macrolet ((define-imm-inst (name cond-kind opcode subcode)
 924                `(define-instruction ,name (segment imm src dst &optional cond)
 925                  (:declare (type tn dst src)
 926                   (type (signed-byte 11) imm))
 927                  (:printer imm-inst ((op ,opcode) (o ,subcode)
 928                                      (c nil :type
 929                                         ',(symbolicate cond-kind "-CONDITION"))))
 930                  (:emitter
 931                   (multiple-value-bind
 932                         (cond false)
 933                       (,(symbolicate cond-kind "-CONDITION") cond)
 934                     (emit-imm-inst segment ,opcode (reg-tn-encoding src)
 935                                    (reg-tn-encoding dst) cond
 936                                    (if false 1 0) ,subcode
 937                                    (im11-encoding imm)))))))
 938   (define-imm-inst addi add #x2D 0)
 939   (define-imm-inst addio add #x2D 1)
 940   (define-imm-inst addit add #x2C 0)
 941   (define-imm-inst addito add #x2C 1)
 942   (define-imm-inst subi compare #x25 0)
 943   (define-imm-inst subio compare #x25 1)
 944   (define-imm-inst comiclr compare #x24 0))
 945
 946 (define-bitfield-emitter emit-extract/deposit-inst 32
 947   (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
 948   (byte 3 10) (byte 5 5) (byte 5 0))
 949
 950 (define-instruction shd (segment r1 r2 count res &optional cond)
 951   (:declare (type tn res r1 r2)
 952             (type (or (member :variable) (integer 0 31)) count))
 953   (:printer extract/deposit-inst ((op1 #x34) (op2 2) (t/clen nil :type 'reg))
 954             '(:name c :tab r1 "," r2 "," cp "," t/clen))
 955   (:printer extract/deposit-inst ((op1 #x34) (op2 0) (t/clen nil :type 'reg))
 956             '('VSHD c :tab r1 "," r2 "," t/clen))
 957   (:emitter
 958    (etypecase count
 959      ((member :variable)
 960       (emit-extract/deposit-inst segment #x34
 961                                  (reg-tn-encoding r2) (reg-tn-encoding r1)
 962                                  (extract/deposit-condition cond)
 963                                  0 0 (reg-tn-encoding res)))
 964      ((integer 0 31)
 965       (emit-extract/deposit-inst segment #x34
 966                                  (reg-tn-encoding r2) (reg-tn-encoding r1)
 967                                  (extract/deposit-condition cond)
 968                                  2 (- 31 count)
 969                                  (reg-tn-encoding res))))))
 970
 971 (macrolet ((define-extract-inst (name opcode)
 972                `(define-instruction ,name (segment src posn len res &optional cond)
 973                  (:declare (type tn res src)
 974                   (type (or (member :variable) (integer 0 31)) posn)
 975                   (type (integer 1 32) len))
 976                  (:printer extract/deposit-inst ((op1 #x34) (cp nil :type 'integer)
 977                                                  (op2 ,opcode))
 978                   '(:name c :tab r2 "," cp "," t/clen "," r1))
 979                  (:printer extract/deposit-inst ((op1 #x34) (op2 ,(- opcode 2)))
 980                   '('V :name c :tab r2 "," t/clen "," r1))
 981                  (:emitter
 982                   (etypecase posn
 983                     ((member :variable)
 984                      (emit-extract/deposit-inst segment #x34 (reg-tn-encoding src)
 985                                                 (reg-tn-encoding res)
 986                                                 (extract/deposit-condition cond)
 987                                                 ,(- opcode 2) 0 (- 32 len)))
 988                     ((integer 0 31)
 989                      (emit-extract/deposit-inst segment #x34 (reg-tn-encoding src)
 990                                                 (reg-tn-encoding res)
 991                                                 (extract/deposit-condition cond)
 992                                                 ,opcode posn (- 32 len))))))))
 993   (define-extract-inst extru 6)
 994   (define-extract-inst extrs 7))
 995
 996 (macrolet ((define-deposit-inst (name opcode)
 997                `(define-instruction ,name (segment src posn len res &optional cond)
 998                  (:declare (type tn res)
 999                   (type (or tn (signed-byte 5)) src)
1000                   (type (or (member :variable) (integer 0 31)) posn)
1001                   (type (integer 1 32) len))
1002                  (:printer extract/deposit-inst ((op1 #x35) (op2 ,opcode))
1003                   ',(let ((base '('VDEP c :tab r1 "," t/clen "," r2)))
1004                          (if (= opcode 0) (cons ''Z base) base)))
1005                  (:printer extract/deposit-inst ((op1 #x35) (op2 ,(+ 2 opcode)))
1006                   ',(let ((base '('DEP c :tab r1 "," cp "," t/clen "," r2)))
1007                          (if (= opcode 0) (cons ''Z base) base)))
1008                  (:printer extract/deposit-inst ((op1 #x35) (r1 nil :type 'im5)
1009                                                  (op2 ,(+ 4 opcode)))
1010                   ',(let ((base '('VDEPI c :tab r1 "," t/clen "," r2)))
1011                          (if (= opcode 0) (cons ''Z base) base)))
1012                  (:printer extract/deposit-inst ((op1 #x35) (r1 nil :type 'im5)
1013                                                  (op2 ,(+ 6 opcode)))
1014                   ',(let ((base '('DEPI c :tab r1 "," cp "," t/clen "," r2)))
1015                          (if (= opcode 0) (cons ''Z base) base)))
1016                  (:emitter
1017                   (multiple-value-bind
1018                         (opcode src-encoding)
1019                       (etypecase src
1020                         (tn
1021                          (values ,opcode (reg-tn-encoding src)))
1022                         ((signed-byte 5)
1023                          (values ,(+ opcode 4) (im5-encoding src))))
1024                     (multiple-value-bind
1025                           (opcode posn-encoding)
1026                         (etypecase posn
1027                           ((member :variable)
1028                            (values opcode 0))
1029                           ((integer 0 31)
1030                            (values (+ opcode 2) (- 31 posn))))
1031                       (emit-extract/deposit-inst segment #x35 (reg-tn-encoding res)
1032                                                  src-encoding
1033                                                  (extract/deposit-condition cond)
1034                                                  opcode posn-encoding (- 32 len))))))))
1035
1036   (define-deposit-inst dep 1)
1037   (define-deposit-inst zdep 0))
1038
1039
1040 \f
1041 ;;;; System Control Instructions.
1042
1043 (define-bitfield-emitter emit-break 32
1044   (byte 6 26) (byte 13 13) (byte 8 5) (byte 5 0))
1045
1046 (define-instruction break (segment &optional (im5 0) (im13 0))
1047   (:declare (type (unsigned-byte 13) im13)
1048             (type (unsigned-byte 5) im5))
1049   (:printer break () :default :control #'break-control)
1050   (:emitter
1051    (emit-break segment 0 im13 0 im5)))
1052
1053 (define-bitfield-emitter emit-system-inst 32
1054   (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 8 5) (byte 5 0))
1055
1056 (define-instruction ldsid (segment res base &optional (space 0))
1057   (:declare (type tn res base)
1058             (type (integer 0 3) space))
1059   (:printer system-inst ((op2 #x85) (c nil :type 'space)
1060                          (s nil  :printer #(0 0 1 1 2 2 3 3)))
1061             `(:name :tab "(" s r1 ")," r3))
1062   (:emitter
1063    (emit-system-inst segment 0 (reg-tn-encoding base) 0 (ash space 1) #x85
1064                      (reg-tn-encoding res))))
1065
1066 (define-instruction mtsp (segment reg space)
1067   (:declare (type tn reg) (type (integer 0 7) space))
1068   (:printer system-inst ((op2 #xC1)) '(:name :tab r2 "," s))
1069   (:emitter
1070    (emit-system-inst segment 0 0 (reg-tn-encoding reg) (space-encoding space)
1071                      #xC1 0)))
1072
1073 (define-instruction mfsp (segment space reg)
1074   (:declare (type tn reg) (type (integer 0 7) space))
1075   (:printer system-inst ((op2 #x25) (c nil :type 'space)) '(:name :tab s r3))
1076   (:emitter
1077    (emit-system-inst segment 0 0 0 (space-encoding space) #x25
1078                      (reg-tn-encoding reg))))
1079
1080 (deftype control-reg ()
1081   '(or (unsigned-byte 5) (member :sar)))
1082
1083 (defun control-reg (reg)
1084   (declare (type control-reg reg)
1085            #+nil (values (unsigned-byte 32)))
1086   (if (typep reg '(unsigned-byte 5))
1087       reg
1088       (ecase reg
1089         (:sar 11))))
1090
1091 (define-instruction mtctl (segment reg ctrl-reg)
1092   (:declare (type tn reg) (type control-reg ctrl-reg))
1093   (:printer system-inst ((op2 #xC2)) '(:name :tab r2 "," r1))
1094   (:emitter
1095    (emit-system-inst segment 0 (control-reg ctrl-reg) (reg-tn-encoding reg)
1096                      0 #xC2 0)))
1097
1098 (define-instruction mfctl (segment ctrl-reg reg)
1099   (:declare (type tn reg) (type control-reg ctrl-reg))
1100   (:printer system-inst ((op2 #x45)) '(:name :tab r1 "," r3))
1101   (:emitter
1102    (emit-system-inst segment 0 (control-reg ctrl-reg) 0 0 #x45
1103                      (reg-tn-encoding reg))))
1104
1105
1106 \f
1107 ;;;; Floating point instructions.
1108
1109 (define-bitfield-emitter emit-fp-load/store 32
1110   (byte 6 26) (byte 5 21) (byte 5 16) (byte 2 14) (byte 1 13) (byte 1 12)
1111   (byte 2 10) (byte 1 9) (byte 3 6) (byte 1 5) (byte 5 0))
1112
1113 (define-instruction fldx (segment index base result &key modify scale side)
1114   (:declare (type tn index base result)
1115             (type (member t nil) modify scale)
1116             (type (member nil 0 1) side))
1117   (:printer fp-load/store ((op #x0b) (x1 0) (x2 0) (x3 0))
1118             `('FLDDX ,@cmplt-index-print :tab x "(" s b ")" "," t))
1119   (:printer fp-load/store ((op #x09) (x1 0) (x2 0) (x3 0))
1120             `('FLDWX ,@cmplt-index-print :tab x "(" s b ")" "," t))
1121   (:emitter
1122    (multiple-value-bind
1123        (result-encoding double-p)
1124        (fp-reg-tn-encoding result)
1125      (when side
1126        (assert double-p)
1127        (setf double-p nil))
1128      (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
1129                          (reg-tn-encoding index) 0 (if scale 1 0) 0 0 0
1130                          (or side 0) (if modify 1 0) result-encoding))))
1131
1132 (define-instruction fstx (segment value index base &key modify scale side)
1133   (:declare (type tn index base value)
1134             (type (member t nil) modify scale)
1135             (type (member nil 0 1) side))
1136   (:printer fp-load/store ((op #x0b) (x1 0) (x2 0) (x3 1))
1137             `('FSTDX ,@cmplt-index-print :tab t "," x "(" s b ")"))
1138   (:printer fp-load/store ((op #x09) (x1 0) (x2 0) (x3 1))
1139             `('FSTWX ,@cmplt-index-print :tab t "," x "(" s b ")"))
1140   (:emitter
1141    (multiple-value-bind
1142        (value-encoding double-p)
1143        (fp-reg-tn-encoding value)
1144      (when side
1145        (assert double-p)
1146        (setf double-p nil))
1147      (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
1148                          (reg-tn-encoding index) 0 (if scale 1 0) 0 0 1
1149                          (or side 0) (if modify 1 0) value-encoding))))
1150
1151 (define-instruction flds (segment disp base result &key modify side)
1152   (:declare (type tn base result)
1153             (type (signed-byte 5) disp)
1154             (type (member :before :after nil) modify)
1155             (type (member nil 0 1) side))
1156   (:printer fp-load/store ((op #x0b) (x nil :type 'im5) (x1 1) (x2 0) (x3 0))
1157             `('FLDDS ,@cmplt-disp-print :tab x "(" s b ")," t))
1158   (:printer fp-load/store ((op #x09) (x nil :type 'im5) (x1 1) (x2 0) (x3 0))
1159             `('FLDWS ,@cmplt-disp-print :tab x "(" s b ")," t))
1160   (:emitter
1161    (multiple-value-bind
1162        (result-encoding double-p)
1163        (fp-reg-tn-encoding result)
1164      (when side
1165        (assert double-p)
1166        (setf double-p nil))
1167      (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
1168                          (short-disp-encoding segment disp) 0
1169                          (if (eq modify :before) 1 0) 1 0 0
1170                          (or side 0) (if modify 1 0) result-encoding))))
1171
1172 (define-instruction fsts (segment value disp base &key modify side)
1173   (:declare (type tn base value)
1174             (type (signed-byte 5) disp)
1175             (type (member :before :after nil) modify)
1176             (type (member nil 0 1) side))
1177   (:printer fp-load/store ((op #x0b) (x nil :type 'im5) (x1 1) (x2 0) (x3 1))
1178             `('FSTDS ,@cmplt-disp-print :tab t "," x "(" s b ")"))
1179   (:printer fp-load/store ((op #x09) (x nil :type 'im5) (x1 1) (x2 0) (x3 1))
1180             `('FSTWS ,@cmplt-disp-print :tab t "," x "(" s b ")"))
1181   (:emitter
1182    (multiple-value-bind
1183        (value-encoding double-p)
1184        (fp-reg-tn-encoding value)
1185      (when side
1186        (assert double-p)
1187        (setf double-p nil))
1188      (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
1189                          (short-disp-encoding segment disp) 0
1190                          (if (eq modify :before) 1 0) 1 0 1
1191                          (or side 0) (if modify 1 0) value-encoding))))
1192
1193
1194 (define-bitfield-emitter emit-fp-class-0-inst 32
1195   (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 2 11) (byte 2 9)
1196   (byte 3 6) (byte 1 5) (byte 5 0))
1197
1198 (define-bitfield-emitter emit-fp-class-1-inst 32
1199   (byte 6 26) (byte 5 21) (byte 4 17) (byte 2 15) (byte 2 13) (byte 2 11)
1200   (byte 2 9) (byte 3 6) (byte 1 5) (byte 5 0))
1201
1202 ;;; Note: classes 2 and 3 are similar enough to class 0 that we don't need
1203 ;;; seperate emitters.
1204
1205 (defconstant-eqx funops '(:copy :abs :sqrt :rnd)
1206   #'equalp)
1207
1208 (deftype funop ()
1209   `(member ,@funops))
1210
1211 (define-instruction funop (segment op from to)
1212   (:declare (type funop op)
1213             (type tn from to))
1214   (:printer fp-class-0-inst ((op1 #x0C) (op2 2) (x2 0))
1215             '('FCPY fmt :tab r "," t))
1216   (:printer fp-class-0-inst ((op1 #x0C) (op2 3) (x2 0))
1217             '('FABS fmt  :tab r "," t))
1218   (:printer fp-class-0-inst ((op1 #x0C) (op2 4) (x2 0))
1219             '('FSQRT fmt :tab r "," t))
1220   (:printer fp-class-0-inst ((op1 #x0C) (op2 5) (x2 0))
1221             '('FRND fmt :tab r "," t))
1222   (:emitter
1223    (multiple-value-bind
1224        (from-encoding from-double-p)
1225        (fp-reg-tn-encoding from)
1226      (multiple-value-bind
1227          (to-encoding to-double-p)
1228          (fp-reg-tn-encoding to)
1229        (assert (eq from-double-p to-double-p))
1230        (emit-fp-class-0-inst segment #x0C from-encoding 0
1231                              (+ 2 (or (position op funops)
1232                                       (error "Bogus FUNOP: ~S" op)))
1233                              (if to-double-p 1 0) 0 0 0 to-encoding)))))
1234
1235 (macrolet ((define-class-1-fp-inst (name subcode)
1236                `(define-instruction ,name (segment from to)
1237                  (:declare (type tn from to))
1238                  (:printer fp-class-1-inst ((op1 #x0C) (x2 ,subcode))
1239                   '(:name sf df :tab r "," t))
1240                  (:emitter
1241                   (multiple-value-bind
1242                         (from-encoding from-double-p)
1243                       (fp-reg-tn-encoding from)
1244                     (multiple-value-bind
1245                           (to-encoding to-double-p)
1246                         (fp-reg-tn-encoding to)
1247                       (emit-fp-class-1-inst segment #x0C from-encoding 0 ,subcode
1248                                             (if to-double-p 1 0) (if from-double-p 1 0)
1249                                             1 0 0 to-encoding)))))))
1250
1251   (define-class-1-fp-inst fcnvff 0)
1252   (define-class-1-fp-inst fcnvxf 1)
1253   (define-class-1-fp-inst fcnvfx 2)
1254   (define-class-1-fp-inst fcnvfxt 3))
1255
1256 (define-instruction fcmp (segment cond r1 r2)
1257   (:declare (type (unsigned-byte 5) cond)
1258             (type tn r1 r2))
1259   (:printer fp-class-0-inst ((op1 #x0C) (op2 0) (x2 2) (t nil :type 'fcmp-cond))
1260             '(:name fmt t :tab r "," x1))
1261   (:emitter
1262    (multiple-value-bind
1263        (r1-encoding r1-double-p)
1264        (fp-reg-tn-encoding r1)
1265      (multiple-value-bind
1266          (r2-encoding r2-double-p)
1267          (fp-reg-tn-encoding r2)
1268        (assert (eq r1-double-p r2-double-p))
1269        (emit-fp-class-0-inst segment #x0C r1-encoding r2-encoding 0
1270                              (if r1-double-p 1 0) 2 0 0 cond)))))
1271
1272 (define-instruction ftest (segment)
1273   (:printer fp-class-0-inst ((op1 #x0c) (op2 1) (x2 2)) '(:name))
1274   (:emitter
1275    (emit-fp-class-0-inst segment #x0C 0 0 1 0 2 0 1 0)))
1276
1277 (defconstant-eqx fbinops '(:add :sub :mpy :div)
1278   #'equalp)
1279
1280 (deftype fbinop ()
1281   `(member ,@fbinops))
1282
1283 (define-instruction fbinop (segment op r1 r2 result)
1284   (:declare (type fbinop op)
1285             (type tn r1 r2 result))
1286   (:printer fp-class-0-inst ((op1 #x0C) (op2 0) (x2 3))
1287             '('FADD fmt :tab r "," x1 "," t))
1288   (:printer fp-class-0-inst ((op1 #x0C) (op2 1) (x2 3))
1289             '('FSUB fmt :tab r "," x1 "," t))
1290   (:printer fp-class-0-inst ((op1 #x0C) (op2 2) (x2 3))
1291             '('FMPY fmt :tab r "," x1 "," t))
1292   (:printer fp-class-0-inst ((op1 #x0C) (op2 3) (x2 3))
1293             '('FDIV fmt :tab r "," x1 "," t))
1294   (:emitter
1295    (multiple-value-bind
1296        (r1-encoding r1-double-p)
1297        (fp-reg-tn-encoding r1)
1298      (multiple-value-bind
1299          (r2-encoding r2-double-p)
1300          (fp-reg-tn-encoding r2)
1301        (assert (eq r1-double-p r2-double-p))
1302        (multiple-value-bind
1303            (result-encoding result-double-p)
1304            (fp-reg-tn-encoding result)
1305          (assert (eq r1-double-p result-double-p))
1306          (emit-fp-class-0-inst segment #x0C r1-encoding r2-encoding
1307                                (or (position op fbinops)
1308                                    (error "Bogus FBINOP: ~S" op))
1309                                (if r1-double-p 1 0) 3 0 0
1310                                result-encoding))))))
1311
1312
1313 \f
1314 ;;;; Instructions built out of other insts.
1315
1316 (define-instruction-macro move (src dst &optional cond)
1317   `(inst or ,src zero-tn ,dst ,cond))
1318
1319 (define-instruction-macro nop (&optional cond)
1320   `(inst or zero-tn zero-tn zero-tn ,cond))
1321
1322 (define-instruction li (segment value reg)
1323   (:declare (type tn reg)
1324             (type (or fixup (signed-byte 32) (unsigned-byte 32)) value))
1325   (:vop-var vop)
1326   (:emitter
1327    (assemble (segment vop)
1328      (etypecase value
1329        (fixup
1330         (inst ldil value reg)
1331         (inst ldo value reg reg))
1332        ((signed-byte 14)
1333         (inst ldo value zero-tn reg))
1334        ((or (signed-byte 32) (unsigned-byte 32))
1335         (let ((hi (ldb (byte 21 11) value))
1336               (lo (ldb (byte 11 0) value)))
1337           (inst ldil hi reg)
1338           (unless (zerop lo)
1339             (inst ldo lo reg reg))))))))
1340
1341 (define-instruction-macro sll (src count result &optional cond)
1342   (once-only ((result result) (src src) (count count) (cond cond))
1343     `(inst zdep ,src (- 31 ,count) (- 32 ,count) ,result ,cond)))
1344
1345 (define-instruction-macro sra (src count result &optional cond)
1346   (once-only ((result result) (src src) (count count) (cond cond))
1347     `(inst extrs ,src (- 31 ,count) (- 32 ,count) ,result ,cond)))
1348
1349 (define-instruction-macro srl (src count result &optional cond)
1350   (once-only ((result result) (src src) (count count) (cond cond))
1351     `(inst extru ,src (- 31 ,count) (- 32 ,count) ,result ,cond)))
1352
1353 (defun maybe-negate-cond (cond negate)
1354   (if negate
1355       (multiple-value-bind
1356           (value negate)
1357           (compare-condition cond)
1358         (if negate
1359             (nth value compare-conditions)
1360             (nth (+ value 8) compare-conditions)))
1361       cond))
1362
1363 (define-instruction bc (segment cond not-p r1 r2 target)
1364   (:declare (type compare-condition cond)
1365             (type (member t nil) not-p)
1366             (type tn r1 r2)
1367             (type label target))
1368   (:vop-var vop)
1369   (:emitter
1370    (emit-chooser segment 8 2
1371      #'(lambda (segment posn delta)
1372          (let ((disp (label-relative-displacement target posn delta)))
1373            (when (<= 0 disp (1- (ash 1 11)))
1374              (assemble (segment vop)
1375                (inst comb (maybe-negate-cond cond not-p) r1 r2 target
1376                      :nullify t))
1377              t)))
1378      #'(lambda (segment posn)
1379          (let ((disp (label-relative-displacement target posn)))
1380            (assemble (segment vop)
1381              (cond ((<= (- (ash 1 11)) disp (1- (ash 1 11)))
1382                     (inst comb (maybe-negate-cond cond not-p) r1 r2 target)
1383                     (inst nop))
1384                    (t
1385                     (inst comclr r1 r2 zero-tn
1386                           (maybe-negate-cond cond (not not-p)))
1387                     (inst b target :nullify t)))))))))
1388
1389 (define-instruction bci (segment cond not-p imm reg target)
1390   (:declare (type compare-condition cond)
1391             (type (member t nil) not-p)
1392             (type (signed-byte 11) imm)
1393             (type tn reg)
1394             (type label target))
1395   (:vop-var vop)
1396   (:emitter
1397    (emit-chooser segment 8 2
1398      #'(lambda (segment posn delta-if-after)
1399          (let ((disp (label-relative-displacement target posn delta-if-after)))
1400            (when (and (<= 0 disp (1- (ash 1 11)))
1401                       (<= (- (ash 1 4)) imm (1- (ash 1 4))))
1402              (assemble (segment vop)
1403                (inst comib (maybe-negate-cond cond not-p) imm reg target
1404                      :nullify t))
1405              t)))
1406      #'(lambda (segment posn)
1407          (let ((disp (label-relative-displacement target posn)))
1408            (assemble (segment vop)
1409              (cond ((and (<= (- (ash 1 11)) disp (1- (ash 1 11)))
1410                          (<= (- (ash 1 4)) imm (1- (ash 1 4))))
1411                     (inst comib (maybe-negate-cond cond not-p) imm reg target)
1412                     (inst nop))
1413                    (t
1414                     (inst comiclr imm reg zero-tn
1415                           (maybe-negate-cond cond (not not-p)))
1416                     (inst b target :nullify t)))))))))
1417
1418 \f
1419 ;;;; Instructions to convert between code ptrs, functions, and lras.
1420
1421 (defun emit-compute-inst (segment vop src label temp dst calc)
1422   (emit-chooser
1423       ;; We emit either 12 or 4 bytes, so we maintain 3 byte alignments.
1424       segment 12 3
1425     #'(lambda (segment posn delta-if-after)
1426         (let ((delta (funcall calc label posn delta-if-after)))
1427           (when (<= (- (ash 1 10)) delta (1- (ash 1 10)))
1428             (emit-back-patch segment 4
1429                              #'(lambda (segment posn)
1430                                  (assemble (segment vop)
1431                                    (inst addi (funcall calc label posn 0) src
1432                                          dst))))
1433             t)))
1434     #'(lambda (segment posn)
1435         (let ((delta (funcall calc label posn 0)))
1436           ;; Note: if we used addil/ldo to do this in 2 instructions then the
1437           ;; intermediate value would be tagged but pointing into space.
1438           (assemble (segment vop)
1439             (inst ldil (ldb (byte 21 11) delta) temp)
1440             (inst ldo (ldb (byte 11 0) delta) temp temp)
1441             (inst add src temp dst))))))
1442
1443 ;; code = fn - header - label-offset + other-pointer-tag
1444 (define-instruction compute-code-from-fn (segment src label temp dst)
1445   (:declare (type tn src dst temp)
1446             (type label label))
1447   (:vop-var vop)
1448   (:emitter
1449    (emit-compute-inst segment vop src label temp dst
1450                       #'(lambda (label posn delta-if-after)
1451                           (- other-pointer-lowtag
1452                              (label-position label posn delta-if-after)
1453                              (component-header-length))))))
1454
1455 ;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
1456 (define-instruction compute-code-from-lra (segment src label temp dst)
1457   (:declare (type tn src dst temp)
1458             (type label label))
1459   (:vop-var vop)
1460   (:emitter
1461    (emit-compute-inst segment vop src label temp dst
1462                       #'(lambda (label posn delta-if-after)
1463                           (- (+ (label-position label posn delta-if-after)
1464                                 (component-header-length)))))))
1465
1466 ;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
1467 (define-instruction compute-lra-from-code (segment src label temp dst)
1468   (:declare (type tn src dst temp)
1469             (type label label))
1470   (:vop-var vop)
1471   (:emitter
1472    (emit-compute-inst segment vop src label temp dst
1473                       #'(lambda (label posn delta-if-after)
1474                           (+ (label-position label posn delta-if-after)
1475                              (component-header-length))))))
1476
1477 \f
1478 ;;;; Data instructions.
1479
1480 (define-instruction byte (segment byte)
1481   (:emitter
1482    (emit-byte segment byte)))
1483
1484 (define-bitfield-emitter emit-halfword 16
1485   (byte 16 0))
1486
1487 (define-instruction halfword (segment halfword)
1488   (:emitter
1489    (emit-halfword segment halfword)))
1490
1491 (define-bitfield-emitter emit-word 32
1492   (byte 32 0))
1493
1494 (define-instruction word (segment word)
1495   (:emitter
1496    (emit-word segment word)))
1497
1498 (define-instruction fun-header-word (segment)
1499   (:emitter
1500    (emit-back-patch
1501     segment 4
1502     #'(lambda (segment posn)
1503         (emit-word segment
1504                    (logior simple-fun-header-widetag
1505                            (ash (+ posn (component-header-length))
1506                                 (- n-widetag-bits word-shift))))))))
1507
1508 (define-instruction lra-header-word (segment)
1509   (:emitter
1510    (emit-back-patch
1511     segment 4
1512     #'(lambda (segment posn)
1513         (emit-word segment
1514                    (logior return-pc-header-widetag
1515                            (ash (+ posn (component-header-length))
1516                                 (- n-widetag-bits word-shift))))))))