basis/bootstrap/assembler/arm.64.factor

   1 ! Copyright (C) 2020 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: bootstrap.image.private compiler.codegen.relocation
   4 compiler.constants compiler.units cpu.arm.assembler
   5 cpu.arm.assembler.opcodes generic.single.private
   6 kernel kernel.private layouts locals.backend
   7 math math.private memory namespaces sequences slots.private
   8 strings.private threads.private vocabs ;
   9 IN: bootstrap.assembler.arm
  10
  11 8 \ cell set
  12
  13 big-endian off
  14
  15 ! Stack frame
  16 ! https://docs.microsoft.com/en-us/cpp/build/arm64-exception-handling?view=vs-2019
  17
  18 ! x0    Volatile        Parameter/scratch register 1, result register
  19 ! x1-x7 Volatile        Parameter/scratch register 2-8
  20 ! x8-x15        Volatile        Scratch registers
  21 ! x16-x17       Volatile        Intra-procedure-call scratch registers
  22 ! x18   Non-volatile    Platform register: in kernel mode, points to KPCR for the current processor;
  23 !   in user mode, points to TEB
  24 ! x19-x28       Non-volatile    Scratch registers
  25 ! x29/fp        Non-volatile    Frame pointer
  26 ! x30/lr        Non-volatile    Link registers
  27
  28 : stack-frame-size ( -- n ) 4 bootstrap-cells ;
  29 : volatile-regs ( -- seq ) { X0 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 X14 X15 X16 X17 } ;
  30 : nv-regs ( -- seq ) { X18 X19 X20 X21 X22 X23 X24 X25 X26 X27 X28 X29 X30 } ;
  31
  32 ! callee-save = non-volatile aka call-preserved
  33
  34 ! x30 is the link register (used to return from subroutines)
  35 ! x29 is the frame register
  36 ! x19 to x29 are callee-saved
  37 ! x18 is the 'platform register', used for some operating-system-specific special purpose,
  38 !   or an additional caller-saved register
  39 ! x16 and x17 are the Intra-Procedure-call scratch register
  40 ! x9 to x15: used to hold local variables (caller saved)
  41 ! x8: used to hold indirect return value address
  42 ! x0 to x7: used to hold argument values passed to a subroutine, and also hold
  43 !   results returned from a subroutine
  44
  45
  46 ! https://en.wikichip.org/wiki/arm/aarch64
  47 ! Generally, X0 through X18 can corrupt while X19-X29 must be preserved
  48 ! Register   Role    Requirement
  49 ! X0 -  X7   Parameter/result registers   Can Corrupt
  50 ! X8         Indirect result location register
  51 ! X9 -  X15  Temporary registers
  52 ! X16 - X17  Intra-procedure call temporary
  53 ! X18        Platform register, otherwise temporary, DONT USE
  54
  55 ! X19 - X29    Callee-saved register    Must preserve
  56 ! X29 - frame pointer register, must always be valid
  57 ! X30    Link Register    Can Corrupt
  58 ! 16-byte stack alignment
  59
  60 : arg1 ( -- reg ) X0 ;
  61 : arg2 ( -- reg ) X1 ;
  62 : arg3 ( -- reg ) X2 ;
  63 : arg4 ( -- reg ) X3 ;
  64 : red-zone-size ( -- n ) 128 ;
  65
  66 : shift-arg ( -- reg ) X1 ;
  67 : div-arg ( -- reg ) X0 ;
  68 : mod-arg ( -- reg ) X2 ;
  69
  70 ! caller-saved registers X9-X15
  71 ! callee-saved registers X19-X29
  72 : temp0 ( -- reg ) X9 ;
  73 : temp1 ( -- reg ) X10 ;
  74 : temp2 ( -- reg ) X11 ;
  75 : temp3 ( -- reg ) X12 ;
  76
  77
  78
  79 ! : pic-tail-reg ( -- reg ) RBX ;
  80 : return-reg ( -- reg ) X0 ;
  81 : stack-reg ( -- reg ) SP ;
  82 ! https://developer.arm.com/documentation/dui0801/a/Overview-of-AArch64-state/Link-registers
  83 : link-reg ( -- reg ) X30 ; ! LR
  84 ! : stack-frame-reg ( -- reg ) X29 ; ! FP
  85 : vm-reg ( -- reg ) X28 ;
  86 : ds-reg ( -- reg ) X27 ;
  87 : rs-reg ( -- reg ) X26 ;
  88 ! : ctx-reg ( -- reg ) R12 ;
  89 ! : fixnum>slot@ ( -- ) temp0 1 SAR ;
  90 ! : rex-length ( -- n ) 1 ;
  91
  92 ! rc-absolute-cell is just CONSTANT: 0
  93 : jit-call ( name -- )
  94     0 X0 MOVwi64
  95     f rc-absolute-cell rel-dlsym
  96     X0 BLR ;
  97     ! RAX 0 MOV f rc-absolute-cell rel-dlsym
  98     ! RAX CALL ;
  99
 100 :: jit-call-1arg ( arg1s name -- )
 101     arg1s arg1 MOVr64
 102     name jit-call ;
 103     ! arg1 arg1s MOVr64
 104     ! name jit-call ;
 105
 106 :: jit-call-2arg ( arg1s arg2s name -- )
 107     arg1s arg1 MOVr64
 108     arg2s arg2 MOVr64
 109     name jit-call ;
 110     ! arg1 arg1s MOV
 111     ! arg2 arg2s MOV
 112     ! name jit-call ;
 113
 114 [
 115     ! pic-tail-reg 5 [RIP+] LEA
 116     ! 0 JMP f rc-relative rel-word-pic-tail
 117 ] JIT-WORD-JUMP jit-define
 118
 119 : jit-load-vm ( -- )
 120     ! no-op on x86-64. in factor contexts vm-reg always contains the
 121     ! vm pointer.
 122     ;
 123
 124 : jit-load-context ( -- ) ;
 125     ! ctx-reg vm-reg vm-context-offset [+] MOV ;
 126
 127 : jit-save-context ( -- ) ;
 128     ! jit-load-context
 129     ! The reason for -8 I think is because we are anticipating a CALL
 130     ! instruction. After the call instruction, the contexts frame_top
 131     ! will point to the origin jump address.
 132     ! R11 RSP -8 [+] LEA
 133     ! ctx-reg context-callstack-top-offset [+] R11 MOV
 134     ! ctx-reg context-datastack-offset [+] ds-reg MOV
 135     ! ctx-reg context-retainstack-offset [+] rs-reg MOV ;
 136
 137 ! ctx-reg must already have been loaded
 138 : jit-restore-context ( -- ) ;
 139     ! ds-reg ctx-reg context-datastack-offset [+] MOV
 140     ! rs-reg ctx-reg context-retainstack-offset [+] MOV ;
 141
 142
 143 [
 144     ! ! ctx-reg is preserved across the call because it is non-volatile
 145     ! ! in the C ABI
 146     ! jit-save-context
 147     ! ! call the primitive
 148     ! arg1 vm-reg MOV
 149     ! RAX 0 MOV f f rc-absolute-cell rel-dlsym
 150     ! RAX CALL
 151     ! jit-restore-context
 152 ] JIT-PRIMITIVE jit-define
 153
 154
 155 : jit-jump-quot ( -- )
 156     quot-entry-point-offset arg1 ADR
 157     arg1 BR ;
 158     ! arg1 quot-entry-point-offset [+] JMP ;
 159
 160 : jit-call-quot ( -- )
 161     quot-entry-point-offset arg1 ADR
 162     arg1 BLR ;
 163     ! arg1 quot-entry-point-offset [+] CALL ;
 164
 165 : signal-handler-save-regs ( -- regs ) { } ;
 166     ! { RAX RCX RDX RBX RBP RSI RDI R8 R9 R10 R11 R12 R13 R14 R15 } ;
 167
 168
 169 [
 170     ! temp2 0 MOV f rc-absolute-cell rel-literal
 171     ! temp1 temp2 CMP
 172 ] PIC-CHECK-TUPLE jit-define
 173
 174
 175
 176 : jit->r ( -- )
 177     1 bootstrap-cells rs-reg rs-reg ADDi64
 178     -1 bootstrap-cells ds-reg rs-reg LDR-post ;
 179
 180 : jit-r> ( -- )
 181     1 bootstrap-cells ds-reg ds-reg ADDi64
 182     -1 bootstrap-cells rs-reg ds-reg LDR-post ;
 183
 184 : jit-2>r ( -- )
 185     1 bootstrap-cells rs-reg rs-reg ADDi64
 186     -1 bootstrap-cells ds-reg rs-reg LDR-post
 187     1 bootstrap-cells rs-reg rs-reg ADDi64
 188     -1 bootstrap-cells ds-reg rs-reg LDR-post ;
 189
 190 : jit-2r> ( -- )
 191     1 bootstrap-cells ds-reg ds-reg ADDi64
 192     -1 bootstrap-cells rs-reg ds-reg LDR-post
 193     1 bootstrap-cells ds-reg ds-reg ADDi64
 194     -1 bootstrap-cells rs-reg ds-reg LDR-post ;
 195
 196 : jit-3>r ( -- )
 197     1 bootstrap-cells rs-reg rs-reg ADDi64
 198     -1 bootstrap-cells ds-reg rs-reg LDR-post
 199     1 bootstrap-cells rs-reg rs-reg ADDi64
 200     -1 bootstrap-cells ds-reg rs-reg LDR-post
 201     1 bootstrap-cells rs-reg rs-reg ADDi64
 202     -1 bootstrap-cells ds-reg rs-reg LDR-post ;
 203
 204 : jit-3r> ( -- )
 205     1 bootstrap-cells ds-reg ds-reg ADDi64
 206     -1 bootstrap-cells rs-reg ds-reg LDR-post
 207     1 bootstrap-cells ds-reg ds-reg ADDi64
 208     -1 bootstrap-cells rs-reg ds-reg LDR-post
 209     1 bootstrap-cells ds-reg ds-reg ADDi64
 210     -1 bootstrap-cells rs-reg ds-reg LDR-post ;
 211
 212 ! Contexts
 213 : jit-switch-context ( reg -- ) drop ;
 214     ! ! Push a bogus return address so the GC can track this frame back
 215     ! ! to the owner
 216     ! 0 CALL
 217
 218     ! ! Make the new context the current one
 219     ! ctx-reg swap MOV
 220     ! vm-reg vm-context-offset [+] ctx-reg MOV
 221
 222     ! ! Load new stack pointer
 223     ! RSP ctx-reg context-callstack-top-offset [+] MOV
 224
 225     ! ! Load new ds, rs registers
 226     ! jit-restore-context
 227
 228     ! ctx-reg jit-update-tib ;
 229
 230 : jit-pop-context-and-param ( -- ) ;
 231     ! arg1 ds-reg [] MOV
 232     ! arg1 arg1 alien-offset [+] MOV
 233     ! arg2 ds-reg -8 [+] MOV
 234     ! ds-reg 16 SUB ;
 235
 236 : jit-push-param ( -- ) ;
 237     ! ds-reg 8 ADD
 238     ! ds-reg [] arg2 MOV ;
 239
 240 : jit-set-context ( -- ) ;
 241     ! jit-pop-context-and-param
 242     ! jit-save-context
 243     ! arg1 jit-switch-context
 244     ! RSP 8 ADD
 245     ! jit-push-param ;
 246
 247 : jit-pop-quot-and-param ( -- ) ;
 248     ! arg1 ds-reg [] MOV
 249     ! arg2 ds-reg -8 [+] MOV
 250     ! ds-reg 16 SUB ;
 251
 252 : jit-start-context ( -- ) ;
 253     ! Create the new context in return-reg. Have to save context
 254     ! twice, first before calling new_context() which may GC,
 255     ! and again after popping the two parameters from the stack.
 256     ! jit-save-context
 257     ! vm-reg "new_context" jit-call-1arg
 258
 259     ! jit-pop-quot-and-param
 260     ! jit-save-context
 261     ! return-reg jit-switch-context
 262     ! jit-push-param
 263     ! jit-jump-quot ;
 264
 265 : jit-delete-current-context ( -- ) ;
 266     ! vm-reg "delete_context" jit-call-1arg ;
 267
 268 [
 269     ! jit->r
 270     ! 0 CALL f rc-relative rel-word
 271     ! jit-r>
 272 ] JIT-DIP jit-define
 273
 274
 275
 276
 277 [
 278     ! 0 [RIP+] EAX MOV rc-relative rel-safepoint
 279 ] JIT-SAFEPOINT jit-define
 280
 281 ! # All arm.64 subprimitives
 282 {
 283     { c-to-factor [
 284
 285             ! write()
 286             ! 68 X8 MOVwi64
 287             ! X2 MOVwi64
 288             ! 0 SVC
 289
 290             ! exit(42)
 291
 292             ! 9999 BRK
 293             ! 42 X0 MOVwi64
 294             ! 93 X8 MOVwi64
 295             ! 0 SVC
 296
 297             ! Rn Rd MOVr64 ! comment
 298             arg1 arg2 MOVr64
 299             vm-reg "begin_callback" jit-call-1arg
 300
 301             return-reg arg1 MOVr64 ! arg1 is return
 302             jit-call-quot
 303
 304             vm-reg "end_callback" jit-call-1arg
 305      ] }
 306 } define-sub-primitives
 307
 308
 309 ! {
 310     ! ## Contexts
 311     ! { (set-context) [ jit-set-context ] }
 312     ! { (set-context-and-delete) [
 313     !     jit-delete-current-context
 314     !     jit-set-context
 315     ! ] }
 316     ! { (start-context) [ jit-start-context ] }
 317     ! { (start-context-and-delete) [ jit-start-context-and-delete ] }
 318
 319     ! ## Entry points
 320     ! { c-to-factor [
 321     !     ! dst src MOV
 322     !     ! arg2 arg1 MOV
 323     !     ! vm-reg "begin_callback" jit-call-1arg
 324
 325     !     ! ! call the quotation
 326     !     ! arg1 return-reg MOV
 327     !     ! jit-call-quot
 328
 329     !     ! vm-reg "end_callback" jit-call-1arg
 330
 331     !     [
 332
 333     !         ! write()
 334     !         ! 68 X8 MOVwi64
 335     !         ! X2 MOVwi64
 336     !         ! 0 SVC
 337
 338     !         ! exit(42)
 339     !         9999 BRK
 340     !         42 X0 MOVwi64
 341     !         93 X8 MOVwi64
 342     !         0 SVC
 343
 344
 345
 346     !         ! Rn Rd MOVr64
 347     !         ! arg1 arg2 MOVr64
 348     !         ! vm-reg "begin_callback" jit-call-1arg
 349
 350     !         ! return-reg arg1 MOVr64 ! arg1 is return
 351     !         ! jit-call-quot
 352
 353     !         ! vm-reg "end_callback" jit-call-1arg
 354
 355     !     ] assemble-arm %
 356
 357     ! ] }
 358     ! { unwind-native-frames [ ] }
 359
 360     ! ## Math
 361     ! { fixnum+ [ [ ADD ] "overflow_fixnum_add" jit-overflow ] }
 362     ! { fixnum- [ [ SUB ] "overflow_fixnum_subtract" jit-overflow ] }
 363     ! { fixnum* [
 364     !     ds-reg 8 SUB
 365     !     jit-save-context
 366     !     RCX ds-reg [] MOV
 367     !     RBX ds-reg 8 [+] MOV
 368     !     RBX tag-bits get SAR
 369     !     RAX RCX MOV
 370     !     RBX IMUL
 371     !     ds-reg [] RAX MOV
 372     !     [ JNO ]
 373     !     [
 374     !         arg1 RCX MOV
 375     !         arg1 tag-bits get SAR
 376     !         arg2 RBX MOV
 377     !         arg3 vm-reg MOV
 378     !         "overflow_fixnum_multiply" jit-call
 379     !     ]
 380     !     jit-conditional
 381     ! ] }
 382
 383     ! ## Misc
 384     ! { fpu-state [
 385     !     RSP 2 SUB
 386     !     RSP [] FNSTCW
 387     !     FNINIT
 388     !     AX RSP [] MOV
 389     !     RSP 2 ADD
 390     ! ] }
 391     ! { set-fpu-state [
 392     !     RSP 2 SUB
 393     !     RSP [] arg1 16-bit-version-of MOV
 394     !     RSP [] FLDCW
 395     !     RSP 2 ADD
 396     ! ] }
 397     ! { set-callstack [
 398     !     ! Load callstack object
 399     !     arg4 ds-reg [] MOV
 400     !     ds-reg bootstrap-cell SUB
 401     !     ! Get ctx->callstack_bottom
 402     !     jit-load-context
 403     !     arg1 ctx-reg context-callstack-bottom-offset [+] MOV
 404     !     ! Get top of callstack object -- 'src' for memcpy
 405     !     arg2 arg4 callstack-top-offset [+] LEA
 406     !     ! Get callstack length, in bytes --- 'len' for memcpy
 407     !     arg3 arg4 callstack-length-offset [+] MOV
 408     !     arg3 tag-bits get SHR
 409     !     ! Compute new stack pointer -- 'dst' for memcpy
 410     !     arg1 arg3 SUB
 411     !     ! Install new stack pointer
 412     !     RSP arg1 MOV
 413     !     ! Call memcpy; arguments are now in the correct registers
 414     !     ! Create register shadow area for Win64
 415     !     RSP 32 SUB
 416     !     "factor_memcpy" jit-call
 417     !     ! Tear down register shadow area
 418     !     RSP 32 ADD
 419     !     ! Return with new callstack
 420     !     0 RET
 421     ! ] }
 422 ! } define-sub-primitives
 423
 424
 425
 426 ! C to Factor entry point
 427 [
 428     ! ! Optimizing compiler's side of callback accesses
 429     ! ! arguments that are on the stack via the frame pointer.
 430     ! ! On x86-32 fastcall, and x86-64, some arguments are passed
 431     ! ! in registers, and so the only registers that are safe for
 432     ! ! use here are frame-reg, nv-reg and vm-reg.
 433     ! frame-reg PUSH
 434     ! frame-reg stack-reg MOV
 435
 436     ! ! Save all non-volatile registers
 437     ! nv-regs [ PUSH ] each
 438
 439     ! jit-save-tib
 440
 441     ! ! Load VM into vm-reg
 442     ! vm-reg 0 MOV 0 rc-absolute-cell rel-vm
 443
 444     ! ! Save old context
 445     ! nv-reg vm-reg vm-context-offset [+] MOV
 446     ! nv-reg PUSH
 447
 448     ! ! Switch over to the spare context
 449     ! nv-reg vm-reg vm-spare-context-offset [+] MOV
 450     ! vm-reg vm-context-offset [+] nv-reg MOV
 451
 452     ! ! Save C callstack pointer
 453     ! nv-reg context-callstack-save-offset [+] stack-reg MOV
 454
 455     ! ! Load Factor stack pointers
 456     ! stack-reg nv-reg context-callstack-bottom-offset [+] MOV
 457     ! nv-reg jit-update-tib
 458     ! jit-install-seh
 459
 460     ! rs-reg nv-reg context-retainstack-offset [+] MOV
 461     ! ds-reg nv-reg context-datastack-offset [+] MOV
 462
 463     ! ! Call into Factor code
 464     ! link-reg 0 MOV f rc-absolute-cell rel-word
 465     ! link-reg CALL
 466
 467     ! ! Load VM into vm-reg; only needed on x86-32, but doesn't
 468     ! ! hurt on x86-64
 469     ! vm-reg 0 MOV 0 rc-absolute-cell rel-vm
 470
 471     ! ! Load C callstack pointer
 472     ! nv-reg vm-reg vm-context-offset [+] MOV
 473     ! stack-reg nv-reg context-callstack-save-offset [+] MOV
 474
 475     ! ! Load old context
 476     ! nv-reg POP
 477     ! vm-reg vm-context-offset [+] nv-reg MOV
 478
 479     ! ! Restore non-volatile registers
 480     ! jit-restore-tib
 481
 482     ! nv-regs <reversed> [ POP ] each
 483
 484     ! frame-reg POP
 485
 486     ! ! Callbacks which return structs, or use stdcall/fastcall/thiscall,
 487     ! ! need a parameter here.
 488
 489     ! ! See the comment for M\ x86.32 stack-cleanup in cpu.x86.32
 490     ! 0xffff RET f rc-absolute-2 rel-untagged
 491 ] CALLBACK-STUB jit-define
 492
 493 [
 494     ! ! load literal
 495     ! temp0 0 MOV f rc-absolute-cell rel-literal
 496     ! ! increment datastack pointer
 497     ! ds-reg bootstrap-cell ADD
 498     ! ! store literal on datastack
 499     ! ds-reg [] temp0 MOV
 500 ] JIT-PUSH-LITERAL jit-define
 501
 502 [
 503     ! 0 CALL f rc-relative rel-word-pic
 504 ] JIT-WORD-CALL jit-define
 505
 506 ! The *-signal-handler subprimitives are special-cased in vm/quotations.cpp
 507 ! not to trigger generation of a stack frame, so they can
 508 ! peform their own prolog/epilog preserving registers.
 509 !
 510 ! It is important that the total is 192/64 and that it matches the
 511 ! constants in vm/cpu-x86.*.hpp
 512 : jit-signal-handler-prolog ( -- ) ;
 513     ! ! Return address already on stack -> 8/4 bytes.
 514
 515     ! ! Push all registers. 15 regs/120 bytes on 64bit, 7 regs/28 bytes
 516     ! ! on 32bit -> 128/32 bytes.
 517     ! signal-handler-save-regs [ PUSH ] each
 518
 519     ! ! Push flags -> 136/36 bytes
 520     ! PUSHF
 521
 522     ! ! Register parameter area 32 bytes, unused on platforms other than
 523     ! ! windows 64 bit, but including it doesn't hurt. Plus
 524     ! ! alignment. LEA used so we don't dirty flags -> 192/64 bytes.
 525     ! stack-reg stack-reg 7 bootstrap-cells neg [+] LEA
 526
 527     ! jit-load-vm ;
 528
 529 : jit-signal-handler-epilog ( -- ) ;
 530     ! stack-reg stack-reg 7 bootstrap-cells [+] LEA
 531     ! POPF
 532     ! signal-handler-save-regs reverse [ POP ] each ;
 533
 534 [
 535     ! ! load boolean
 536     ! temp0 ds-reg [] MOV
 537     ! ! pop boolean
 538     ! ds-reg bootstrap-cell SUB
 539     ! ! compare boolean with f
 540     ! temp0 \ f type-number CMP
 541     ! ! jump to true branch if not equal
 542     ! 0 JNE f rc-relative rel-word
 543     ! ! jump to false branch if equal
 544     ! 0 JMP f rc-relative rel-word
 545 ] JIT-IF jit-define
 546
 547
 548 [
 549     ! jit->r
 550     ! 0 CALL f rc-relative rel-word
 551     ! jit-r>
 552 ] JIT-DIP jit-define
 553
 554 [
 555     ! jit-2>r
 556     ! 0 CALL f rc-relative rel-word
 557     ! jit-2r>
 558 ] JIT-2DIP jit-define
 559
 560 [
 561     ! jit-3>r
 562     ! 0 CALL f rc-relative rel-word
 563     ! jit-3r>
 564 ] JIT-3DIP jit-define
 565
 566 ! [
 567 !     ! load from stack
 568 !     temp0 ds-reg [] MOV
 569 !     ! pop stack
 570 !     ds-reg bootstrap-cell SUB
 571 ! ]
 572 ! [ temp0 word-entry-point-offset [+] CALL ]
 573 ! [ temp0 word-entry-point-offset [+] JMP ]
 574 ! \ (execute) define-combinator-primitive
 575
 576 [
 577     ! temp0 ds-reg [] MOV
 578     ! ds-reg bootstrap-cell SUB
 579     ! temp0 word-entry-point-offset [+] JMP
 580 ] JIT-EXECUTE jit-define
 581
 582 [
 583     ! stack-reg stack-framrcee-size bootstrap-cell - SUB
 584     stack-frame-size bootstrap-cell - stack-reg stack-reg SUBi64
 585 ] JIT-PROLOG jit-define
 586
 587 [
 588     ! stack-reg stack-frame-size bootstrap-cell - ADD
 589 ] JIT-EPILOG jit-define
 590
 591 [
 592     f RET
 593 ] JIT-RETURN jit-define
 594
 595 ! ! ! Polymorphic inline caches
 596
 597 ! The PIC stubs are not permitted to touch pic-tail-reg.
 598
 599 ! Load a value from a stack position
 600 [
 601     ! temp1 ds-reg 0x7f [+] MOV f rc-absolute-1 rel-untagged
 602 ] PIC-LOAD jit-define
 603
 604 [
 605     ! temp1/32 tag-mask get AND
 606 ] PIC-TAG jit-define
 607
 608 [
 609     ! temp0 temp1 MOV
 610     ! temp1/32 tag-mask get AND
 611     ! temp1/32 tuple type-number CMP
 612     ! [ JNE ]
 613     ! [ temp1 temp0 tuple-class-offset [+] MOV ]
 614     ! jit-conditional
 615 ] PIC-TUPLE jit-define
 616
 617 [
 618     ! temp1/32 0x7f CMP f rc-absolute-1 rel-untagged
 619 ] PIC-CHECK-TAG jit-define
 620
 621 [
 622     ! 0 JE f rc-relative rel-word
 623 ] PIC-HIT jit-define
 624
 625 ! ! ! Megamorphic caches
 626
 627 [
 628     ! ! class = ...
 629     ! temp0 temp1 MOV
 630     ! temp1/32 tag-mask get AND
 631     ! temp1/32 tag-bits get SHL
 632     ! temp1/32 tuple type-number tag-fixnum CMP
 633     ! [ JNE ]
 634     ! [ temp1 temp0 tuple-class-offset [+] MOV ]
 635     ! jit-conditional
 636     ! ! cache = ...
 637     ! temp0 0 MOV f rc-absolute-cell rel-literal
 638     ! ! key = hashcode(class)
 639     ! temp2 temp1 MOV
 640     ! bootstrap-cell 4 = [ temp2 1 SHR ] when
 641     ! ! key &= cache.length - 1
 642     ! temp2 mega-cache-size get 1 - bootstrap-cell * AND
 643     ! ! cache += array-start-offset
 644     ! temp0 array-start-offset ADD
 645     ! ! cache += key
 646     ! temp0 temp2 ADD
 647     ! ! if(get(cache) == class)
 648     ! temp0 [] temp1 CMP
 649     ! [ JNE ]
 650     ! [
 651     !     ! megamorphic_cache_hits++
 652     !     temp1 0 MOV rc-absolute-cell rel-megamorphic-cache-hits
 653     !     temp1 [] 1 ADD
 654     !     ! goto get(cache + bootstrap-cell)
 655     !     temp0 temp0 bootstrap-cell [+] MOV
 656     !     temp0 word-entry-point-offset [+] JMP
 657     !     ! fall-through on miss
 658     ! ] jit-conditional
 659 ] MEGA-LOOKUP jit-define
 660
 661 ! Comparisons
 662 : jit-compare ( insn -- ) drop ;
 663     ! ! load t
 664     ! temp3 0 MOV t rc-absolute-cell rel-literal
 665     ! ! load f
 666     ! temp1 \ f type-number MOV
 667     ! ! load first value
 668     ! temp0 ds-reg [] MOV
 669     ! ! adjust stack pointer
 670     ! ds-reg bootstrap-cell SUB
 671     ! ! compare with second value
 672     ! ds-reg [] temp0 CMP
 673     ! ! move t if true
 674     ! [ temp1 temp3 ] dip execute( dst src -- )
 675     ! ! store
 676     ! ds-reg [] temp1 MOV ;
 677
 678 ! Math
 679 : jit-math ( insn -- ) drop ;
 680     ! ! load second input
 681     ! temp0 ds-reg [] MOV
 682     ! ! pop stack
 683     ! ds-reg bootstrap-cell SUB
 684     ! ! compute result
 685     ! [ ds-reg [] temp0 ] dip execute( dst src -- ) ;
 686
 687 : jit-fixnum-/mod ( -- ) ;
 688     ! ! load second parameter
 689     ! temp1 ds-reg [] MOV
 690     ! ! load first parameter
 691     ! div-arg ds-reg bootstrap-cell neg [+] MOV
 692     ! ! make a copy
 693     ! mod-arg div-arg MOV
 694     ! ! sign-extend
 695     ! mod-arg bootstrap-cell-bits 1 - SAR
 696     ! ! divide
 697     ! temp1 IDIV ;
 698
 699 ! # Rest of arm64 subprimitives
 700 {
 701     ! ! ## Fixnums
 702
 703     ! ! ### Add
 704     ! { fixnum+fast [ \ ADD jit-math ] }
 705
 706     ! ! ### Bit stuff
 707     ! { fixnum-bitand [ \ AND jit-math ] }
 708     ! { fixnum-bitnot [
 709     !     ! complement
 710     !     ds-reg [] NOT
 711     !     ! clear tag bits
 712     !     ds-reg [] tag-mask get XOR
 713     ! ] }
 714     ! { fixnum-bitor [ \ OR jit-math ] }
 715     ! { fixnum-bitxor [ \ XOR jit-math ] }
 716     ! { fixnum-shift-fast [
 717     !     ! load shift count
 718     !     shift-arg ds-reg [] MOV
 719     !     ! untag shift count
 720     !     shift-arg tag-bits get SAR
 721     !     ! adjust stack pointer
 722     !     ds-reg bootstrap-cell SUB
 723     !     ! load value
 724     !     temp3 ds-reg [] MOV
 725     !     ! make a copy
 726     !     temp2 temp3 MOV
 727     !     ! compute positive shift value in temp2
 728     !     temp2 CL SHL
 729     !     shift-arg NEG
 730     !     ! compute negative shift value in temp3
 731     !     temp3 CL SAR
 732     !     temp3 tag-mask get bitnot AND
 733     !     shift-arg 0 CMP
 734     !     ! if shift count was negative, move temp0 to temp2
 735     !     temp2 temp3 CMOVGE
 736     !     ! push to stack
 737     !     ds-reg [] temp2 MOV
 738     ! ] }
 739
 740     ! ! ### Comparisons
 741     ! { both-fixnums? [
 742     !     temp0 ds-reg [] MOV
 743     !     ds-reg bootstrap-cell SUB
 744     !     temp0 ds-reg [] OR
 745     !     temp0 tag-mask get TEST
 746     !     temp0 \ f type-number MOV
 747     !     temp1 1 tag-fixnum MOV
 748     !     temp0 temp1 CMOVE
 749     !     ds-reg [] temp0 MOV
 750     ! ] }
 751     ! { eq? [ \ CMOVE jit-compare ] }
 752     ! { fixnum> [ \ CMOVG jit-compare ] }
 753     ! { fixnum>= [ \ CMOVGE jit-compare ] }
 754     ! { fixnum< [ \ CMOVL jit-compare ] }
 755     ! { fixnum<= [ \ CMOVLE jit-compare ] }
 756
 757     ! ! ### Div/mod
 758     ! { fixnum-mod [
 759     !     jit-fixnum-/mod
 760     !     ! adjust stack pointer
 761     !     ds-reg bootstrap-cell SUB
 762     !     ! push to stack
 763     !     ds-reg [] mod-arg MOV
 764     ! ] }
 765     ! { fixnum/i-fast [
 766     !     jit-fixnum-/mod
 767     !     ! adjust stack pointer
 768     !     ds-reg bootstrap-cell SUB
 769     !     ! tag it
 770     !     div-arg tag-bits get SHL
 771     !     ! push to stack
 772     !     ds-reg [] div-arg MOV
 773     ! ] }
 774     ! { fixnum/mod-fast [
 775     !     jit-fixnum-/mod
 776     !     ! tag it
 777     !     div-arg tag-bits get SHL
 778     !     ! push to stack
 779     !     ds-reg [] mod-arg MOV
 780     !     ds-reg bootstrap-cell neg [+] div-arg MOV
 781     ! ] }
 782
 783     ! ! ### Mul
 784     ! { fixnum*fast [
 785     !     ! load second input
 786     !     temp0 ds-reg [] MOV
 787     !     ! pop stack
 788     !     ds-reg bootstrap-cell SUB
 789     !     ! load first input
 790     !     temp1 ds-reg [] MOV
 791     !     ! untag second input
 792     !     temp0 tag-bits get SAR
 793     !     ! multiply
 794     !     temp0 temp1 IMUL2
 795     !     ! push result
 796     !     ds-reg [] temp0 MOV
 797     ! ] }
 798
 799     ! ! ### Sub
 800     ! { fixnum-fast [ \ SUB jit-math ] }
 801
 802     ! ! ## Locals
 803     ! { drop-locals [
 804     !     ! load local count
 805     !     temp0 ds-reg [] MOV
 806     !     ! adjust stack pointer
 807     !     ds-reg bootstrap-cell SUB
 808     !     ! turn local number into offset
 809     !     fixnum>slot@
 810     !     ! decrement retain stack pointer
 811     !     rs-reg temp0 SUB
 812     ! ] }
 813     ! { get-local [
 814     !     ! load local number
 815     !     temp0 ds-reg [] MOV
 816     !     ! turn local number into offset
 817     !     fixnum>slot@
 818     !     ! load local value
 819     !     temp0 rs-reg temp0 [+] MOV
 820     !     ! push to stack
 821     !     ds-reg [] temp0 MOV
 822     ! ] }
 823     ! { load-local [ jit->r ] }
 824
 825     ! ! ## Objects
 826     ! { slot [
 827     !     ! load slot number
 828     !     temp0 ds-reg [] MOV
 829     !     ! adjust stack pointer
 830     !     ds-reg bootstrap-cell SUB
 831     !     ! load object
 832     !     temp1 ds-reg [] MOV
 833     !     ! turn slot number into offset
 834     !     fixnum>slot@
 835     !     ! mask off tag
 836     !     temp1 tag-bits get SHR
 837     !     temp1 tag-bits get SHL
 838     !     ! load slot value
 839     !     temp0 temp1 temp0 [+] MOV
 840     !     ! push to stack
 841     !     ds-reg [] temp0 MOV
 842     ! ] }
 843     ! { string-nth-fast [
 844     !     ! load string index from stack
 845     !     temp0 ds-reg bootstrap-cell neg [+] MOV
 846     !     temp0 tag-bits get SHR
 847     !     ! load string from stack
 848     !     temp1 ds-reg [] MOV
 849     !     ! load character
 850     !     temp0 8-bit-version-of temp0 temp1 string-offset [++] MOV
 851     !     temp0 temp0 8-bit-version-of MOVZX
 852     !     temp0 tag-bits get SHL
 853     !     ! store character to stack
 854     !     ds-reg bootstrap-cell SUB
 855     !     ds-reg [] temp0 MOV
 856     ! ] }
 857     ! { tag [
 858     !     ! load from stack
 859     !     temp0 ds-reg [] MOV
 860     !     ! compute tag
 861     !     temp0/32 tag-mask get AND
 862     !     ! tag the tag
 863     !     temp0/32 tag-bits get SHL
 864     !     ! push to stack
 865     !     ds-reg [] temp0 MOV
 866     ! ] }
 867
 868     ! ! ## Shufflers
 869
 870     ! ! ### Drops
 871     ! { drop [ ds-reg bootstrap-cell SUB ] }
 872     ! { 2drop [ ds-reg 2 bootstrap-cells SUB ] }
 873     ! { 3drop [ ds-reg 3 bootstrap-cells SUB ] }
 874     ! { 4drop [ ds-reg 4 bootstrap-cells SUB ] }
 875
 876     ! ! ### Dups
 877     ! { dup [
 878     !     temp0 ds-reg [] MOV
 879     !     ds-reg bootstrap-cell ADD
 880     !     ds-reg [] temp0 MOV
 881     ! ] }
 882     ! { 2dup [
 883     !     temp0 ds-reg [] MOV
 884     !     temp1 ds-reg bootstrap-cell neg [+] MOV
 885     !     ds-reg 2 bootstrap-cells ADD
 886     !     ds-reg [] temp0 MOV
 887     !     ds-reg bootstrap-cell neg [+] temp1 MOV
 888     ! ] }
 889     ! { 3dup [
 890     !     temp0 ds-reg [] MOV
 891     !     temp1 ds-reg -1 bootstrap-cells [+] MOV
 892     !     temp3 ds-reg -2 bootstrap-cells [+] MOV
 893     !     ds-reg 3 bootstrap-cells ADD
 894     !     ds-reg [] temp0 MOV
 895     !     ds-reg -1 bootstrap-cells [+] temp1 MOV
 896     !     ds-reg -2 bootstrap-cells [+] temp3 MOV
 897     ! ] }
 898     ! { 4dup [
 899     !     temp0 ds-reg [] MOV
 900     !     temp1 ds-reg -1 bootstrap-cells [+] MOV
 901     !     temp2 ds-reg -2 bootstrap-cells [+] MOV
 902     !     temp3 ds-reg -3 bootstrap-cells [+] MOV
 903     !     ds-reg 4 bootstrap-cells ADD
 904     !     ds-reg [] temp0 MOV
 905     !     ds-reg -1 bootstrap-cells [+] temp1 MOV
 906     !     ds-reg -2 bootstrap-cells [+] temp2 MOV
 907     !     ds-reg -3 bootstrap-cells [+] temp3 MOV
 908     ! ] }
 909     ! { dupd [
 910     !     temp0 ds-reg [] MOV
 911     !     temp1 ds-reg -1 bootstrap-cells [+] MOV
 912     !     ds-reg [] temp1 MOV
 913     !     ds-reg bootstrap-cell ADD
 914     !     ds-reg [] temp0 MOV
 915     ! ] }
 916
 917     ! ! ### Misc shufflers
 918     ! { over [
 919     !     temp0 ds-reg -1 bootstrap-cells [+] MOV
 920     !     ds-reg bootstrap-cell ADD
 921     !     ds-reg [] temp0 MOV
 922     ! ] }
 923     ! { pick [
 924     !     temp0 ds-reg -2 bootstrap-cells [+] MOV
 925     !     ds-reg bootstrap-cell ADD
 926     !     ds-reg [] temp0 MOV
 927     ! ] }
 928
 929     ! ! ### Nips
 930     ! { nip [
 931     !     temp0 ds-reg [] MOV
 932     !     ds-reg bootstrap-cell SUB
 933     !     ds-reg [] temp0 MOV
 934     ! ] }
 935     ! { 2nip [
 936     !     temp0 ds-reg [] MOV
 937     !     ds-reg 2 bootstrap-cells SUB
 938     !     ds-reg [] temp0 MOV
 939     ! ] }
 940
 941     ! ! ### Swaps
 942     ! { -rot [
 943     !     temp0 ds-reg [] MOV
 944     !     temp1 ds-reg -1 bootstrap-cells [+] MOV
 945     !     temp3 ds-reg -2 bootstrap-cells [+] MOV
 946     !     ds-reg -2 bootstrap-cells [+] temp0 MOV
 947     !     ds-reg -1 bootstrap-cells [+] temp3 MOV
 948     !     ds-reg [] temp1 MOV
 949     ! ] }
 950     ! { rot [
 951     !     temp0 ds-reg [] MOV
 952     !     temp1 ds-reg -1 bootstrap-cells [+] MOV
 953     !     temp3 ds-reg -2 bootstrap-cells [+] MOV
 954     !     ds-reg -2 bootstrap-cells [+] temp1 MOV
 955     !     ds-reg -1 bootstrap-cells [+] temp0 MOV
 956     !     ds-reg [] temp3 MOV
 957     ! ] }
 958     ! { swap [
 959     !     temp0 ds-reg [] MOV
 960     !     temp1 ds-reg bootstrap-cell neg [+] MOV
 961     !     ds-reg bootstrap-cell neg [+] temp0 MOV
 962     !     ds-reg [] temp1 MOV
 963     ! ] }
 964     ! { swapd [
 965     !     temp0 ds-reg -1 bootstrap-cells [+] MOV
 966     !     temp1 ds-reg -2 bootstrap-cells [+] MOV
 967     !     ds-reg -2 bootstrap-cells [+] temp0 MOV
 968     !     ds-reg -1 bootstrap-cells [+] temp1 MOV
 969     ! ] }
 970
 971     ! ! ## Signal handling
 972     ! { leaf-signal-handler [
 973     !     jit-signal-handler-prolog
 974     !     jit-save-context
 975     !     temp0 vm-reg vm-signal-handler-addr-offset [+] MOV
 976     !     temp0 CALL
 977     !     jit-signal-handler-epilog
 978     !     ! Pop the fake leaf frame along with our return address
 979     !     leaf-stack-frame-size bootstrap-cell - RET
 980     ! ] }
 981     ! { signal-handler [
 982     !     jit-signal-handler-prolog
 983     !     jit-save-context
 984     !     temp0 vm-reg vm-signal-handler-addr-offset [+] MOV
 985     !     temp0 CALL
 986     !     jit-signal-handler-epilog
 987     !     0 RET
 988     ! ] }
 989 } define-sub-primitives
 990
 991 [ "bootstrap.arm.64" forget-vocab ] with-compilation-unit