src/compiler/alpha/insts.lisp

   1 ;;; the instruction set definition for the Alpha
   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 ;;;(def-assembler-params
  15 ;;;  :scheduler-p nil)
  16
  17 ;;; ../x86/insts contains the invocation
  18 ;;; (setf sb!disassem:*disassem-inst-alignment-bytes* 1)
  19 ;;; which apparently was another use of def-assembler-params
  20 \f
  21 ;;;; utility functions
  22
  23 (defun reg-tn-encoding (tn)
  24   (declare (type tn tn)
  25            (values (unsigned-byte 5)))
  26   (sc-case tn
  27     (zero zero-offset)
  28     (null null-offset)
  29     (t
  30      (aver (eq (sb-name (sc-sb (tn-sc tn))) 'registers))
  31      (tn-offset tn))))
  32
  33 (defun fp-reg-tn-encoding (tn)
  34   (declare (type tn tn))
  35   (sc-case tn
  36     (fp-single-zero (tn-offset fp-single-zero-tn))
  37     (fp-double-zero (tn-offset fp-double-zero-tn))
  38     (t
  39      (unless (eq (sb-name (sc-sb (tn-sc tn))) 'float-registers)
  40        (error "~S isn't a floating-point register." tn))
  41      (tn-offset tn))))
  42 \f
  43 ;;;; initial disassembler setup
  44
  45 ;; XXX find out what this was supposed to do
  46 ;; (sb!disassem:set-disassem-params :instruction-alignment 32)
  47
  48 (defvar *disassem-use-lisp-reg-names* t)
  49
  50 (defparameter reg-symbols
  51   (map 'vector
  52        (lambda (name)
  53          (cond ((null name) nil)
  54                (t (make-symbol (concatenate 'string "$" name)))))
  55        *register-names*))
  56
  57 (sb!disassem:define-arg-type reg
  58   :printer (lambda (value stream dstate)
  59              (declare (stream stream) (fixnum value))
  60              (let ((regname (aref reg-symbols value)))
  61                (princ regname stream)
  62                (sb!disassem:maybe-note-associated-storage-ref
  63                 value
  64                 'registers
  65                 regname
  66                 dstate))))
  67
  68 (defparameter float-reg-symbols
  69   #.(coerce
  70      (loop for n from 0 to 31 collect (make-symbol (format nil "~D" n)))
  71      'vector))
  72
  73 (sb!disassem:define-arg-type fp-reg
  74   :printer (lambda (value stream dstate)
  75              (declare (stream stream) (fixnum value))
  76              (let ((regname (aref float-reg-symbols value)))
  77                (princ regname stream)
  78                (sb!disassem:maybe-note-associated-storage-ref
  79                 value
  80                 'float-registers
  81                 regname
  82                 dstate))))
  83
  84 (sb!disassem:define-arg-type relative-label
  85   :sign-extend t
  86   :use-label (lambda (value dstate)
  87                (declare (type (signed-byte 21) value)
  88                         (type sb!disassem:disassem-state dstate))
  89                (+ (ash value 2) (sb!disassem:dstate-cur-addr dstate))))
  90
  91
  92 \f
  93 ;;;; DEFINE-INSTRUCTION-FORMATs for the disassembler
  94
  95 (sb!disassem:define-instruction-format
  96     (memory 32 :default-printer '(:name :tab ra "," disp "(" rb ")"))
  97   (op   :field (byte 6 26))
  98   (ra   :field (byte 5 21) :type 'reg)
  99   (rb   :field (byte 5 16) :type 'reg)
 100   (disp :field (byte 16 0) :sign-extend t))
 101
 102 (sb!disassem:define-instruction-format
 103     (jump 32 :default-printer '(:name :tab ra ",(" rb ")," hint))
 104   (op    :field (byte 6 26))
 105   (ra    :field (byte 5 21) :type 'reg)
 106   (rb    :field (byte 5 16) :type 'reg)
 107   (subop :field (byte 2 14))
 108   (hint  :field (byte 14 0)))
 109
 110 (sb!disassem:define-instruction-format
 111     (branch 32 :default-printer '(:name :tab ra "," disp))
 112   (op   :field (byte 6 26))
 113   (ra   :field (byte 5 21) :type 'reg)
 114   (disp :field (byte 21 0) :type 'relative-label))
 115
 116 (sb!disassem:define-instruction-format
 117     (reg-operate 32 :default-printer '(:name :tab ra "," rb "," rc))
 118   (op  :field (byte 6 26))
 119   (ra  :field (byte 5 21) :type 'reg)
 120   (rb  :field (byte 5 16) :type 'reg)
 121   (sbz :field (byte 3 13))
 122   (f   :field (byte 1 12) :value 0)
 123   (fn  :field (byte 7 5))
 124   (rc  :field (byte 5 0) :type 'reg))
 125
 126 (sb!disassem:define-instruction-format
 127     (lit-operate 32 :default-printer '(:name :tab ra "," lit "," rc))
 128   (op  :field (byte 6 26))
 129   (ra  :field (byte 5 21) :type 'reg)
 130   (lit :field (byte 8 13))
 131   (f   :field (byte 1 12) :value 1)
 132   (fn  :field (byte 7 5))
 133   (rc  :field (byte 5 0) :type 'reg))
 134
 135 (sb!disassem:define-instruction-format
 136     (fp-operate 32 :default-printer '(:name :tab fa "," fb "," fc))
 137   (op :field (byte 6 26))
 138   (fa :field (byte 5 21) :type 'fp-reg)
 139   (fb :field (byte 5 16) :type 'fp-reg)
 140   (fn :field (byte 11 5))
 141   (fc :field (byte 5 0) :type 'fp-reg))
 142
 143 (sb!disassem:define-instruction-format
 144     (call-pal 32 :default-printer '('call_pal :tab 'pal_ :name))
 145   (op      :field (byte 6 26) :value 0)
 146   (palcode :field (byte 26 0)))
 147
 148 \f
 149 ;;;; emitters
 150
 151 (define-bitfield-emitter emit-word 16
 152   (byte 16 0))
 153
 154 (define-bitfield-emitter emit-lword 32
 155   (byte 32 0))
 156
 157 (define-bitfield-emitter emit-qword 64
 158   (byte 64 0))
 159
 160 (define-bitfield-emitter emit-memory 32
 161   (byte 6 26) (byte 5 21) (byte 5 16) (byte 16 0))
 162
 163 (define-bitfield-emitter emit-branch 32
 164   (byte 6 26) (byte 5 21) (byte 21 0))
 165
 166 (define-bitfield-emitter emit-reg-operate 32
 167   (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 1 12) (byte 7 5)
 168   (byte 5 0))
 169
 170 (define-bitfield-emitter emit-lit-operate 32
 171   (byte 6 26) (byte 5 21) (byte 8 13) (byte 1 12) (byte 7 5) (byte 5 0))
 172
 173 (define-bitfield-emitter emit-fp-operate 32
 174   (byte 6 26) (byte 5 21) (byte 5 16) (byte 11 5) (byte 5 0))
 175
 176 (define-bitfield-emitter emit-pal 32
 177   (byte 6 26) (byte 26 0))
 178 \f
 179 ;;;; macros for instructions
 180
 181 (macrolet ((define-memory (name op &optional fixup float)
 182              `(define-instruction ,name (segment ra disp rb ,@(if fixup
 183                                                                   '(&optional type)))
 184                 (:declare (type tn ra rb)
 185                           ,@(if fixup    ; ### unsigned-byte 16 bad idea?
 186                                 '((type (or (unsigned-byte 16) (signed-byte 16) fixup)
 187                                         disp))
 188                               '((type (or (unsigned-byte 16) (signed-byte 16)) disp))))
 189                 (:printer memory ((op ,op)))
 190                 (:emitter
 191                  ,@(when fixup
 192                      `((when (fixup-p disp)
 193                          (note-fixup segment (or type ,fixup) disp)
 194                          (setf disp 0))))
 195                  (emit-memory segment ,op ,@(if float
 196                                                 '((fp-reg-tn-encoding ra))
 197                                               '((reg-tn-encoding ra)))
 198                               (reg-tn-encoding rb)
 199                               disp)))))
 200   (define-memory lda   #x08 :lda)
 201   (define-memory ldah  #x09 :ldah)
 202   (define-memory ldbu  #x0a)            ; BWX extension
 203   (define-memory ldwu  #x0c)            ; BWX extension
 204   (define-memory ldl   #x28)
 205   (define-memory ldq   #x29)
 206   (define-memory ldl_l #x2a)
 207   (define-memory ldq_q #x2b)
 208   (define-memory ldq_u #x0b)
 209   (define-memory stw   #x0d)            ; BWX extension
 210   (define-memory stb   #x0e)            ; BWX extension
 211   (define-memory stl   #x2c)
 212   (define-memory stq   #x2d)
 213   (define-memory stl_c #x2e)
 214   (define-memory stq_c #x2f)
 215   (define-memory stq_u #x0f)
 216   (define-memory ldf   #x20 nil t)
 217   (define-memory ldg   #x21 nil t)
 218   (define-memory lds   #x22 nil t)
 219   (define-memory ldt   #x23 nil t)
 220   (define-memory stf   #x24 nil t)
 221   (define-memory stg   #x25 nil t)
 222   (define-memory sts   #x26 nil t)
 223   (define-memory stt   #x27 nil t))
 224
 225 (macrolet ((define-jump (name subop)
 226              `(define-instruction ,name (segment ra rb &optional (hint 0))
 227                 (:declare (type tn ra rb)
 228                           (type (or (unsigned-byte 14) fixup) hint))
 229                 (:printer jump ((op #x1a) (subop ,subop)))
 230                 (:emitter
 231                  (when (fixup-p hint)
 232                    (note-fixup segment :jmp-hint hint)
 233                    (setf hint 0))
 234                  (emit-memory segment #x1a (reg-tn-encoding ra) (reg-tn-encoding rb)
 235                               (logior (ash ,subop 14) hint))))))
 236   (define-jump jmp 0)
 237   (define-jump jsr 1)
 238   (define-jump ret 2)
 239   (define-jump jsr-coroutine 3))
 240
 241
 242 (macrolet ((define-branch (name op &optional (float nil))
 243              `(define-instruction ,name (segment ra target)
 244                 (:declare (type tn ra)
 245                           (type label target))
 246                 (:printer branch ((op ,op)
 247                                   ,@(when float
 248                                       '((ra nil :type 'fp-reg)))))
 249                 (:emitter
 250                  (emit-back-patch segment 4
 251                                   (lambda (segment posn)
 252                                     (emit-branch segment ,op
 253                                                  ,@(if float
 254                                                        '((fp-reg-tn-encoding ra))
 255                                                        '((reg-tn-encoding ra)))
 256                                                  (ash (- (label-position target)
 257                                                          (+ posn 4))
 258                                                       -2))))))))
 259   (define-branch br   #x30)
 260   (define-branch bsr  #x34)
 261   (define-branch blbc #x38)
 262   (define-branch blbs #x3c)
 263   (define-branch fbeq #x31 t)
 264   (define-branch fbne #x35 t)
 265   (define-branch beq  #x39)
 266   (define-branch bne  #x3d)
 267   (define-branch fblt #x32 t)
 268   (define-branch fbge #x36 t)
 269   (define-branch blt  #x3a)
 270   (define-branch bge  #x3e)
 271   (define-branch fble #x33 t)
 272   (define-branch fbgt #x37 t)
 273   (define-branch ble  #x3b)
 274   (define-branch bgt  #x3f))
 275
 276 (macrolet ((define-operate (name op fn)
 277              `(define-instruction ,name (segment ra rb rc)
 278                 (:declare (type tn ra rc)
 279                           (type (or tn (unsigned-byte 8)) rb))
 280                 (:printer reg-operate ((op ,op) (fn ,fn)))
 281                 (:printer lit-operate ((op ,op) (fn ,fn)))
 282                 ,@(when (and (= op #x11) (= fn #x20))
 283                     `((:printer reg-operate ((op ,op) (fn ,fn) (ra 31))
 284                                 '('move :tab rb "," rc))
 285                       (:printer reg-operate ((op ,op) (fn ,fn) (ra 31) (rb 31) (rc 31))
 286                                 '('nop))))
 287                 (:emitter
 288                  (etypecase rb
 289                    (tn
 290                     (emit-reg-operate segment ,op (reg-tn-encoding ra)
 291                                       (reg-tn-encoding rb) 0 0 ,fn (reg-tn-encoding rc)))
 292                    (number
 293                     (emit-lit-operate segment ,op (reg-tn-encoding ra) rb 1 ,fn
 294                                       (reg-tn-encoding rc))))))))
 295   (define-operate addl   #x10 #x00)
 296   (define-operate addl/v #x10 #x40)
 297   (define-operate addq   #x10 #x20)
 298   (define-operate addq/v #x10 #x60)
 299   (define-operate cmpule #x10 #x3d)
 300   (define-operate cmpbge #x10 #x0f)
 301   (define-operate subl   #x10 #x09)
 302   (define-operate subl/v #x10 #x49)
 303   (define-operate subq   #x10 #x29)
 304   (define-operate subq/v #x10 #x69)
 305   (define-operate cmpeq  #x10 #x2d)
 306   (define-operate cmplt  #x10 #x4d)
 307   (define-operate cmple  #x10 #x6d)
 308   (define-operate cmpult #x10 #x1d)
 309   (define-operate s4addl #x10 #x02)
 310   (define-operate s4addq #x10 #x22)
 311   (define-operate s4subl #x10 #x0b)
 312   (define-operate s4subq #x10 #x2b)
 313   (define-operate s8addl #x10 #x12)
 314   (define-operate s8addq #x10 #x32)
 315   (define-operate s8subl #x10 #x1b)
 316   (define-operate s8subq #x10 #x3b)
 317
 318   (define-operate and     #x11 #x00)
 319   (define-operate bic     #x11 #x08)
 320   (define-operate cmoveq  #x11 #x24)
 321   (define-operate cmovne  #x11 #x26)
 322   (define-operate cmovlbs #x11 #x14)
 323   (define-operate bis     #x11 #x20)
 324   (define-operate ornot   #x11 #x28)
 325   (define-operate cmovlt  #x11 #x44)
 326   (define-operate cmovge  #x11 #x46)
 327   (define-operate cmovlbc #x11 #x16)
 328   (define-operate xor     #x11 #x40)
 329   (define-operate eqv     #x11 #x48)
 330   (define-operate cmovle  #x11 #x64)
 331   (define-operate cmovgt  #x11 #x66)
 332
 333   (define-operate sll    #x12 #x39)
 334   (define-operate extbl  #x12 #x06)
 335   (define-operate extwl  #x12 #x16)
 336   (define-operate extll  #x12 #x26)
 337   (define-operate extql  #x12 #x36)
 338   (define-operate extwh  #x12 #x5a)
 339   (define-operate extlh  #x12 #x6a)
 340   (define-operate extqh  #x12 #x7a)
 341   (define-operate sra    #x12 #x3c)
 342   (define-operate insbl  #x12 #x0b)
 343   (define-operate inswl  #x12 #x1b)
 344   (define-operate insll  #x12 #x2b)
 345   (define-operate insql  #x12 #x3b)
 346   (define-operate inswh  #x12 #x57)
 347   (define-operate inslh  #x12 #x67)
 348   (define-operate insqh  #x12 #x77)
 349   (define-operate srl    #x12 #x34)
 350   (define-operate mskbl  #x12 #x02)
 351   (define-operate mskwl  #x12 #x12)
 352   (define-operate mskll  #x12 #x22)
 353   (define-operate mskql  #x12 #x32)
 354   (define-operate mskwh  #x12 #x52)
 355   (define-operate msklh  #x12 #x62)
 356   (define-operate mskqh  #x12 #x72)
 357   (define-operate zap    #x12 #x30)
 358   (define-operate zapnot #x12 #x31)
 359
 360   (define-operate mull   #x13 #x00)
 361   (define-operate mulq/v #x13 #x60)
 362   (define-operate mull/v #x13 #x40)
 363   (define-operate umulh  #x13 #x30)
 364   (define-operate mulq   #x13 #x20)
 365
 366   (define-operate ctpop  #x1c #x30)     ; CIX extension
 367   (define-operate ctlz   #x1c #x32)     ; CIX extension
 368   (define-operate cttz   #x1c #x33))    ; CIX extension
 369
 370
 371 (macrolet ((define-fp-operate (name op fn &optional (args 3))
 372              `(define-instruction ,name (segment ,@(when (= args 3) '(fa)) fb fc)
 373                 (:declare (type tn ,@(when (= args 3) '(fa)) fb fc))
 374                 (:printer fp-operate ((op ,op) (fn ,fn) ,@(when (= args 2) '((fa 31))))
 375                           ,@(when (= args 2)
 376                               '('(:name :tab fb "," fc))))
 377                 ,@(when (and (= op #x17) (= fn #x20))
 378                     `((:printer fp-operate ((op ,op) (fn ,fn) (fa 31))
 379                                 '('fabs :tab fb "," fc))))
 380                 (:emitter
 381                  (emit-fp-operate segment ,op ,@(if (= args 3)
 382                                                     '((fp-reg-tn-encoding fa))
 383                                                   '(31))
 384                                   (fp-reg-tn-encoding fb) ,fn (fp-reg-tn-encoding fc))))))
 385   (define-fp-operate cpys     #x17 #x020)
 386   (define-fp-operate mf_fpcr  #x17 #x025)
 387   (define-fp-operate cpysn    #x17 #x021)
 388   (define-fp-operate mt_fpcr  #x17 #x024)
 389   (define-fp-operate cpyse    #x17 #x022)
 390   (define-fp-operate cvtql/sv #x17 #x530 2)
 391   (define-fp-operate cvtlq    #x17 #x010 2)
 392   (define-fp-operate cvtql    #x17 #x030 2)
 393   (define-fp-operate cvtql/v  #x17 #x130 2)
 394   (define-fp-operate fcmoveq  #x17 #x02a)
 395   (define-fp-operate fcmovne  #x17 #x02b)
 396   (define-fp-operate fcmovlt  #x17 #x02c)
 397   (define-fp-operate fcmovge  #x17 #x02d)
 398   (define-fp-operate fcmovle  #x17 #x02e)
 399   (define-fp-operate fcmovgt  #x17 #x02f)
 400
 401   (define-fp-operate cvtqs #x16 #x0bc 2)
 402   (define-fp-operate cvtqt #x16 #x0be 2)
 403   (define-fp-operate cvtts #x16 #x0ac 2)
 404   (define-fp-operate cvttq #x16 #x0af 2)
 405   (define-fp-operate cvttq/c #x16 #x02f 2)
 406   (define-fp-operate cmpteq #x16 #x5a5)
 407   (define-fp-operate cmptlt #x16 #x5a6)
 408   (define-fp-operate cmptle #x16 #x5a7)
 409   (define-fp-operate cmptun #x16 #x5a4)
 410   (define-fp-operate adds #x16 #x080)
 411   (define-fp-operate addt #x16 #x0a0)
 412   (define-fp-operate divs #x16 #x083)
 413   (define-fp-operate divt #x16 #x0a3)
 414   (define-fp-operate muls #x16 #x082)
 415   (define-fp-operate mult #x16 #x0a2)
 416   (define-fp-operate subs #x16 #x081)
 417   (define-fp-operate subt #x16 #x0a1)
 418
 419 ;;; IEEE support
 420   (def!constant +su+   #x500)           ; software, underflow enabled
 421   (def!constant +sui+  #x700)           ; software, inexact & underflow enabled
 422   (def!constant +sv+   #x500)           ; software, interger overflow enabled
 423   (def!constant +svi+  #x700)
 424   (def!constant +rnd+  #x0c0)           ; dynamic rounding mode
 425   (def!constant +sud+  #x5c0)
 426   (def!constant +svid+ #x7c0)
 427   (def!constant +suid+ #x7c0)
 428
 429   (define-fp-operate cvtqs_su #x16 (logior +su+ #x0bc) 2)
 430   (define-fp-operate cvtqs_sui #x16 (logior +sui+ #x0bc) 2)
 431   (define-fp-operate cvtqt_su #x16 (logior +su+ #x0be) 2)
 432   (define-fp-operate cvtqt_sui #x16 (logior +sui+ #x0be) 2)
 433   (define-fp-operate cvtts_su #x16 (logior +su+ #x0ac) 2)
 434
 435   (define-fp-operate cvttq_sv #x16 (logior +su+ #x0af) 2)
 436   (define-fp-operate cvttq/c_sv #x16 (logior +su+ #x02f) 2)
 437
 438   (define-fp-operate adds_su #x16 (logior +su+ #x080))
 439   (define-fp-operate addt_su #x16 (logior +su+ #x0a0))
 440   (define-fp-operate divs_su #x16 (logior +su+ #x083))
 441   (define-fp-operate divt_su #x16 (logior +su+ #x0a3))
 442   (define-fp-operate muls_su #x16 (logior +su+ #x082))
 443   (define-fp-operate mult_su #x16 (logior +su+ #x0a2))
 444   (define-fp-operate subs_su #x16 (logior +su+ #x081))
 445   (define-fp-operate subt_su #x16 (logior +su+ #x0a1)))
 446
 447 (define-instruction  excb (segment)
 448   (:emitter (emit-lword segment #x63ff0400)))
 449
 450 (define-instruction trapb (segment)
 451   (:emitter (emit-lword segment #x63ff0000)))
 452
 453 (define-instruction imb (segment)
 454   (:emitter (emit-lword segment #x00000086)))
 455
 456 (define-instruction gentrap (segment code)
 457   (:printer call-pal ((palcode #xaa0000)))
 458   (:emitter
 459    (emit-lword segment #x000081)        ;actually bugchk
 460    (emit-lword segment code)))
 461
 462 (define-instruction-macro move (src dst)
 463   `(inst bis zero-tn ,src ,dst))
 464
 465 (define-instruction-macro not (src dst)
 466   `(inst ornot zero-tn ,src ,dst))
 467
 468 (define-instruction-macro fmove (src dst)
 469   `(inst cpys ,src ,src ,dst))
 470
 471 (define-instruction-macro fabs (src dst)
 472   `(inst cpys fp-single-zero-tn ,src ,dst))
 473
 474 (define-instruction-macro fneg (src dst)
 475   `(inst cpysn ,src ,src ,dst))
 476
 477 (define-instruction-macro nop ()
 478   `(inst bis zero-tn zero-tn zero-tn))
 479
 480 (defun %li (value reg)
 481   (etypecase value
 482     ((signed-byte 16)
 483      (inst lda reg value zero-tn))
 484     ((signed-byte 32)
 485      (flet ((se (x n)
 486               (let ((x (logand x (lognot (ash -1 n)))))
 487                 (if (logbitp (1- n) x)
 488                     (logior (ash -1 (1- n)) x)
 489                     x))))
 490        (let* ((value (se value 32))
 491               (low (ldb (byte 16 0) value))
 492               (tmp1 (- value (se low 16)))
 493               (high (ldb (byte 16 16) tmp1))
 494               (tmp2 (- tmp1 (se (ash high 16) 32)))
 495               (extra 0))
 496          (unless (= tmp2 0)
 497            (setf extra #x4000)
 498            (setf tmp1 (- tmp1 #x40000000))
 499            (setf high (ldb (byte 16 16) tmp1)))
 500          (inst lda reg low zero-tn)
 501          (unless (= extra 0)
 502            (inst ldah reg extra reg))
 503          (unless (= high 0)
 504            (inst ldah reg high reg)))))
 505     ((or (unsigned-byte 32) (signed-byte 64) (unsigned-byte 64))
 506      ;; Since it took NJF and CSR a good deal of puzzling to work out
 507      ;; (a) what a previous version of this was doing and (b) why it
 508      ;; was wrong:
 509      ;;
 510      ;; write VALUE = a_63 * 2^63 + a_48-62 * 2^48
 511      ;;               + a_47 * 2^47 + a_32-46 * 2^32
 512      ;;               + a_31 * 2^31 + a_16-30 * 2^16
 513      ;;               + a_15 * 2^15 + a_0-14
 514      ;;
 515      ;; then, because of the wonders of sign-extension and
 516      ;; twos-complement arithmetic modulo 2^64, if a_15 is set, LDA
 517      ;; (which sign-extends its argument) will add
 518      ;;
 519      ;;    (a_15 * 2^15 + a_0-14 - 65536).
 520      ;;
 521      ;; So we need to add that 65536 back on, which is what this
 522      ;; LOGBITP business is doing.  The same applies for bits 31 and
 523      ;; 47 (bit 63 is taken care of by the fact that all of this
 524      ;; arithmetic is mod 2^64 anyway), but we have to be careful that
 525      ;; we consider the altered value, not the original value.
 526      ;;
 527      ;; I think, anyway.  -- CSR, 2003-09-26
 528      (let* ((value1 (if (logbitp 15 value) (+ value (ash 1 16)) value))
 529             (value2 (if (logbitp 31 value1) (+ value1 (ash 1 32)) value1))
 530             (value3 (if (logbitp 47 value2) (+ value2 (ash 1 48)) value2)))
 531        (inst lda reg (ldb (byte 16 32) value2) zero-tn)
 532        ;; FIXME: Don't yet understand these conditionals.  If I'm
 533        ;; right, surely we can just consider the zeroness of the
 534        ;; particular bitfield, not the zeroness of the whole thing?
 535        ;; -- CSR, 2003-09-26
 536        (unless (= value3 0)
 537          (inst ldah reg (ldb (byte 16 48) value3) reg))
 538        (unless (and (= value2 0) (= value3 0))
 539          (inst sll reg 32 reg))
 540        (unless (= value 0)
 541          (inst lda reg (ldb (byte 16 0) value) reg))
 542        (unless (= value1 0)
 543          (inst ldah reg (ldb (byte 16 16) value1) reg))))
 544     (fixup
 545      (inst lda reg value zero-tn :bits-47-32)
 546      (inst ldah reg value reg :bits-63-48)
 547      (inst sll reg 32 reg)
 548      (inst lda reg value reg)
 549      (inst ldah reg value reg))))
 550
 551 (define-instruction-macro li (value reg)
 552   `(%li ,value ,reg))
 553
 554 \f
 555 ;;;;
 556
 557 (define-instruction lword (segment lword)
 558   (:declare (type (or (unsigned-byte 32) (signed-byte 32)) lword))
 559   (:cost 0)
 560   (:emitter
 561    (emit-lword segment lword)))
 562
 563 (define-instruction short (segment word)
 564   (:declare (type (or (unsigned-byte 16) (signed-byte 16)) word))
 565   (:cost 0)
 566   (:emitter
 567    (emit-word segment word)))
 568
 569 (define-instruction byte (segment byte)
 570   (:declare (type (or (unsigned-byte 8) (signed-byte 8)) byte))
 571   (:cost 0)
 572   (:emitter
 573    (emit-byte segment byte)))
 574
 575 (defun emit-header-data (segment type)
 576   (emit-back-patch
 577    segment 4
 578    (lambda (segment posn)
 579      (emit-lword segment
 580                  (logior type
 581                          (ash (+ posn (component-header-length))
 582                               (- n-widetag-bits word-shift)))))))
 583
 584 (define-instruction simple-fun-header-word (segment)
 585   (:cost 0)
 586   (:emitter
 587    (emit-header-data segment simple-fun-header-widetag)))
 588
 589 (define-instruction lra-header-word (segment)
 590   (:cost 0)
 591   (:emitter
 592    (emit-header-data segment return-pc-header-widetag)))
 593
 594 (defun emit-compute-inst (segment vop dst src label temp calc)
 595   (declare (ignore temp))
 596   (emit-chooser
 597    ;; We emit either 12 or 4 bytes, so we maintain 8 byte alignments.
 598    segment 12 3
 599    (lambda (segment posn delta-if-after)
 600      (let ((delta (funcall calc label posn delta-if-after)))
 601        (when (<= (- (ash 1 15)) delta (1- (ash 1 15)))
 602          (emit-back-patch segment 4
 603                           (lambda (segment posn)
 604                             (assemble (segment vop)
 605                                       (inst lda dst
 606                                             (funcall calc label posn 0)
 607                                             src))))
 608          t)))
 609    (lambda (segment posn)
 610      (assemble (segment vop)
 611                (flet ((se (x n)
 612                           (let ((x (logand x (lognot (ash -1 n)))))
 613                             (if (logbitp (1- n) x)
 614                                 (logior (ash -1 (1- n)) x)
 615                                 x))))
 616                  (let* ((value (se (funcall calc label posn 0) 32))
 617                         (low (ldb (byte 16 0) value))
 618                         (tmp1 (- value (se low 16)))
 619                         (high (ldb (byte 16 16) tmp1))
 620                         (tmp2 (- tmp1 (se (ash high 16) 32)))
 621                         (extra 0))
 622                    (unless (= tmp2 0)
 623                      (setf extra #x4000)
 624                      (setf tmp1 (- tmp1 #x40000000))
 625                      (setf high (ldb (byte 16 16) tmp1)))
 626                    (inst lda dst low src)
 627                    (inst ldah dst extra dst)
 628                    (inst ldah dst high dst)))))))
 629
 630 ;; code = lip - header - label-offset + other-pointer-tag
 631 (define-instruction compute-code-from-lip (segment dst src label temp)
 632   (:declare (type tn dst src temp) (type label label))
 633   (:vop-var vop)
 634   (:emitter
 635    (emit-compute-inst segment vop dst src label temp
 636                       (lambda (label posn delta-if-after)
 637                         (- other-pointer-lowtag
 638                            (label-position label posn delta-if-after)
 639                            (component-header-length))))))
 640
 641 ;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
 642 ;;      = lra - (header + label-offset)
 643 (define-instruction compute-code-from-lra (segment dst src label temp)
 644   (:declare (type tn dst src temp) (type label label))
 645   (:vop-var vop)
 646   (:emitter
 647    (emit-compute-inst segment vop dst src label temp
 648                       (lambda (label posn delta-if-after)
 649                         (- (+ (label-position label posn delta-if-after)
 650                               (component-header-length)))))))
 651
 652 ;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
 653 ;;     = code + header + label-offset
 654 (define-instruction compute-lra-from-code (segment dst src label temp)
 655   (:declare (type tn dst src temp) (type label label))
 656   (:vop-var vop)
 657   (:emitter
 658    (emit-compute-inst segment vop dst src label temp
 659                       (lambda (label posn delta-if-after)
 660                         (+ (label-position label posn delta-if-after)
 661                            (component-header-length))))))