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