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-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 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 cvtqs_sui #x16 (logior +sui+ #x0bc) 2)
 423   (define-fp-operate cvtqt_su #x16 (logior +su+ #x0be) 2)
 424   (define-fp-operate cvtqt_sui #x16 (logior +sui+ #x0be) 2)
 425   (define-fp-operate cvtts_su #x16 (logior +su+ #x0ac) 2)
 426
 427   (define-fp-operate cvttq_sv #x16 (logior +su+ #x0af) 2)
 428   (define-fp-operate cvttq/c_sv #x16 (logior +su+ #x02f) 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 imb (segment)
 446   (:emitter (emit-lword segment #x00000086)))
 447
 448 (define-instruction gentrap (segment code)
 449   (:printer call-pal ((palcode #xaa0000)))
 450   (:emitter
 451    (emit-lword segment #x000081)        ;actually bugchk
 452    (emit-lword segment code)))
 453
 454 (define-instruction-macro move (src dst)
 455   `(inst bis zero-tn ,src ,dst))
 456
 457 (define-instruction-macro not (src dst)
 458   `(inst ornot zero-tn ,src ,dst))
 459
 460 (define-instruction-macro fmove (src dst)
 461   `(inst cpys ,src ,src ,dst))
 462
 463 (define-instruction-macro fabs (src dst)
 464   `(inst cpys fp-single-zero-tn ,src ,dst))
 465
 466 (define-instruction-macro fneg (src dst)
 467   `(inst cpysn ,src ,src ,dst))
 468
 469 (define-instruction-macro nop ()
 470   `(inst bis zero-tn zero-tn zero-tn))
 471
 472 (defun %li (value reg)
 473   (etypecase value
 474     ((signed-byte 16)
 475      (inst lda reg value zero-tn))
 476     ((signed-byte 32)
 477      (flet ((se (x n)
 478               (let ((x (logand x (lognot (ash -1 n)))))
 479                 (if (logbitp (1- n) x)
 480                     (logior (ash -1 (1- n)) x)
 481                     x))))
 482        (let* ((value (se value 32))
 483               (low (ldb (byte 16 0) value))
 484               (tmp1 (- value (se low 16)))
 485               (high (ldb (byte 16 16) tmp1))
 486               (tmp2 (- tmp1 (se (ash high 16) 32)))
 487               (extra 0))
 488          (unless (= tmp2 0)
 489            (setf extra #x4000)
 490            (setf tmp1 (- tmp1 #x40000000))
 491            (setf high (ldb (byte 16 16) tmp1)))
 492          (inst lda reg low zero-tn)
 493          (unless (= extra 0)
 494            (inst ldah reg extra reg))
 495          (unless (= high 0)
 496            (inst ldah reg high reg)))))
 497     ((or (unsigned-byte 32) (signed-byte 64) (unsigned-byte 64))
 498      (let* ((value1 (if (logbitp 15 value) (+ value (ash 1 16)) value))
 499             (value2 (if (logbitp 31 value) (+ value (ash 1 32)) value1))
 500             (value3 (if (logbitp 47 value) (+ value (ash 1 48)) value2)))
 501        (inst lda reg (ldb (byte 16 32) value2) zero-tn)
 502        (unless (= value3 0)
 503          (inst ldah reg (ldb (byte 16 48) value3) reg))
 504        (unless (and (= value2 0) (= value3 0))
 505          (inst sll reg 32 reg))
 506        (unless (= value 0)
 507          (inst lda reg (ldb (byte 16 0) value) reg))
 508        (unless (= value1 0)
 509          (inst ldah reg (ldb (byte 16 16) value1) reg))))
 510     (fixup
 511      (inst lda reg value zero-tn :bits-47-32)
 512      (inst ldah reg value reg :bits-63-48)
 513      (inst sll reg 32 reg)
 514      (inst lda reg value reg)
 515      (inst ldah reg value reg))))
 516
 517 (define-instruction-macro li (value reg)
 518   `(%li ,value ,reg))
 519
 520 \f
 521 ;;;;
 522
 523 (define-instruction lword (segment lword)
 524   (:declare (type (or (unsigned-byte 32) (signed-byte 32)) lword))
 525   (:cost 0)
 526   (:emitter
 527    (emit-lword segment lword)))
 528
 529 (define-instruction short (segment word)
 530   (:declare (type (or (unsigned-byte 16) (signed-byte 16)) word))
 531   (:cost 0)
 532   (:emitter
 533    (emit-word segment word)))
 534
 535 (define-instruction byte (segment byte)
 536   (:declare (type (or (unsigned-byte 8) (signed-byte 8)) byte))
 537   (:cost 0)
 538   (:emitter
 539    (emit-byte segment byte)))
 540
 541 (defun emit-header-data (segment type)
 542   (emit-back-patch
 543    segment 4
 544    (lambda (segment posn)
 545      (emit-lword segment
 546                  (logior type
 547                          (ash (+ posn (component-header-length))
 548                               (- n-widetag-bits word-shift)))))))
 549
 550 (define-instruction simple-fun-header-word (segment)
 551   (:cost 0)
 552   (:emitter
 553    (emit-header-data segment simple-fun-header-widetag)))
 554
 555 (define-instruction lra-header-word (segment)
 556   (:cost 0)
 557   (:emitter
 558    (emit-header-data segment return-pc-header-widetag)))
 559
 560 (defun emit-compute-inst (segment vop dst src label temp calc)
 561   (declare (ignore temp))
 562   (emit-chooser
 563    ;; We emit either 12 or 4 bytes, so we maintain 8 byte alignments.
 564    segment 12 3
 565    (lambda (segment posn delta-if-after)
 566      (let ((delta (funcall calc label posn delta-if-after)))
 567        (when (<= (- (ash 1 15)) delta (1- (ash 1 15)))
 568          (emit-back-patch segment 4
 569                           (lambda (segment posn)
 570                             (assemble (segment vop)
 571                                       (inst lda dst
 572                                             (funcall calc label posn 0)
 573                                             src))))
 574          t)))
 575    (lambda (segment posn)
 576      (assemble (segment vop)
 577                (flet ((se (x n)
 578                           (let ((x (logand x (lognot (ash -1 n)))))
 579                             (if (logbitp (1- n) x)
 580                                 (logior (ash -1 (1- n)) x)
 581                                 x))))
 582                  (let* ((value (se (funcall calc label posn 0) 32))
 583                         (low (ldb (byte 16 0) value))
 584                         (tmp1 (- value (se low 16)))
 585                         (high (ldb (byte 16 16) tmp1))
 586                         (tmp2 (- tmp1 (se (ash high 16) 32)))
 587                         (extra 0))
 588                    (unless (= tmp2 0)
 589                      (setf extra #x4000)
 590                      (setf tmp1 (- tmp1 #x40000000))
 591                      (setf high (ldb (byte 16 16) tmp1)))
 592                    (inst lda dst low src)
 593                    (inst ldah dst extra dst)
 594                    (inst ldah dst high dst)))))))
 595
 596 ;; code = fn - header - label-offset + other-pointer-tag
 597 (define-instruction compute-code-from-fn (segment dst src label temp)
 598   (:declare (type tn dst src temp) (type label label))
 599   (:vop-var vop)
 600   (:emitter
 601    (emit-compute-inst segment vop dst src label temp
 602                       (lambda (label posn delta-if-after)
 603                         (- other-pointer-lowtag
 604                            (label-position label posn delta-if-after)
 605                            (component-header-length))))))
 606
 607 ;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
 608 ;;      = lra - (header + label-offset)
 609 (define-instruction compute-code-from-lra (segment dst src label temp)
 610   (:declare (type tn dst src temp) (type label label))
 611   (:vop-var vop)
 612   (:emitter
 613    (emit-compute-inst segment vop dst src label temp
 614                       (lambda (label posn delta-if-after)
 615                         (- (+ (label-position label posn delta-if-after)
 616                               (component-header-length)))))))
 617
 618 ;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
 619 (define-instruction compute-lra-from-code (segment dst src label temp)
 620   (:declare (type tn dst src temp) (type label label))
 621   (:vop-var vop)
 622   (:emitter
 623    (emit-compute-inst segment vop dst src label temp
 624                       (lambda (label posn delta-if-after)
 625                         (+ (label-position label posn delta-if-after)
 626                            (component-header-length))))))