src/compiler/hppa/insts.lisp

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