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      (assert (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-argument-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-argument-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-argument-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 ldl   #x28)
 203   (define-memory ldq   #x29)
 204   (define-memory ldl_l #x2a)
 205   (define-memory ldq_q #x2b)
 206   (define-memory ldq_u #x0b)
 207   (define-memory stl   #x2c)
 208   (define-memory stq   #x2d)
 209   (define-memory stl_c #x2e)
 210   (define-memory stq_c #x2f)
 211   (define-memory stq_u #x0f)
 212   (define-memory ldf   #x20 nil t)
 213   (define-memory ldg   #x21 nil t)
 214   (define-memory lds   #x22 nil t)
 215   (define-memory ldt   #x23 nil t)
 216   (define-memory stf   #x24 nil t)
 217   (define-memory stg   #x25 nil t)
 218   (define-memory sts   #x26 nil t)
 219   (define-memory stt   #x27 nil t))
 220
 221 (macrolet ((define-jump (name subop)
 222              `(define-instruction ,name (segment ra rb &optional (hint 0))
 223                 (:declare (type tn ra rb)
 224                           (type (or (unsigned-byte 14) fixup) hint))
 225                 (:printer jump ((op #x1a) (subop ,subop)))
 226                 (:emitter
 227                  (when (fixup-p hint)
 228                    (note-fixup segment :jmp-hint hint)
 229                    (setf hint 0))
 230                  (emit-memory segment #x1a (reg-tn-encoding ra) (reg-tn-encoding rb)
 231                               (logior (ash ,subop 14) hint))))))
 232   (define-jump jmp 0)
 233   (define-jump jsr 1)
 234   (define-jump ret 2)
 235   (define-jump jsr-coroutine 3))
 236
 237
 238 (macrolet ((define-branch (name op &optional (float nil))
 239              `(define-instruction ,name (segment ra target)
 240                 (:declare (type tn ra)
 241                           (type label target))
 242                 (:printer branch ((op ,op)
 243                                   ,@(when float
 244                                       '((ra nil :type 'fp-reg)))))
 245                 (:emitter
 246                  (emit-back-patch segment 4
 247                                   #'(lambda (segment posn)
 248                                       (emit-branch segment ,op
 249                                                    ,@(if float
 250                                                          '((fp-reg-tn-encoding ra))
 251                                                        '((reg-tn-encoding ra)))
 252                                                    (ash (- (label-position target)
 253                                                            (+ posn 4))
 254                                                         -2))))))))
 255   (define-branch br   #x30)
 256   (define-branch bsr  #x34)
 257   (define-branch blbc #x38)
 258   (define-branch blbs #x3c)
 259   (define-branch fbeq #x31 t)
 260   (define-branch fbne #x35 t)
 261   (define-branch beq  #x39)
 262   (define-branch bne  #x3d)
 263   (define-branch fblt #x32 t)
 264   (define-branch fbge #x36 t)
 265   (define-branch blt  #x3a)
 266   (define-branch bge  #x3e)
 267   (define-branch fble #x33 t)
 268   (define-branch fbgt #x37 t)
 269   (define-branch ble  #x3b)
 270   (define-branch bgt  #x3f))
 271
 272 (macrolet ((define-operate (name op fn)
 273              `(define-instruction ,name (segment ra rb rc)
 274                 (:declare (type tn ra rc)
 275                           (type (or tn (unsigned-byte 8)) rb))
 276                 (:printer reg-operate ((op ,op) (fn ,fn)))
 277                 (:printer lit-operate ((op ,op) (fn ,fn)))
 278                 ,@(when (and (= op #x11) (= fn #x20))
 279                     `((:printer reg-operate ((op ,op) (fn ,fn) (ra 31))
 280                                 '('move :tab rb "," rc))
 281                       (:printer reg-operate ((op ,op) (fn ,fn) (ra 31) (rb 31) (rc 31))
 282                                 '('nop))))
 283                 (:emitter
 284                  (etypecase rb
 285                    (tn
 286                     (emit-reg-operate segment ,op (reg-tn-encoding ra)
 287                                       (reg-tn-encoding rb) 0 0 ,fn (reg-tn-encoding rc)))
 288                    (number
 289                     (emit-lit-operate segment ,op (reg-tn-encoding ra) rb 1 ,fn
 290                                       (reg-tn-encoding rc))))))))
 291   (define-operate addl   #x10 #x00)
 292   (define-operate addl/v #x10 #x40)
 293   (define-operate addq   #x10 #x20)
 294   (define-operate addq/v #x10 #x60)
 295   (define-operate cmpule #x10 #x3d)
 296   (define-operate cmpbge #x10 #x0f)
 297   (define-operate subl   #x10 #x09)
 298   (define-operate subl/v #x10 #x49)
 299   (define-operate subq   #x10 #x29)
 300   (define-operate subq/v #x10 #x69)
 301   (define-operate cmpeq  #x10 #x2d)
 302   (define-operate cmplt  #x10 #x4d)
 303   (define-operate cmple  #x10 #x6d)
 304   (define-operate cmpult #x10 #x1d)
 305   (define-operate s4addl #x10 #x02)
 306   (define-operate s4addq #x10 #x22)
 307   (define-operate s4subl #x10 #x0b)
 308   (define-operate s4subq #x10 #x2b)
 309   (define-operate s8addl #x10 #x12)
 310   (define-operate s8addq #x10 #x32)
 311   (define-operate s8subl #x10 #x1b)
 312   (define-operate s8subq #x10 #x3b)
 313
 314   (define-operate and     #x11 #x00)
 315   (define-operate bic     #x11 #x08)
 316   (define-operate cmoveq  #x11 #x24)
 317   (define-operate cmovne  #x11 #x26)
 318   (define-operate cmovlbs #x11 #x14)
 319   (define-operate bis     #x11 #x20)
 320   (define-operate ornot   #x11 #x28)
 321   (define-operate cmovlt  #x11 #x44)
 322   (define-operate cmovge  #x11 #x46)
 323   (define-operate cmovlbc #x11 #x16)
 324   (define-operate xor     #x11 #x40)
 325   (define-operate eqv     #x11 #x48)
 326   (define-operate cmovle  #x11 #x64)
 327   (define-operate cmovgt  #x11 #x66)
 328
 329   (define-operate sll    #x12 #x39)
 330   (define-operate extbl  #x12 #x06)
 331   (define-operate extwl  #x12 #x16)
 332   (define-operate extll  #x12 #x26)
 333   (define-operate extql  #x12 #x36)
 334   (define-operate extwh  #x12 #x5a)
 335   (define-operate extlh  #x12 #x6a)
 336   (define-operate extqh  #x12 #x7a)
 337   (define-operate sra    #x12 #x3c)
 338   (define-operate insbl  #x12 #x0b)
 339   (define-operate inswl  #x12 #x1b)
 340   (define-operate insll  #x12 #x2b)
 341   (define-operate insql  #x12 #x3b)
 342   (define-operate inswh  #x12 #x57)
 343   (define-operate inslh  #x12 #x67)
 344   (define-operate insqh  #x12 #x77)
 345   (define-operate srl    #x12 #x34)
 346   (define-operate mskbl  #x12 #x02)
 347   (define-operate mskwl  #x12 #x12)
 348   (define-operate mskll  #x12 #x22)
 349   (define-operate mskql  #x12 #x32)
 350   (define-operate mskwh  #x12 #x52)
 351   (define-operate msklh  #x12 #x62)
 352   (define-operate mskqh  #x12 #x72)
 353   (define-operate zap    #x12 #x30)
 354   (define-operate zapnot #x12 #x31)
 355
 356   (define-operate mull   #x13 #x00)
 357   (define-operate mulq/v #x13 #x60)
 358   (define-operate mull/v #x13 #x40)
 359   (define-operate umulh  #x13 #x30)
 360   (define-operate mulq   #x13 #x20))
 361
 362
 363 (macrolet ((define-fp-operate (name op fn &optional (args 3))
 364              `(define-instruction ,name (segment ,@(when (= args 3) '(fa)) fb fc)
 365                 (:declare (type tn ,@(when (= args 3) '(fa)) fb fc))
 366                 (:printer fp-operate ((op ,op) (fn ,fn) ,@(when (= args 2) '((fa 31))))
 367                           ,@(when (= args 2)
 368                               '('(:name :tab fb "," fc))))
 369                 ,@(when (and (= op #x17) (= fn #x20))
 370                     `((:printer fp-operate ((op ,op) (fn ,fn) (fa 31))
 371                                 '('fabs :tab fb "," fc))))
 372                 (:emitter
 373                  (emit-fp-operate segment ,op ,@(if (= args 3)
 374                                                     '((fp-reg-tn-encoding fa))
 375                                                   '(31))
 376                                   (fp-reg-tn-encoding fb) ,fn (fp-reg-tn-encoding fc))))))
 377   (define-fp-operate cpys     #x17 #x020)
 378   (define-fp-operate mf_fpcr  #x17 #x025)
 379   (define-fp-operate cpysn    #x17 #x021)
 380   (define-fp-operate mt_fpcr  #x17 #x024)
 381   (define-fp-operate cpyse    #x17 #x022)
 382   (define-fp-operate cvtql/sv #x17 #x530 2)
 383   (define-fp-operate cvtlq    #x17 #x010 2)
 384   (define-fp-operate cvtql    #x17 #x030 2)
 385   (define-fp-operate cvtql/v  #x17 #x130 2)
 386   (define-fp-operate fcmoveq  #x17 #x02a)
 387   (define-fp-operate fcmovne  #x17 #x02b)
 388   (define-fp-operate fcmovlt  #x17 #x02c)
 389   (define-fp-operate fcmovge  #x17 #x02d)
 390   (define-fp-operate fcmovle  #x17 #x02e)
 391   (define-fp-operate fcmovgt  #x17 #x02f)
 392
 393   (define-fp-operate cvtqs #x16 #x0bc 2)
 394   (define-fp-operate cvtqt #x16 #x0be 2)
 395   (define-fp-operate cvtts #x16 #x0ac 2)
 396   (define-fp-operate cvttq #x16 #x0af 2)
 397   (define-fp-operate cvttq/c #x16 #x02f 2)
 398   (define-fp-operate cmpteq #x16 #x5a5)
 399   (define-fp-operate cmptlt #x16 #x5a6)
 400   (define-fp-operate cmptle #x16 #x5a7)
 401   (define-fp-operate cmptun #x16 #x5a4)
 402   (define-fp-operate adds #x16 #x080)
 403   (define-fp-operate addt #x16 #x0a0)
 404   (define-fp-operate divs #x16 #x083)
 405   (define-fp-operate divt #x16 #x0a3)
 406   (define-fp-operate muls #x16 #x082)
 407   (define-fp-operate mult #x16 #x0a2)
 408   (define-fp-operate subs #x16 #x081)
 409   (define-fp-operate subt #x16 #x0a1)
 410
 411 ;;; IEEE support
 412   (defconstant +su+   #x500)            ; software, underflow enabled
 413   (defconstant +sui+  #x700)            ; software, inexact & underflow enabled
 414   (defconstant +sv+   #x500)            ; software, interger overflow enabled
 415   (defconstant +svi+  #x700)
 416   (defconstant +rnd+  #x0c0)            ; dynamic rounding mode
 417   (defconstant +sud+  #x5c0)
 418   (defconstant +svid+ #x7c0)
 419   (defconstant +suid+ #x7c0)
 420
 421   (define-fp-operate cvtqs_su #x16 (logior +su+ #x0bc) 2)
 422   (define-fp-operate cvtqt_su #x16 (logior +su+ #x0be) 2)
 423   (define-fp-operate cvtts_su #x16 (logior +su+ #x0ac) 2)
 424
 425   (define-fp-operate adds_su #x16 (logior +su+ #x080))
 426   (define-fp-operate addt_su #x16 (logior +su+ #x0a0))
 427   (define-fp-operate divs_su #x16 (logior +su+ #x083))
 428   (define-fp-operate divt_su #x16 (logior +su+ #x0a3))
 429   (define-fp-operate muls_su #x16 (logior +su+ #x082))
 430   (define-fp-operate mult_su #x16 (logior +su+ #x0a2))
 431   (define-fp-operate subs_su #x16 (logior +su+ #x081))
 432   (define-fp-operate subt_su #x16 (logior +su+ #x0a1)))
 433
 434 (define-instruction  excb (segment)
 435   (:emitter (emit-lword segment #x63ff0400)))
 436
 437 (define-instruction trapb (segment)
 438   (:emitter (emit-lword segment #x63ff0000)))
 439
 440 (define-instruction gentrap (segment code)
 441   (:printer call-pal ((palcode #xaa0000)))
 442   (:emitter
 443    (emit-lword segment #x000081)        ;actually bugchk
 444    (emit-lword segment code)))
 445
 446 (define-instruction-macro move (src dst)
 447   `(inst bis zero-tn ,src ,dst))
 448
 449 (define-instruction-macro not (src dst)
 450   `(inst ornot zero-tn ,src ,dst))
 451
 452 (define-instruction-macro fmove (src dst)
 453   `(inst cpys ,src ,src ,dst))
 454
 455 (define-instruction-macro fabs (src dst)
 456   `(inst cpys fp-single-zero-tn ,src ,dst))
 457
 458 (define-instruction-macro fneg (src dst)
 459   `(inst cpysn ,src ,src ,dst))
 460
 461 (define-instruction-macro nop ()
 462   `(inst bis zero-tn zero-tn zero-tn))
 463
 464 (defun %li (value reg)
 465   (etypecase value
 466     ((signed-byte 16)
 467      (inst lda reg value zero-tn))
 468     ((signed-byte 32)
 469      (flet ((se (x n)
 470               (let ((x (logand x (lognot (ash -1 n)))))
 471                 (if (logbitp (1- n) x)
 472                     (logior (ash -1 (1- n)) x)
 473                     x))))
 474        (let* ((value (se value 32))
 475               (low (ldb (byte 16 0) value))
 476               (tmp1 (- value (se low 16)))
 477               (high (ldb (byte 16 16) tmp1))
 478               (tmp2 (- tmp1 (se (ash high 16) 32)))
 479               (extra 0))
 480          (unless (= tmp2 0)
 481            (setf extra #x4000)
 482            (setf tmp1 (- tmp1 #x40000000))
 483            (setf high (ldb (byte 16 16) tmp1)))
 484          (inst lda reg low zero-tn)
 485          (unless (= extra 0)
 486            (inst ldah reg extra reg))
 487          (unless (= high 0)
 488            (inst ldah reg high reg)))))
 489     ((or (unsigned-byte 32) (signed-byte 64) (unsigned-byte 64))
 490      (let* ((value1 (if (logbitp 15 value) (+ value (ash 1 16)) value))
 491             (value2 (if (logbitp 31 value) (+ value (ash 1 32)) value1))
 492             (value3 (if (logbitp 47 value) (+ value (ash 1 48)) value2)))
 493        (inst lda reg (ldb (byte 16 32) value2) zero-tn)
 494        (unless (= value3 0)
 495          (inst ldah reg (ldb (byte 16 48) value3) reg))
 496        (unless (and (= value2 0) (= value3 0))
 497          (inst sll reg 32 reg))
 498        (unless (= value 0)
 499          (inst lda reg (ldb (byte 16 0) value) reg))
 500        (unless (= value1 0)
 501          (inst ldah reg (ldb (byte 16 16) value1) reg))))
 502     (fixup
 503      (inst lda reg value zero-tn :bits-47-32)
 504      (inst ldah reg value reg :bits-63-48)
 505      (inst sll reg 32 reg)
 506      (inst lda reg value reg)
 507      (inst ldah reg value reg))))
 508
 509 (define-instruction-macro li (value reg)
 510   `(%li ,value ,reg))
 511
 512 \f
 513 ;;;;
 514
 515 (define-instruction lword (segment lword)
 516   (:declare (type (or (unsigned-byte 32) (signed-byte 32)) lword))
 517   (:cost 0)
 518   (:emitter
 519    (emit-lword segment lword)))
 520
 521 (define-instruction short (segment word)
 522   (:declare (type (or (unsigned-byte 16) (signed-byte 16)) word))
 523   (:cost 0)
 524   (:emitter
 525    (emit-word segment word)))
 526
 527 (define-instruction byte (segment byte)
 528   (:declare (type (or (unsigned-byte 8) (signed-byte 8)) byte))
 529   (:cost 0)
 530   (:emitter
 531    (emit-byte segment byte)))
 532
 533 (defun emit-header-data (segment type)
 534   (emit-back-patch
 535    segment 4
 536    #'(lambda (segment posn)
 537        (emit-lword segment
 538                   (logior type
 539                           (ash (+ posn (component-header-length))
 540                                (- n-widetag-bits word-shift)))))))
 541
 542 (define-instruction simple-fun-header-word (segment)
 543   (:cost 0)
 544   (:emitter
 545    (emit-header-data segment simple-fun-header-widetag)))
 546
 547 (define-instruction lra-header-word (segment)
 548   (:cost 0)
 549   (:emitter
 550    (emit-header-data segment return-pc-header-widetag)))
 551
 552 (defun emit-compute-inst (segment vop dst src label temp calc)
 553   (declare (ignore temp))
 554   (emit-chooser
 555    ;; We emit either 12 or 4 bytes, so we maintain 8 byte alignments.
 556    segment 12 3
 557    #'(lambda (segment posn delta-if-after)
 558        (let ((delta (funcall calc label posn delta-if-after)))
 559           (when (<= (- (ash 1 15)) delta (1- (ash 1 15)))
 560             (emit-back-patch segment 4
 561                              #'(lambda (segment posn)
 562                                  (assemble (segment vop)
 563                                            (inst lda dst
 564                                                  (funcall calc label posn 0)
 565                                                  src))))
 566             t)))
 567    #'(lambda (segment posn)
 568        (assemble (segment vop)
 569          (flet ((se (x n)
 570                   (let ((x (logand x (lognot (ash -1 n)))))
 571                     (if (logbitp (1- n) x)
 572                         (logior (ash -1 (1- n)) x)
 573                         x))))
 574            (let* ((value (se (funcall calc label posn 0) 32))
 575                   (low (ldb (byte 16 0) value))
 576                   (tmp1 (- value (se low 16)))
 577                   (high (ldb (byte 16 16) tmp1))
 578                   (tmp2 (- tmp1 (se (ash high 16) 32)))
 579                   (extra 0))
 580              (unless (= tmp2 0)
 581                (setf extra #x4000)
 582                (setf tmp1 (- tmp1 #x40000000))
 583                (setf high (ldb (byte 16 16) tmp1)))
 584              (inst lda dst low src)
 585              (inst ldah dst extra dst)
 586              (inst ldah dst high dst)))))))
 587
 588 ;; code = fn - header - label-offset + other-pointer-tag
 589 (define-instruction compute-code-from-fn (segment dst src label temp)
 590   (:declare (type tn dst src temp) (type label label))
 591   (:vop-var vop)
 592   (:emitter
 593    (emit-compute-inst segment vop dst src label temp
 594                       #'(lambda (label posn delta-if-after)
 595                           (- other-pointer-lowtag
 596                              (label-position label posn delta-if-after)
 597                              (component-header-length))))))
 598
 599 ;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
 600 ;;      = lra - (header + label-offset)
 601 (define-instruction compute-code-from-lra (segment dst src label temp)
 602   (:declare (type tn dst src temp) (type label label))
 603   (:vop-var vop)
 604   (:emitter
 605    (emit-compute-inst segment vop dst src label temp
 606                       #'(lambda (label posn delta-if-after)
 607                           (- (+ (label-position label posn delta-if-after)
 608                                 (component-header-length)))))))
 609
 610 ;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
 611 (define-instruction compute-lra-from-code (segment dst src label temp)
 612   (:declare (type tn dst src temp) (type label label))
 613   (:vop-var vop)
 614   (:emitter
 615    (emit-compute-inst segment vop dst src label temp
 616                       #'(lambda (label posn delta-if-after)
 617                           (+ (label-position label posn delta-if-after)
 618                              (component-header-length))))))