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 (!def-vm-support-routine 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 (<= (- (ash 1 16)) disp (1- (ash 1 16))))
 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         (when (not (<= (- (ash 1 11)) disp (1- (ash 1 11))))
 867           (format t "AVER fail: disp = ~s~%" disp)
 868           (format t "target = ~s~%" target)
 869           (format t "posn   = ~s~%" posn)
 870           )
 871         (aver (<= (- (ash 1 11)) disp (1- (ash 1 11))))
 872         (let ((w1 (logior (ash (ldb (byte 10 0) disp) 1)
 873                           (ldb (byte 1 10) disp)))
 874               (w (ldb (byte 1 11) disp)))
 875           (emit-branch segment opcode r2 r1 cond w1 (if nullify 1 0) w))))))
 876
 877 (defun im5-encoding (value)
 878   (declare (type (signed-byte 5) value)
 879            #+nil (values (unsigned-byte 5)))
 880   (dpb (ldb (byte 4 0) value)
 881        (byte 4 1)
 882        (ldb (byte 1 4) value)))
 883
 884 (macrolet ((define-branch-inst (r-name r-opcode i-name i-opcode cond-kind
 885                                 writes-reg)
 886                (let* ((conditional (symbolicate cond-kind "-CONDITION"))
 887                       (false-conditional (symbolicate conditional "-FALSE")))
 888                  `(progn
 889                    (define-instruction ,r-name (segment cond r1 r2 target &key nullify)
 890                      (:declare (type ,conditional cond)
 891                                (type tn r1 r2)
 892                                (type label target)
 893                                (type (member t nil) nullify))
 894                      (:delay 0)
 895                      ,@(ecase writes-reg
 896                          (:write-reg
 897                            '((:dependencies (reads r1) (reads r2) (writes r2))))
 898                          (:pinned
 899                            '(:pinned))
 900                          (nil
 901                            '((:dependencies (reads r1) (reads r2)))))
 902 ;                     ,@(if writes-reg
 903 ;                         '((:dependencies (reads r1) (reads r2) (writes r2)))
 904 ;                         '((:dependencies (reads r1) (reads r2))))
 905                      (:printer branch12 ((op1 ,r-opcode) (c nil :type ',conditional))
 906                       '(:name c n :tab r1 "," r2 "," w))
 907                      ,@(unless (= r-opcode #x32)
 908                          `((:printer branch12 ((op1 ,(+ 2 r-opcode))
 909                                                (c nil :type ',false-conditional))
 910                             '(:name c n :tab r1 "," r2 "," w))))
 911                      (:emitter
 912                       (multiple-value-bind
 913                             (cond-encoding false)
 914                           (,conditional cond)
 915                         (emit-conditional-branch
 916                          segment (if false ,(+ r-opcode 2) ,r-opcode)
 917                          (reg-tn-encoding r2) (reg-tn-encoding r1)
 918                          cond-encoding target nullify))))
 919                    (define-instruction ,i-name (segment cond imm reg target &key nullify)
 920                      (:declare (type ,conditional cond)
 921                                (type (signed-byte 5) imm)
 922                                (type tn reg)
 923                                (type (member t nil) nullify))
 924                      (:delay 0)
 925 ;                     ,@(if writes-reg
 926 ;                         '((:dependencies (reads reg) (writes reg)))
 927 ;                         '((:dependencies (reads reg))))
 928                      ,@(ecase writes-reg
 929                          (:write-reg
 930                            '((:dependencies (reads r1) (reads r2) (writes r2))))
 931                          (:pinned
 932                            '(:pinned))
 933                          (nil
 934                            '((:dependencies (reads r1) (reads r2)))))
 935                      (:printer branch12 ((op1 ,i-opcode) (r1 nil :type 'im5)
 936                                          (c nil :type ',conditional))
 937                       '(:name c n :tab r1 "," r2 "," w))
 938                      ,@(unless (= r-opcode #x32)
 939                                `((:printer branch12 ((op1 ,(+ 2 i-opcode)) (r1 nil :type 'im5)
 940                                                      (c nil :type ',false-conditional))
 941                                   '(:name c n :tab r1 "," r2 "," w))))
 942                      (:emitter
 943                       (multiple-value-bind
 944                             (cond-encoding false)
 945                           (,conditional cond)
 946                         (emit-conditional-branch
 947                          segment (if false (+ ,i-opcode 2) ,i-opcode)
 948                          (reg-tn-encoding reg) (im5-encoding imm)
 949                          cond-encoding target nullify))))))))
 950   (define-branch-inst movb #x32 movib #x33 extract/deposit :write-reg)
 951   (define-branch-inst comb #x20 comib #x21 compare :pinned)
 952   (define-branch-inst addb #x28 addib #x29 add :write-reg))
 953
 954 (define-instruction bb (segment cond reg posn target &key nullify)
 955   (:declare (type (member t nil) cond nullify)
 956             (type tn reg)
 957             (type (or (member :variable) (unsigned-byte 5)) posn))
 958   (:delay 0)
 959   (:dependencies (reads reg))
 960   (:printer branch12 ((op1 30) (c nil :type 'extract/deposit-condition))
 961                       '('BVB c n :tab r1 "," w))
 962   (:emitter
 963    (multiple-value-bind
 964        (opcode posn-encoding)
 965        (if (eq posn :variable)
 966            (values #x30 0)
 967            (values #x31 posn))
 968      (emit-conditional-branch segment opcode posn-encoding
 969                               (reg-tn-encoding reg)
 970                               (if cond 2 6) target nullify))))
 971
 972 \f
 973 ;;;; Computation Instructions
 974
 975 (define-bitfield-emitter emit-r3-inst 32
 976   (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
 977   (byte 1 12) (byte 7 5) (byte 5 0))
 978
 979 (macrolet ((define-r3-inst (name cond-kind opcode &optional pinned)
 980                `(define-instruction ,name (segment r1 r2 res &optional cond)
 981                  (:declare (type tn res r1 r2))
 982                  (:delay 0)
 983                  ,@(if pinned
 984                      '(:pinned)
 985                      '((:dependencies (reads r1) (reads r2) (writes res))))
 986                  (:printer r3-inst ((op ,opcode) (c nil :type ',(symbolicate
 987                                                                  cond-kind
 988                                                                  "-CONDITION"))))
 989                  ,@(when (eq name 'or)
 990                          `((:printer r3-inst ((op ,opcode) (r2 0)
 991                                               (c nil :type ',(symbolicate cond-kind
 992                                                                           "-CONDITION")))
 993                             `('COPY :tab r1 "," t))))
 994                  (:emitter
 995                   (multiple-value-bind
 996                         (cond false)
 997                       (,(symbolicate cond-kind "-CONDITION") cond)
 998                     (emit-r3-inst segment #x02 (reg-tn-encoding r2) (reg-tn-encoding r1)
 999                                   cond (if false 1 0) ,opcode
1000                                   (reg-tn-encoding res)))))))
1001   (define-r3-inst add add #x30)
1002   (define-r3-inst addl add #x50)
1003   (define-r3-inst addo add #x70)
1004   (define-r3-inst addc add #x38)
1005   (define-r3-inst addco add #x78)
1006   (define-r3-inst sh1add add #x32)
1007   (define-r3-inst sh1addl add #x52)
1008   (define-r3-inst sh1addo add #x72)
1009   (define-r3-inst sh2add add #x34)
1010   (define-r3-inst sh2addl add #x54)
1011   (define-r3-inst sh2addo add #x74)
1012   (define-r3-inst sh3add add #x36)
1013   (define-r3-inst sh3addl add #x56)
1014   (define-r3-inst sh3addo add #x76)
1015   (define-r3-inst sub compare #x20)
1016   (define-r3-inst subo compare #x60)
1017   (define-r3-inst subb compare #x28)
1018   (define-r3-inst subbo compare #x68)
1019   (define-r3-inst subt compare #x26)
1020   (define-r3-inst subto compare #x66)
1021   (define-r3-inst ds compare #x22)
1022   (define-r3-inst comclr compare #x44)
1023   (define-r3-inst or logical #x12 t) ; as a nop it must be pinned
1024   (define-r3-inst xor logical #x14)
1025   (define-r3-inst and logical #x10)
1026   (define-r3-inst andcm logical #x00)
1027   (define-r3-inst uxor unit #x1C)
1028   (define-r3-inst uaddcm unit #x4C)
1029   (define-r3-inst uaddcmt unit #x4E)
1030   (define-r3-inst dcor unit #x5C)
1031   (define-r3-inst idcor unit #x5E))
1032
1033 (define-bitfield-emitter emit-imm-inst 32
1034   (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
1035   (byte 1 12) (byte 1 11) (byte 11 0))
1036
1037 (macrolet ((define-imm-inst (name cond-kind opcode subcode &optional pinned)
1038              `(define-instruction ,name (segment imm src dst &optional cond)
1039                 (:declare (type tn dst src)
1040                   (type (signed-byte 11) imm))
1041                 (:delay 0)
1042                 (:printer imm-inst ((op ,opcode) (o ,subcode)
1043                                     (c nil :type
1044                                        ',(symbolicate cond-kind "-CONDITION"))))
1045                 (:dependencies (reads imm) (reads src) (writes dst))
1046                 (:emitter
1047                   (multiple-value-bind (cond false)
1048                       (,(symbolicate cond-kind "-CONDITION") cond)
1049                     (emit-imm-inst segment ,opcode (reg-tn-encoding src)
1050                                    (reg-tn-encoding dst) cond
1051                                    (if false 1 0) ,subcode
1052                                    (encode-imm11 imm)))))))
1053   (define-imm-inst addi add #x2D 0)
1054   (define-imm-inst addio add #x2D 1)
1055   (define-imm-inst addit add #x2C 0)
1056   (define-imm-inst addito add #x2C 1)
1057   (define-imm-inst subi compare #x25 0)
1058   (define-imm-inst subio compare #x25 1)
1059   (define-imm-inst comiclr compare #x24 0))
1060
1061 (define-bitfield-emitter emit-extract/deposit-inst 32
1062   (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
1063   (byte 3 10) (byte 5 5) (byte 5 0))
1064
1065 (define-instruction shd (segment r1 r2 count res &optional cond)
1066   (:declare (type tn res r1 r2)
1067             (type (or (member :variable) (integer 0 31)) count))
1068   (:delay 0)
1069   :pinned
1070   (:printer extract/deposit-inst ((op1 #x34) (op2 2) (t/clen nil :type 'reg))
1071             '(:name c :tab r1 "," r2 "," cp "," t/clen))
1072   (:printer extract/deposit-inst ((op1 #x34) (op2 0) (t/clen nil :type 'reg))
1073             '('VSHD c :tab r1 "," r2 "," t/clen))
1074   (:emitter
1075    (etypecase count
1076      ((member :variable)
1077       (emit-extract/deposit-inst segment #x34
1078                                  (reg-tn-encoding r2) (reg-tn-encoding r1)
1079                                  (extract/deposit-condition cond)
1080                                  0 0 (reg-tn-encoding res)))
1081      ((integer 0 31)
1082       (emit-extract/deposit-inst segment #x34
1083                                  (reg-tn-encoding r2) (reg-tn-encoding r1)
1084                                  (extract/deposit-condition cond)
1085                                  2 (- 31 count)
1086                                  (reg-tn-encoding res))))))
1087
1088 (macrolet ((define-extract-inst (name opcode)
1089                `(define-instruction ,name (segment src posn len res &optional cond)
1090                  (:declare (type tn res src)
1091                   (type (or (member :variable) (integer 0 31)) posn)
1092                   (type (integer 1 32) len))
1093                  (:delay 0)
1094                  (:dependencies (reads src) (writes res))
1095                  (:printer extract/deposit-inst ((op1 #x34) (cp nil :type 'integer)
1096                                                  (op2 ,opcode))
1097                   '(:name c :tab r2 "," cp "," t/clen "," r1))
1098                  (:printer extract/deposit-inst ((op1 #x34) (op2 ,(- opcode 2)))
1099                   '('V :name c :tab r2 "," t/clen "," r1))
1100                  (:emitter
1101                   (etypecase posn
1102                     ((member :variable)
1103                      (emit-extract/deposit-inst segment #x34 (reg-tn-encoding src)
1104                                                 (reg-tn-encoding res)
1105                                                 (extract/deposit-condition cond)
1106                                                 ,(- opcode 2) 0 (- 32 len)))
1107                     ((integer 0 31)
1108                      (emit-extract/deposit-inst segment #x34 (reg-tn-encoding src)
1109                                                 (reg-tn-encoding res)
1110                                                 (extract/deposit-condition cond)
1111                                                 ,opcode posn (- 32 len))))))))
1112   (define-extract-inst extru 6)
1113   (define-extract-inst extrs 7))
1114
1115 (macrolet ((define-deposit-inst (name opcode)
1116              `(define-instruction ,name (segment src posn len res &optional cond)
1117                (:declare (type tn res)
1118                 (type (or tn (signed-byte 5)) src)
1119                 (type (or (member :variable) (integer 0 31)) posn)
1120                 (type (integer 1 32) len))
1121                (:delay 0)
1122                (:dependencies (reads src) (writes res))
1123                (:printer extract/deposit-inst ((op1 #x35) (op2 ,opcode))
1124                 ',(let ((base '('VDEP c :tab r1 "," t/clen "," r2)))
1125                        (if (= opcode 0) (cons ''Z base) base)))
1126                (:printer extract/deposit-inst ((op1 #x35) (op2 ,(+ 2 opcode)))
1127                 ',(let ((base '('DEP c :tab r1 "," cp "," t/clen "," r2)))
1128                        (if (= opcode 0) (cons ''Z base) base)))
1129                (:printer extract/deposit-inst ((op1 #x35) (r1 nil :type 'im5)
1130                                                (op2 ,(+ 4 opcode)))
1131                 ',(let ((base '('VDEPI c :tab r1 "," t/clen "," r2)))
1132                        (if (= opcode 0) (cons ''Z base) base)))
1133                (:printer extract/deposit-inst ((op1 #x35) (r1 nil :type 'im5)
1134                                                (op2 ,(+ 6 opcode)))
1135                 ',(let ((base '('DEPI c :tab r1 "," cp "," t/clen "," r2)))
1136                        (if (= opcode 0) (cons ''Z base) base)))
1137                (:emitter
1138                 (multiple-value-bind
1139                       (opcode src-encoding)
1140                     (etypecase src
1141                       (tn
1142                        (values ,opcode (reg-tn-encoding src)))
1143                       ((signed-byte 5)
1144                        (values ,(+ opcode 4) (im5-encoding src))))
1145                   (multiple-value-bind
1146                         (opcode posn-encoding)
1147                       (etypecase posn
1148                         ((member :variable)
1149                          (values opcode 0))
1150                         ((integer 0 31)
1151                          (values (+ opcode 2) (- 31 posn))))
1152                     (emit-extract/deposit-inst segment #x35 (reg-tn-encoding res)
1153                                                src-encoding
1154                                                (extract/deposit-condition cond)
1155                                                opcode posn-encoding (- 32 len))))))))
1156
1157   (define-deposit-inst dep 1)
1158   (define-deposit-inst zdep 0))
1159
1160
1161 \f
1162 ;;;; System Control Instructions.
1163
1164 (define-bitfield-emitter emit-break 32
1165   (byte 6 26) (byte 13 13) (byte 8 5) (byte 5 0))
1166
1167 (define-instruction break (segment &optional (im5 0) (im13 0))
1168   (:declare (type (unsigned-byte 13) im13)
1169             (type (unsigned-byte 5) im5))
1170   (:cost 0)
1171   (:delay 0)
1172   :pinned
1173   (:printer break () :default :control #'break-control)
1174   (:emitter
1175    (emit-break segment 0 im13 0 im5)))
1176
1177 (define-bitfield-emitter emit-system-inst 32
1178   (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 8 5) (byte 5 0))
1179
1180 (define-instruction ldsid (segment res base &optional (space 0))
1181   (:declare (type tn res base)
1182             (type (integer 0 3) space))
1183   (:delay 0)
1184   :pinned
1185   (:printer system-inst ((op2 #x85) (c nil :type 'space)
1186                          (s nil  :printer #(0 0 1 1 2 2 3 3)))
1187             `(:name :tab "(" s r1 ")," r3))
1188   (:emitter
1189    (emit-system-inst segment 0 (reg-tn-encoding base) 0 (ash space 1) #x85
1190                      (reg-tn-encoding res))))
1191
1192 (define-instruction mtsp (segment reg space)
1193   (:declare (type tn reg) (type (integer 0 7) space))
1194   (:delay 0)
1195   :pinned
1196   (:printer system-inst ((op2 #xC1)) '(:name :tab r2 "," s))
1197   (:emitter
1198    (emit-system-inst segment 0 0 (reg-tn-encoding reg) (space-encoding space)
1199                      #xC1 0)))
1200
1201 (define-instruction mfsp (segment space reg)
1202   (:declare (type tn reg) (type (integer 0 7) space))
1203   (:delay 0)
1204   :pinned
1205   (:printer system-inst ((op2 #x25) (c nil :type 'space)) '(:name :tab s r3))
1206   (:emitter
1207    (emit-system-inst segment 0 0 0 (space-encoding space) #x25
1208                      (reg-tn-encoding reg))))
1209
1210 (deftype control-reg ()
1211   '(or (unsigned-byte 5) (member :sar)))
1212
1213 (defun control-reg (reg)
1214   (declare (type control-reg reg)
1215            #+nil (values (unsigned-byte 32)))
1216   (if (typep reg '(unsigned-byte 5))
1217       reg
1218       (ecase reg
1219         (:sar 11))))
1220
1221 (define-instruction mtctl (segment reg ctrl-reg)
1222   (:declare (type tn reg) (type control-reg ctrl-reg))
1223   (:delay 0)
1224   :pinned
1225   (:printer system-inst ((op2 #xC2)) '(:name :tab r2 "," r1))
1226   (:emitter
1227    (emit-system-inst segment 0 (control-reg ctrl-reg) (reg-tn-encoding reg)
1228                      0 #xC2 0)))
1229
1230 (define-instruction mfctl (segment ctrl-reg reg)
1231   (:declare (type tn reg) (type control-reg ctrl-reg))
1232   (:delay 0)
1233   :pinned
1234   (:printer system-inst ((op2 #x45)) '(:name :tab r1 "," r3))
1235   (:emitter
1236    (emit-system-inst segment 0 (control-reg ctrl-reg) 0 0 #x45
1237                      (reg-tn-encoding reg))))
1238
1239
1240 \f
1241 ;;;; Floating point instructions.
1242
1243 (define-bitfield-emitter emit-fp-load/store 32
1244   (byte 6 26) (byte 5 21) (byte 5 16) (byte 2 14) (byte 1 13) (byte 1 12)
1245   (byte 2 10) (byte 1 9) (byte 3 6) (byte 1 5) (byte 5 0))
1246
1247 (define-instruction fldx (segment index base result &key modify scale side)
1248   (:declare (type tn index base result)
1249             (type (member t nil) modify scale)
1250             (type (member nil 0 1) side))
1251   (:delay 0)
1252   :pinned
1253   (:printer fp-load/store ((op #x0b) (x1 0) (x2 0) (x3 0))
1254             `('FLDD ,@cmplt-index-print :tab x "(" s b ")" "," t))
1255   (:printer fp-load/store ((op #x09) (x1 0) (x2 0) (x3 0))
1256             `('FLDW ,@cmplt-index-print :tab x "(" s b ")" "," t))
1257   (:emitter
1258    (multiple-value-bind
1259        (result-encoding double-p)
1260        (fp-reg-tn-encoding result)
1261      (when side
1262        (aver double-p)
1263        (setf double-p nil))
1264      (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
1265                          (reg-tn-encoding index) 0 (if scale 1 0) 0 0 0
1266                          (or side 0) (if modify 1 0) result-encoding))))
1267
1268 (define-instruction fstx (segment value index base &key modify scale side)
1269   (:declare (type tn index base value)
1270             (type (member t nil) modify scale)
1271             (type (member nil 0 1) side))
1272   (:delay 0)
1273   :pinned
1274   (:printer fp-load/store ((op #x0b) (x1 0) (x2 0) (x3 1))
1275             `('FSTD ,@cmplt-index-print :tab t "," x "(" s b ")"))
1276   (:printer fp-load/store ((op #x09) (x1 0) (x2 0) (x3 1))
1277             `('FSTW ,@cmplt-index-print :tab t "," x "(" s b ")"))
1278   (:emitter
1279    (multiple-value-bind
1280        (value-encoding double-p)
1281        (fp-reg-tn-encoding value)
1282      (when side
1283        (aver double-p)
1284        (setf double-p nil))
1285      (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
1286                          (reg-tn-encoding index) 0 (if scale 1 0) 0 0 1
1287                          (or side 0) (if modify 1 0) value-encoding))))
1288
1289 (define-instruction flds (segment disp base result &key modify side)
1290   (:declare (type tn base result)
1291             (type (signed-byte 5) disp)
1292             (type (member :before :after nil) modify)
1293             (type (member nil 0 1) side))
1294   (:delay 0)
1295   :pinned
1296   (:printer fp-load/store ((op #x0b) (x nil :type 'im5) (x1 1) (x2 0) (x3 0))
1297             `('FLDD ,@cmplt-disp-print :tab x "(" s b ")," t))
1298   (:printer fp-load/store ((op #x09) (x nil :type 'im5) (x1 1) (x2 0) (x3 0))
1299             `('FLDW ,@cmplt-disp-print :tab x "(" s b ")," t))
1300   (:emitter
1301    (multiple-value-bind
1302        (result-encoding double-p)
1303        (fp-reg-tn-encoding result)
1304      (when side
1305        (aver double-p)
1306        (setf double-p nil))
1307      (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
1308                          (short-disp-encoding segment disp) 0
1309                          (if (eq modify :before) 1 0) 1 0 0
1310                          (or side 0) (if modify 1 0) result-encoding))))
1311
1312 (define-instruction fsts (segment value disp base &key modify side)
1313   (:declare (type tn base value)
1314             (type (signed-byte 5) disp)
1315             (type (member :before :after nil) modify)
1316             (type (member nil 0 1) side))
1317   (:delay 0)
1318   :pinned
1319   (:printer fp-load/store ((op #x0b) (x nil :type 'im5) (x1 1) (x2 0) (x3 1))
1320             `('FSTD ,@cmplt-disp-print :tab t "," x "(" s b ")"))
1321   (:printer fp-load/store ((op #x09) (x nil :type 'im5) (x1 1) (x2 0) (x3 1))
1322             `('FSTW ,@cmplt-disp-print :tab t "," x "(" s b ")"))
1323   (:emitter
1324    (multiple-value-bind
1325        (value-encoding double-p)
1326        (fp-reg-tn-encoding value)
1327      (when side
1328        (aver double-p)
1329        (setf double-p nil))
1330      (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
1331                          (short-disp-encoding segment disp) 0
1332                          (if (eq modify :before) 1 0) 1 0 1
1333                          (or side 0) (if modify 1 0) value-encoding))))
1334
1335
1336 (define-bitfield-emitter emit-fp-class-0-inst 32
1337   (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 2 11) (byte 2 9)
1338   (byte 3 6) (byte 1 5) (byte 5 0))
1339
1340 (define-bitfield-emitter emit-fp-class-1-inst 32
1341   (byte 6 26) (byte 5 21) (byte 4 17) (byte 2 15) (byte 2 13) (byte 2 11)
1342   (byte 2 9) (byte 3 6) (byte 1 5) (byte 5 0))
1343
1344 ;;; Note: classes 2 and 3 are similar enough to class 0 that we don't need
1345 ;;; seperate emitters.
1346
1347 (defconstant-eqx funops '(:copy :abs :sqrt :rnd)
1348   #'equalp)
1349
1350 (deftype funop ()
1351   `(member ,@funops))
1352
1353 (define-instruction funop (segment op from to)
1354   (:declare (type funop op)
1355             (type tn from to))
1356   (:delay 0)
1357   :pinned
1358   (:printer fp-class-0-inst ((op1 #x0C) (op2 2) (x2 0))
1359             '('FCPY fmt :tab r "," t))
1360   (:printer fp-class-0-inst ((op1 #x0C) (op2 3) (x2 0))
1361             '('FABS fmt  :tab r "," t))
1362   (:printer fp-class-0-inst ((op1 #x0C) (op2 4) (x2 0))
1363             '('FSQRT fmt :tab r "," t))
1364   (:printer fp-class-0-inst ((op1 #x0C) (op2 5) (x2 0))
1365             '('FRND fmt :tab r "," t))
1366   (:emitter
1367    (multiple-value-bind
1368        (from-encoding from-double-p)
1369        (fp-reg-tn-encoding from)
1370      (multiple-value-bind
1371          (to-encoding to-double-p)
1372          (fp-reg-tn-encoding to)
1373        (aver (eq from-double-p to-double-p))
1374        (emit-fp-class-0-inst segment #x0C from-encoding 0
1375                              (+ 2 (or (position op funops)
1376                                       (error "Bogus FUNOP: ~S" op)))
1377                              (if to-double-p 1 0) 0 0 0 to-encoding)))))
1378
1379 (macrolet ((define-class-1-fp-inst (name subcode)
1380                `(define-instruction ,name (segment from to)
1381                  (:declare (type tn from to))
1382                  (:delay 0)
1383                  (:printer fp-class-1-inst ((op1 #x0C) (x2 ,subcode))
1384                   '(:name sf df :tab r "," t))
1385                  (:emitter
1386                   (multiple-value-bind
1387                         (from-encoding from-double-p)
1388                       (fp-reg-tn-encoding from)
1389                     (multiple-value-bind
1390                           (to-encoding to-double-p)
1391                         (fp-reg-tn-encoding to)
1392                       (emit-fp-class-1-inst segment #x0C from-encoding 0 ,subcode
1393                                             (if to-double-p 1 0) (if from-double-p 1 0)
1394                                             1 0 0 to-encoding)))))))
1395
1396   (define-class-1-fp-inst fcnvff 0)
1397   (define-class-1-fp-inst fcnvxf 1)
1398   (define-class-1-fp-inst fcnvfx 2)
1399   (define-class-1-fp-inst fcnvfxt 3))
1400
1401 (define-instruction fcmp (segment cond r1 r2)
1402   (:declare (type (unsigned-byte 5) cond)
1403             (type tn r1 r2))
1404   (:delay 0)
1405   :pinned
1406   (:printer fp-class-0-inst ((op1 #x0C) (op2 0) (x2 2) (t nil :type 'fcmp-cond))
1407             '(:name fmt t :tab r "," x1))
1408   (:emitter
1409    (multiple-value-bind
1410        (r1-encoding r1-double-p)
1411        (fp-reg-tn-encoding r1)
1412      (multiple-value-bind
1413          (r2-encoding r2-double-p)
1414          (fp-reg-tn-encoding r2)
1415        (aver (eq r1-double-p r2-double-p))
1416        (emit-fp-class-0-inst segment #x0C r1-encoding r2-encoding 0
1417                              (if r1-double-p 1 0) 2 0 0 cond)))))
1418
1419 (define-instruction ftest (segment)
1420   (:delay 0)
1421   :pinned
1422   (:printer fp-class-0-inst ((op1 #x0c) (op2 1) (x2 2)) '(:name))
1423   (:emitter
1424    (emit-fp-class-0-inst segment #x0C 0 0 1 0 2 0 1 0)))
1425
1426 (defconstant-eqx fbinops '(:add :sub :mpy :div)
1427   #'equalp)
1428
1429 (deftype fbinop ()
1430   `(member ,@fbinops))
1431
1432 (define-instruction fbinop (segment op r1 r2 result)
1433   (:declare (type fbinop op)
1434             (type tn r1 r2 result))
1435   (:delay 0)
1436   :pinned
1437   (:printer fp-class-0-inst ((op1 #x0C) (op2 0) (x2 3))
1438             '('FADD fmt :tab r "," x1 "," t))
1439   (:printer fp-class-0-inst ((op1 #x0C) (op2 1) (x2 3))
1440             '('FSUB fmt :tab r "," x1 "," t))
1441   (:printer fp-class-0-inst ((op1 #x0C) (op2 2) (x2 3))
1442             '('FMPY fmt :tab r "," x1 "," t))
1443   (:printer fp-class-0-inst ((op1 #x0C) (op2 3) (x2 3))
1444             '('FDIV fmt :tab r "," x1 "," t))
1445   (:emitter
1446    (multiple-value-bind
1447        (r1-encoding r1-double-p)
1448        (fp-reg-tn-encoding r1)
1449      (multiple-value-bind
1450          (r2-encoding r2-double-p)
1451          (fp-reg-tn-encoding r2)
1452        (aver (eq r1-double-p r2-double-p))
1453        (multiple-value-bind
1454            (result-encoding result-double-p)
1455            (fp-reg-tn-encoding result)
1456          (aver (eq r1-double-p result-double-p))
1457          (emit-fp-class-0-inst segment #x0C r1-encoding r2-encoding
1458                                (or (position op fbinops)
1459                                    (error "Bogus FBINOP: ~S" op))
1460                                (if r1-double-p 1 0) 3 0 0
1461                                result-encoding))))))
1462
1463
1464 \f
1465 ;;;; Instructions built out of other insts.
1466
1467 (define-instruction-macro move (src dst &optional cond)
1468   `(inst or ,src zero-tn ,dst ,cond))
1469
1470 (define-instruction-macro nop (&optional cond)
1471   `(inst or zero-tn zero-tn zero-tn ,cond))
1472
1473 (define-instruction li (segment value reg)
1474   (:declare (type tn reg)
1475             (type (or fixup (signed-byte 32) (unsigned-byte 32)) value))
1476   (:delay 0)
1477   (:dependencies (reads reg))
1478   (:vop-var vop)
1479   (:emitter
1480    (assemble (segment vop)
1481      (etypecase value
1482        (fixup
1483         (inst ldil value reg)
1484         (inst ldo value reg reg :unsigned t))
1485        ((signed-byte 14)
1486         (inst ldo value zero-tn reg))
1487        ((or (signed-byte 32) (unsigned-byte 32))
1488         (let ((lo (ldb (byte 11 0) value)))
1489           (inst ldil value reg)
1490           (inst ldo lo reg reg :unsigned t)))))))
1491
1492 (define-instruction-macro sll (src count result &optional cond)
1493   (once-only ((result result) (src src) (count count) (cond cond))
1494     `(inst zdep ,src (- 31 ,count) (- 32 ,count) ,result ,cond)))
1495
1496 (define-instruction-macro sra (src count result &optional cond)
1497   (once-only ((result result) (src src) (count count) (cond cond))
1498     `(inst extrs ,src (- 31 ,count) (- 32 ,count) ,result ,cond)))
1499
1500 (define-instruction-macro srl (src count result &optional cond)
1501   (once-only ((result result) (src src) (count count) (cond cond))
1502     `(inst extru ,src (- 31 ,count) (- 32 ,count) ,result ,cond)))
1503
1504 (defun maybe-negate-cond (cond negate)
1505   (if negate
1506       (multiple-value-bind
1507           (value negate)
1508           (compare-condition cond)
1509         (if negate
1510             (nth value compare-conditions)
1511             (nth (+ value 8) compare-conditions)))
1512       cond))
1513
1514 (define-instruction bc (segment cond not-p r1 r2 target)
1515   (:declare (type compare-condition cond)
1516             (type (member t nil) not-p)
1517             (type tn r1 r2)
1518             (type label target))
1519   (:delay 0)
1520   (:dependencies (reads r1) (reads r2))
1521   (:vop-var vop)
1522   (:emitter
1523    (emit-chooser segment 8 2
1524      (lambda (segment posn delta)
1525        (let ((disp (label-relative-displacement target posn delta)))
1526          (when (<= 0 disp (1- (ash 1 11)))
1527            (assemble (segment vop)
1528              (inst comb (maybe-negate-cond cond not-p) r1 r2 target
1529                    :nullify t))
1530            t)))
1531      (lambda (segment posn)
1532        (let ((disp (label-relative-displacement target posn)))
1533          (assemble (segment vop)
1534            (cond ((<= (- (ash 1 11)) disp (1- (ash 1 11)))
1535                   (inst comb (maybe-negate-cond cond not-p) r1 r2 target)
1536                   (inst nop)) ; FIXME-lav, cant nullify when backward branch
1537                  (t
1538                   (inst comclr r1 r2 zero-tn
1539                         (maybe-negate-cond cond (not not-p)))
1540                   (inst b target :nullify t)))))))))
1541
1542 (define-instruction bci (segment cond not-p imm reg target)
1543   (:declare (type compare-condition cond)
1544             (type (member t nil) not-p)
1545             (type (signed-byte 11) imm)
1546             (type tn reg)
1547             (type label target))
1548   (:delay 0)
1549   (:dependencies (reads reg))
1550   (:vop-var vop)
1551   (:emitter
1552    (emit-chooser segment 8 2
1553      (lambda (segment posn delta-if-after)
1554        (let ((disp (label-relative-displacement target posn delta-if-after)))
1555          (when (and (<= 0 disp (1- (ash 1 11)))
1556                     (<= (- (ash 1 4)) imm (1- (ash 1 4))))
1557            (assemble (segment vop)
1558              (inst comib (maybe-negate-cond cond not-p) imm reg target
1559                    :nullify t))
1560            t)))
1561      (lambda (segment posn)
1562        (let ((disp (label-relative-displacement target posn)))
1563          (assemble (segment vop)
1564            (cond ((and (<= (- (ash 1 11)) disp (1- (ash 1 11)))
1565                        (<= (- (ash 1 4)) imm (1- (ash 1 4))))
1566                   (inst comib (maybe-negate-cond cond not-p) imm reg target)
1567                   (inst nop))
1568                  (t
1569                   (inst comiclr imm reg zero-tn
1570                         (maybe-negate-cond cond (not not-p)))
1571                   (inst b target :nullify t)))))))))
1572
1573 \f
1574 ;;;; Instructions to convert between code ptrs, functions, and lras.
1575
1576 (defun emit-header-data (segment type)
1577   (emit-back-patch
1578    segment 4
1579    (lambda (segment posn)
1580      (emit-word segment
1581                 (logior type
1582                         (ash (+ posn (component-header-length))
1583                              (- n-widetag-bits word-shift)))))))
1584
1585 (define-instruction simple-fun-header-word (segment)
1586   :pinned
1587   (:cost 0)
1588   (:delay 0)
1589   (:emitter
1590    (emit-header-data segment simple-fun-header-widetag)))
1591
1592 (define-instruction lra-header-word (segment)
1593   :pinned
1594   (:cost 0)
1595   (:delay 0)
1596   (:emitter
1597    (emit-header-data segment return-pc-header-widetag)))
1598
1599
1600 (defun emit-compute-inst (segment vop src label temp dst calc)
1601   (emit-chooser
1602    ;; We emit either 12 or 4 bytes, so we maintain 3 byte alignments.
1603    segment 12 3
1604    ;; This is the best-case that emits one instruction ( 4 bytes )
1605    (lambda (segment posn delta-if-after)
1606      (let ((delta (funcall calc label posn delta-if-after)))
1607        ;; WHEN, Why not AVER ?
1608        (when (<= (- (ash 1 10)) delta (1- (ash 1 10)))
1609          (emit-back-patch segment 4
1610                           (lambda (segment posn)
1611                             (assemble (segment vop)
1612                               (inst addi (funcall calc label posn 0) src
1613                                     dst))))
1614          t)))
1615    ;; This is the worst-case that emits three instruction ( 12 bytes )
1616    (lambda (segment posn)
1617      (let ((delta (funcall calc label posn 0)))
1618        ;; FIXME-lav: why do we hit below check ?
1619        ;;  (when (<= (- (ash 1 10)) delta (1- (ash 1 10)))
1620        ;;   (error "emit-compute-inst selected worst-case, but is shrinkable, delta is ~s" delta))
1621        ;; Note: if we used addil/ldo to do this in 2 instructions then the
1622        ;; intermediate value would be tagged but pointing into space.
1623        ;; Does above note mean that the intermediate value would be
1624        ;; a bogus pointer that would be GCed wrongly ?
1625        ;; Also what I can see addil would also overwrite NFP (r1) ???
1626        (assemble (segment vop)
1627          ;; Three instructions (4 * 3) this is the reason for 12 bytes
1628          (inst ldil delta temp)
1629          (inst ldo (ldb (byte 11 0) delta) temp temp :unsigned t)
1630          (inst add src temp dst))))))
1631
1632 (macrolet ((compute ((name) &body body)
1633              `(define-instruction ,name (segment src label temp dst)
1634                (:declare (type tn src dst temp) (type label label))
1635                (:attributes variable-length)
1636                (:dependencies (reads src) (writes dst) (writes temp))
1637                (:delay 0)
1638                (:vop-var vop)
1639                (:emitter
1640                  (emit-compute-inst segment vop src label temp dst
1641                                     ,@body)))))
1642   (compute (compute-code-from-lip)
1643     (lambda (label posn delta-if-after)
1644       (- other-pointer-lowtag
1645          (label-position label posn delta-if-after)
1646          (component-header-length))))
1647   (compute (compute-code-from-lra)
1648     (lambda (label posn delta-if-after)
1649       (- (+ (label-position label posn delta-if-after)
1650             (component-header-length)))))
1651   (compute (compute-lra-from-code)
1652      (lambda (label posn delta-if-after)
1653        (+ (label-position label posn delta-if-after)
1654           (component-header-length)))))
1655 \f
1656 ;;;; Data instructions.
1657 (define-bitfield-emitter emit-word 32
1658   (byte 32 0))
1659
1660 (macrolet ((data (size type)
1661              `(define-instruction ,size (segment ,size)
1662                 (:declare (type ,type ,size))
1663                 (:cost 0)
1664                 (:delay 0)
1665                 :pinned
1666                 (:emitter
1667                  (,(symbolicate "EMIT-" size) segment ,size)))))
1668   (data byte  (or (unsigned-byte 8)  (signed-byte 8)))
1669   (data short (or (unsigned-byte 16) (signed-byte 16)))
1670   (data word  (or (unsigned-byte 23) (signed-byte 23))))
1671
1672