src/compiler/alpha/insts.lisp

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