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