basis/bootstrap/assembler/arm.64.factor

   1 ! Copyright (C) 2020 Doug Coleman.
   2 ! Copyright (C) 2023 Giftpflanze.
   3 ! See https://factorcode.org/license.txt for BSD license.
   4 USING: bootstrap.image.private compiler.codegen.relocation
   5 compiler.constants compiler.units cpu.arm.64.assembler
   6 generic.single.private kernel kernel.private layouts
   7 locals.backend math math.private namespaces 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 ! X0-X17  volatile     scratch registers
  16 ! X0-X8                parameter registers
  17 ! X0                   result register
  18 ! X16-X17              intra-procedure-call registers
  19 ! X18-X29 non-volatile scratch registers
  20 ! X18                  platform register (TEB pointer under Windows)
  21 ! X29/FP               frame pointer
  22 ! X30/LR  non-volatile link register
  23
  24 : words ( n -- n ) 4 * ; inline
  25 : stack-frame-size ( -- n ) 8 bootstrap-cells ; inline
  26
  27 : return-reg ( -- reg ) X0 ; inline
  28 : arg1 ( -- reg ) X0 ; inline
  29 : arg2 ( -- reg ) X1 ; inline
  30 : arg3 ( -- reg ) X2 ; inline
  31 : arg4 ( -- reg ) X3 ; inline
  32
  33 : temp0 ( -- reg ) X9 ; inline
  34 : temp1 ( -- reg ) X10 ; inline
  35 : temp2 ( -- reg ) X11 ; inline
  36 : temp3 ( -- reg ) X12 ; inline
  37 : pic-tail-reg ( -- reg ) X12 ; inline
  38
  39 : stack-reg ( -- reg ) SP ; inline
  40 : link-reg ( -- reg ) X30 ; inline ! LR
  41 : stack-frame-reg ( -- reg ) X29 ; inline ! FP
  42 : vm-reg ( -- reg ) X28 ; inline
  43 : ds-reg ( -- reg ) X27 ; inline
  44 : rs-reg ( -- reg ) X26 ; inline
  45 : ctx-reg ( -- reg ) X25 ; inline
  46
  47 : push-link-reg ( -- ) -16 stack-reg link-reg STRpre ;
  48 : pop-link-reg ( -- ) 16 stack-reg link-reg LDRpost ;
  49
  50 : load0 ( -- ) 0 ds-reg temp0 LDRuoff ;
  51 : load1 ( -- ) -8 ds-reg temp1 LDUR ;
  52 : load2 ( -- ) -16 ds-reg temp2 LDUR ;
  53 : load1/0 ( -- ) -8 ds-reg temp0 temp1 LDPsoff ;
  54 : load2/1 ( -- ) -16 ds-reg temp1 temp2 LDPsoff ;
  55 : load2/1* ( -- ) -8 ds-reg temp1 temp2 LDPsoff ;
  56 : load3/2 ( -- ) -24 ds-reg temp2 temp3 LDPsoff ;
  57 : load-arg1/2 ( -- ) -8 ds-reg arg2 arg1 LDPsoff ;
  58
  59 : ndrop ( n -- ) bootstrap-cells ds-reg dup SUBi ;
  60
  61 : pop0 ( -- ) -8 ds-reg temp0 LDRpost ;
  62 : popr ( -- ) -8 rs-reg temp0 LDRpost ;
  63 : pop-arg1 ( -- ) -8 ds-reg arg1 LDRpost ;
  64 : pop-arg2 ( -- ) -8 ds-reg arg2 LDRpost ;
  65
  66 : push0 ( -- ) 8 ds-reg temp0 STRpre ;
  67 : push1 ( -- ) 8 ds-reg temp1 STRpre ;
  68 : push2 ( -- ) 8 ds-reg temp2 STRpre ;
  69 : push3 ( -- ) 8 ds-reg temp3 STRpre ;
  70 : pushr ( -- ) 8 rs-reg temp0 STRpre ;
  71 : push-arg2 ( -- ) 8 ds-reg arg2 STRpre ;
  72
  73 : push-down0 ( n -- ) neg bootstrap-cells ds-reg temp0 STRpre ;
  74 : push-down-arg3 ( -- ) -8 ds-reg arg3 STRpre ;
  75
  76 : store0 ( -- ) 0 ds-reg temp0 STRuoff ;
  77 : store1 ( -- ) 0 ds-reg temp1 STRuoff ;
  78 : store0/1 ( -- ) -8 ds-reg temp1 temp0 STPsoff ;
  79 : store0/2 ( -- ) -8 ds-reg temp2 temp0 STPsoff ;
  80 : store1/0 ( -- ) -8 ds-reg temp0 temp1 STPsoff ;
  81 : store1/2 ( -- ) -16 ds-reg temp2 temp1 STPsoff ;
  82
  83 :: tag ( reg -- ) tag-bits get reg reg LSLi ;
  84 :: untag ( reg -- ) tag-bits get reg reg ASRi ;
  85 : tagged>offset0 ( -- ) 1 temp0 temp0 ASRi ;
  86
  87 : >r ( -- ) pop0 pushr ;
  88 : r> ( -- ) popr push0 ;
  89
  90 : absolute-jump ( -- word class )
  91     2 words temp0 LDRl
  92     temp0 BR
  93     NOP NOP f rc-absolute-cell ; inline
  94
  95 : absolute-call ( -- word class )
  96     5 words temp0 LDRl
  97     push-link-reg
  98     temp0 BLR
  99     pop-link-reg
 100     3 words Br
 101     NOP NOP f rc-absolute-cell ; inline
 102
 103 [
 104     ! ! pic-tail-reg 5 [RIP+] LEA
 105     ! why do we store the address after JMP in EBX, where is it
 106     ! picked up?
 107     4 pic-tail-reg ADR
 108     ! ! 0 JMP f rc-relative rel-word-pic-tail
 109     ! 0 Br f rc-relative-arm64-branch rel-word-pic-tail
 110     absolute-jump rel-word-pic-tail
 111 ] JIT-WORD-JUMP jit-define
 112
 113 [
 114     ! ! 0 CALL f rc-relative rel-word-pic
 115     ! push-link-reg
 116     ! 0 BL f rc-relative-arm64-branch rel-word-pic
 117     ! pop-link-reg
 118     absolute-call rel-word-pic
 119 ] JIT-WORD-CALL jit-define
 120
 121 : jit-call ( name -- )
 122     ! RAX 0 MOV f rc-absolute-cell rel-dlsym
 123     ! RAX CALL ;
 124     absolute-call rel-dlsym ;
 125
 126 :: jit-call-1arg ( arg1s name -- )
 127     ! arg1 arg1s MOVr
 128     ! name jit-call ;
 129     arg1s arg1 MOVr
 130     name jit-call ;
 131
 132 :: jit-call-2arg ( arg1s arg2s name -- )
 133     ! arg1 arg1s MOV
 134     ! arg2 arg2s MOV
 135     ! name jit-call ;
 136     arg1s arg1 MOVr
 137     arg2s arg2 MOVr
 138     name jit-call ;
 139
 140 : jit-load-vm ( -- ) ;
 141
 142 : jit-load-context ( -- )
 143     ! ctx-reg vm-reg vm-context-offset [+] MOV ;
 144     vm-context-offset vm-reg ctx-reg LDRuoff ;
 145
 146 : jit-save-context ( -- )
 147     jit-load-context
 148     ! The reason for -8 I think is because we are anticipating a CALL
 149     ! instruction. After the call instruction, the contexts frame_top
 150     ! will point to the origin jump address.
 151     ! R11 RSP -8 [+] LEA
 152     ! ctx-reg context-callstack-top-offset [+] R11 MOV
 153     stack-reg temp0 MOVsp
 154     16 temp0 temp0 SUBi
 155     context-callstack-top-offset ctx-reg temp0 STRuoff
 156     ! ctx-reg context-datastack-offset [+] ds-reg MOV
 157     ! ctx-reg context-retainstack-offset [+] rs-reg MOV ;
 158     context-datastack-offset ctx-reg ds-reg STRuoff
 159     context-retainstack-offset ctx-reg rs-reg STRuoff ;
 160
 161 ! ctx-reg must already have been loaded
 162 : jit-restore-context ( -- )
 163     ! ds-reg ctx-reg context-datastack-offset [+] MOV
 164     ! rs-reg ctx-reg context-retainstack-offset [+] MOV ;
 165     context-datastack-offset ctx-reg ds-reg LDRuoff
 166     context-retainstack-offset ctx-reg rs-reg LDRuoff ;
 167
 168 [
 169     ! ! ctx-reg is preserved across the call because it is non-volatile
 170     ! ! in the C ABI
 171     jit-save-context
 172     ! ! call the primitive
 173     ! arg1 vm-reg MOV
 174     ! RAX 0 MOV f f rc-absolute-cell rel-dlsym
 175     ! RAX CALL
 176     vm-reg arg1 MOVr
 177     f jit-call
 178     jit-restore-context
 179 ] JIT-PRIMITIVE jit-define
 180
 181 : jit-jump-quot ( -- )
 182     ! arg1 quot-entry-point-offset [+] JMP ;
 183     quot-entry-point-offset arg1 temp0 LDUR
 184     temp0 BR ;
 185
 186 : jit-call-quot ( -- )
 187     ! arg1 quot-entry-point-offset [+] CALL ;
 188     push-link-reg
 189     quot-entry-point-offset arg1 temp0 LDUR
 190     temp0 BLR
 191     pop-link-reg ;
 192
 193 [
 194     ! temp2 0 MOV f rc-absolute-cell rel-literal
 195     ! temp1 temp2 CMP
 196     3 words temp2 LDRl
 197     temp2 temp1 CMPr
 198     3 words Br
 199     NOP NOP f rc-absolute-cell rel-literal
 200 ] PIC-CHECK-TUPLE jit-define
 201
 202 ! Inline cache miss entry points
 203 : jit-load-return-address ( -- )
 204     ! RBX RSP stack-frame-size bootstrap-cell - [+] MOV ;
 205     stack-frame-size bootstrap-cell - stack-reg arg1 LDRuoff ;
 206
 207 ! These are always in tail position with an existing stack
 208 ! frame, and the stack. The frame setup takes this into account.
 209 : jit-inline-cache-miss ( -- )
 210     jit-save-context
 211     ! arg1 RBX MOV
 212     ! arg2 vm-reg MOV
 213     vm-reg arg2 MOVr
 214     ! RAX 0 MOV rc-absolute-cell rel-inline-cache-miss
 215     ! RAX CALL
 216     absolute-call nip rel-inline-cache-miss
 217     jit-load-context
 218     jit-restore-context ;
 219
 220 [ jit-load-return-address jit-inline-cache-miss ] [
 221     ! RAX CALL
 222     push-link-reg
 223     temp0 BLR
 224     pop-link-reg
 225 ] [
 226     ! RAX JMP
 227     temp0 BR
 228 ] \ inline-cache-miss define-combinator-primitive
 229
 230 [ jit-inline-cache-miss ] [
 231     ! RAX CALL
 232     push-link-reg
 233     temp0 BLR
 234     pop-link-reg
 235 ] [
 236     ! RAX JMP
 237     temp0 BR
 238 ] \ inline-cache-miss-tail define-combinator-primitive
 239
 240 ! Contexts
 241 : jit-switch-context ( reg -- )
 242     ! ! Push a bogus return address so the GC can track this frame back
 243     ! ! to the owner
 244     ! 0 CALL
 245     0 BL ! ?!
 246
 247     ! ! Make the new context the current one
 248     ! ctx-reg swap MOV
 249     ! vm-reg vm-context-offset [+] ctx-reg MOV
 250     ctx-reg MOVr
 251     vm-context-offset vm-reg ctx-reg STRuoff
 252
 253     ! ! Load new stack pointer
 254     ! RSP ctx-reg context-callstack-top-offset [+] MOV
 255     context-callstack-top-offset ctx-reg temp0 LDRuoff
 256     temp0 stack-reg MOVsp
 257
 258     ! ! Load new ds, rs registers
 259     jit-restore-context
 260
 261     ctx-reg jit-update-tib ;
 262
 263 : jit-pop-context-and-param ( -- )
 264     ! arg1 ds-reg [] MOV
 265     ! arg1 arg1 alien-offset [+] MOV
 266     ! arg2 ds-reg -8 [+] MOV
 267     ! ds-reg 16 SUB ;
 268     pop-arg1
 269     alien-offset arg1 arg1 ADDi
 270     0 arg1 arg1 LDRuoff
 271     pop-arg2 ;
 272
 273 : jit-push-param ( -- )
 274     ! ds-reg 8 ADD
 275     ! ds-reg [] arg2 MOV ;
 276     push-arg2 ;
 277
 278 : jit-set-context ( -- )
 279     jit-pop-context-and-param
 280     jit-save-context
 281     arg1 jit-switch-context
 282     ! RSP 8 ADD
 283     16 stack-reg stack-reg ADDi
 284     jit-push-param ;
 285
 286 : jit-pop-quot-and-param ( -- )
 287     ! arg1 ds-reg [] MOV
 288     ! arg2 ds-reg -8 [+] MOV
 289     ! ds-reg 16 SUB ;
 290     pop-arg1 pop-arg2 ;
 291
 292 : jit-start-context ( -- )
 293     ! Create the new context in return-reg. Have to save context
 294     ! twice, first before calling new_context() which may GC,
 295     ! and again after popping the two parameters from the stack.
 296     jit-save-context
 297     vm-reg "new_context" jit-call-1arg
 298
 299     jit-pop-quot-and-param
 300     jit-save-context
 301     return-reg jit-switch-context
 302     jit-push-param
 303     jit-jump-quot ;
 304
 305 : jit-delete-current-context ( -- )
 306     vm-reg "delete_context" jit-call-1arg ;
 307
 308 ! Resets the active context and instead the passed in quotation
 309 ! becomes the new code that it executes.
 310 : jit-start-context-and-delete ( -- )
 311     ! Updates the context to match the values in the data and retain
 312     ! stack registers. reset_context can GC.
 313     jit-save-context
 314
 315     ! Resets the context. The top two ds items are preserved.
 316     vm-reg "reset_context" jit-call-1arg
 317
 318     ! Switches to the same context I think.
 319     ctx-reg jit-switch-context
 320
 321     ! Pops the quotation from the stack and puts it in arg1.
 322     ! arg1 ds-reg [] MOV
 323     ! ds-reg 8 SUB
 324     pop-arg1
 325
 326     ! Jump to quotation arg1
 327     jit-jump-quot ;
 328
 329 [
 330     ! 0 [RIP+] EAX MOV rc-relative rel-safepoint
 331     3 words temp0 LDRl
 332     0 temp0 W0 STRuoff
 333     3 words Br
 334     NOP NOP rc-absolute-cell rel-safepoint
 335 ] JIT-SAFEPOINT jit-define
 336
 337 ! C to Factor entry point
 338 [
 339     0xabcd BRK
 340     ! ! Optimizing compiler's side of callback accesses
 341     ! ! arguments that are on the stack via the frame pointer.
 342     ! ! On x86-32 fastcall, and x86-64, some arguments are passed
 343     ! ! in registers, and so the only registers that are safe for
 344     ! ! use here are frame-reg, nv-reg and vm-reg.
 345     ! frame-reg PUSH
 346     ! frame-reg stack-reg MOV
 347
 348     ! ! Save all non-volatile registers
 349     ! nv-regs [ PUSH ] each
 350     -16 SP X19 X18 STPpre
 351     -16 SP X21 X20 STPpre
 352     -16 SP X23 X22 STPpre
 353     -16 SP X25 X24 STPpre
 354     -16 SP X27 X26 STPpre
 355     -16 SP X29 X28 STPpre
 356     -16 SP X30 STRpre
 357     stack-reg stack-frame-reg MOVsp
 358
 359     jit-save-tib
 360
 361     ! ! Load VM into vm-reg
 362     ! vm-reg 0 MOV 0 rc-absolute-cell rel-vm
 363     2 words vm-reg LDRl
 364     3 words Br
 365     NOP NOP 0 rc-absolute-cell rel-vm
 366
 367     ! ! Save old context
 368     ! nv-reg vm-reg vm-context-offset [+] MOV
 369     ! nv-reg PUSH
 370     vm-context-offset vm-reg ctx-reg LDRuoff
 371     8 SP ctx-reg STRuoff
 372
 373     ! ! Switch over to the spare context
 374     ! nv-reg vm-reg vm-spare-context-offset [+] MOV
 375     ! vm-reg vm-context-offset [+] nv-reg MOV
 376     vm-spare-context-offset vm-reg ctx-reg LDRuoff
 377     vm-context-offset vm-reg ctx-reg STRuoff
 378
 379     ! ! Save C callstack pointer
 380     ! nv-reg context-callstack-save-offset [+] stack-reg MOV
 381
 382     stack-reg temp0 MOVsp
 383     context-callstack-save-offset ctx-reg temp0 STRuoff
 384     ! stack-reg X24 MOVsp
 385     ! NOP
 386
 387     ! ! Load Factor stack pointers
 388     ! stack-reg nv-reg context-callstack-bottom-offset [+] MOV
 389     context-callstack-bottom-offset ctx-reg temp0 LDRuoff
 390     temp0 stack-reg MOVsp
 391
 392     ctx-reg jit-update-tib
 393     jit-install-seh
 394
 395     ! rs-reg nv-reg context-retainstack-offset [+] MOV
 396     ! ds-reg nv-reg context-datastack-offset [+] MOV
 397     context-retainstack-offset ctx-reg rs-reg LDRuoff
 398     context-datastack-offset ctx-reg ds-reg LDRuoff
 399
 400     ! ! Call into Factor code
 401     ! link-reg 0 MOV f rc-absolute-cell rel-word
 402     ! link-reg CALL
 403     3 words temp0 LDRl
 404     temp0 BLR
 405     3 words Br
 406     NOP NOP f rc-absolute-cell rel-word
 407
 408     ! ! Load C callstack pointer
 409     ! nv-reg vm-reg vm-context-offset [+] MOV
 410     ! stack-reg nv-reg context-callstack-save-offset [+] MOV
 411     vm-context-offset vm-reg ctx-reg LDRuoff
 412
 413     context-callstack-save-offset ctx-reg temp0 LDRuoff
 414     temp0 stack-reg MOVsp
 415     ! X24 stack-reg MOVsp
 416     ! NOP
 417
 418     ! ! Load old context
 419     ! nv-reg POP
 420     ! vm-reg vm-context-offset [+] nv-reg MOV
 421     8 SP ctx-reg LDRuoff
 422     vm-context-offset vm-reg ctx-reg STRuoff
 423
 424     jit-restore-tib
 425
 426     ! ! Restore non-volatile registers
 427     ! nv-regs <reversed> [ POP ] each
 428     ! frame-reg POP
 429     16 SP X30 LDRpost
 430     16 SP X29 X28 LDPpost
 431     16 SP X27 X26 LDPpost
 432     16 SP X25 X24 LDPpost
 433     16 SP X23 X22 LDPpost
 434     16 SP X21 X20 LDPpost
 435     16 SP X19 X18 LDPpost
 436
 437     ! ! Callbacks which return structs, or use stdcall/fastcall/thiscall,
 438     ! ! need a parameter here.
 439
 440     ! ! See the comment for M\ x86.32 stack-cleanup in cpu.x86.32
 441     ! 0xffff RET f rc-absolute-2 rel-untagged
 442     4 words temp0 ADR
 443     2 temp0 temp0 LDRHuoff
 444     temp0 stack-reg stack-reg ADDr
 445     f RET
 446     NOP f rc-absolute-2 rel-untagged
 447 ] CALLBACK-STUB jit-define
 448
 449 [
 450     ! ! load literal
 451     ! temp0 0 MOV f rc-absolute-cell rel-literal
 452     2 words temp0 LDRl
 453     3 words Br
 454     NOP NOP f rc-absolute-cell rel-literal
 455     ! ! increment datastack pointer
 456     ! ds-reg bootstrap-cell ADD
 457     ! ! store literal on datastack
 458     ! ds-reg [] temp0 MOV
 459     push0
 460 ] JIT-PUSH-LITERAL jit-define
 461
 462 ! The *-signal-handler subprimitives are special-cased in vm/quotations.cpp
 463 ! not to trigger generation of a stack frame, so they can
 464 ! perform their own prolog/epilog preserving registers.
 465 !
 466 ! It is important that the total is 192/64 and that it matches the
 467 ! constants in vm/cpu-x86.*.hpp
 468 : jit-signal-handler-prolog ( -- )
 469     ! ! Return address already on stack -> 8/4 bytes.
 470
 471     ! ! Push all registers. 15 regs/120 bytes on 64bit, 7 regs/28 bytes
 472     ! ! on 32bit -> 128/32 bytes.
 473     ! signal-handler-save-regs [ PUSH ] each
 474
 475     ! ! Push flags -> 136/36 bytes
 476     ! PUSHF
 477     -16 SP X1 X0 STPpre
 478     -16 SP X3 X2 STPpre
 479     -16 SP X5 X4 STPpre
 480     -16 SP X7 X6 STPpre
 481     -16 SP X9 X8 STPpre
 482     -16 SP X11 X10 STPpre
 483     -16 SP X13 X12 STPpre
 484     -16 SP X15 X14 STPpre
 485     -16 SP X17 X16 STPpre
 486     -16 SP X19 X18 STPpre
 487     -16 SP X21 X20 STPpre
 488     -16 SP X23 X22 STPpre
 489     -16 SP X25 X24 STPpre
 490     -16 SP X27 X26 STPpre
 491     -16 SP X29 X28 STPpre
 492     NZCV X0 MRS
 493     -16 SP X0 X30 STPpre
 494
 495     ! ! Register parameter area 32 bytes, unused on platforms other than
 496     ! ! windows 64 bit, but including it doesn't hurt. Plus
 497     ! ! alignment. LEA used so we don't dirty flags -> 192/64 bytes.
 498     ! stack-reg stack-reg 7 bootstrap-cells neg [+] LEA
 499     4 bootstrap-cells stack-reg stack-reg SUBi
 500
 501     jit-load-vm ;
 502
 503 : jit-signal-handler-epilog ( -- )
 504     ! stack-reg stack-reg 7 bootstrap-cells [+] LEA
 505     ! POPF
 506     ! signal-handler-save-regs reverse [ POP ] each ;
 507     16 SP X0 X30 LDPpost
 508     NZCV X0 MSRr
 509     16 SP X29 X28 LDPpost
 510     16 SP X27 X26 LDPpost
 511     16 SP X25 X24 LDPpost
 512     16 SP X23 X22 LDPpost
 513     16 SP X21 X20 LDPpost
 514     16 SP X19 X18 LDPpost
 515     16 SP X17 X16 LDPpost
 516     16 SP X15 X14 LDPpost
 517     16 SP X13 X12 LDPpost
 518     16 SP X11 X10 LDPpost
 519     16 SP X9 X8 LDPpost
 520     16 SP X7 X6 LDPpost
 521     16 SP X5 X4 LDPpost
 522     16 SP X3 X2 LDPpost
 523     16 SP X1 X0 LDPpost ;
 524
 525 [
 526     ! ! load boolean
 527     ! temp0 ds-reg [] MOV
 528     ! ! pop boolean
 529     ! ds-reg bootstrap-cell SUB
 530     pop0
 531     ! ! compare boolean with f
 532     ! temp0 \ f type-number CMP
 533     \ f type-number temp0 CMPi
 534     ! ! jump to true branch if not equal
 535     ! ! 0 JNE f rc-relative rel-word
 536     ! 0 NE B.cond f rc-relative-arm64-bcond rel-word
 537     5 words EQ B.cond
 538     absolute-jump rel-word
 539     ! ! jump to false branch if equal
 540     ! ! 0 JMP f rc-relative rel-word
 541     ! 0 Br f rc-relative-arm64-branch rel-word
 542     absolute-jump rel-word
 543 ] JIT-IF jit-define
 544
 545 [
 546     >r
 547     ! ! 0 CALL f rc-relative rel-word
 548     ! push-link-reg
 549     ! 0 Br f rc-relative-arm64-branch rel-word
 550     ! pop-link-reg
 551     absolute-call rel-word
 552     r>
 553 ] JIT-DIP jit-define
 554
 555 [
 556     >r >r
 557     ! ! 0 CALL f rc-relative rel-word
 558     ! push-link-reg
 559     ! 0 Br f rc-relative-arm64-branch rel-word
 560     ! pop-link-reg
 561     absolute-call rel-word
 562     r> r>
 563 ] JIT-2DIP jit-define
 564
 565 [
 566     >r >r >r
 567     ! ! 0 CALL f rc-relative rel-word
 568     ! push-link-reg
 569     ! 0 Br f rc-relative-arm64-branch rel-word
 570     ! pop-link-reg
 571     absolute-call rel-word
 572     r> r> r>
 573 ] JIT-3DIP jit-define
 574
 575 [
 576     ! ! load from stack
 577     ! temp0 ds-reg [] MOV
 578     ! ! pop stack
 579     ! ds-reg bootstrap-cell SUB
 580     pop0
 581 ] [
 582     ! temp0 word-entry-point-offset [+] CALL
 583     push-link-reg
 584     temp0 BLR
 585     pop-link-reg
 586 ] [
 587     ! temp0 word-entry-point-offset [+] JMP
 588     temp0 BR
 589 ] \ (execute) define-combinator-primitive
 590
 591 [
 592     ! temp0 ds-reg [] MOV
 593     ! ds-reg bootstrap-cell SUB
 594     pop0
 595     ! temp0 word-entry-point-offset [+] JMP
 596     word-entry-point-offset temp0 temp0 ADDi
 597     temp0 BR
 598 ] JIT-EXECUTE jit-define
 599
 600 ! https://elixir.bootlin.com/linux/latest/source/arch/arm64/kernel/stacktrace.c#L22
 601 [
 602     ! ! make room for LR plus magic number of callback, 16byte align
 603     ! x64 ! stack-reg stack-frame-size bootstrap-cell - SUB
 604     stack-frame-size stack-reg stack-reg SUBi
 605     push-link-reg
 606 ] JIT-PROLOG jit-define
 607
 608 [
 609     ! x64 ! stack-reg stack-frame-size bootstrap-cell - ADD
 610     pop-link-reg
 611     stack-frame-size stack-reg stack-reg ADDi
 612 ] JIT-EPILOG jit-define
 613
 614 [ f RET ] JIT-RETURN jit-define
 615
 616 ! ! ! Polymorphic inline caches
 617
 618 ! The PIC stubs are not permitted to touch pic-tail-reg.
 619
 620 ! Load a value from a stack position
 621 [
 622     ! temp1 ds-reg 0x7f [+] MOV f rc-absolute-1 rel-untagged
 623     4 words temp2 ADR
 624     3 temp2 temp2 LDRBuoff
 625     temp2 ds-reg temp1 LDRr
 626     2 words Br
 627     NOP f rc-absolute-1 rel-untagged
 628 ] PIC-LOAD jit-define
 629
 630 [
 631     ! temp1/32 tag-mask get AND
 632     tag-mask get temp1 temp1 ANDi
 633 ] PIC-TAG jit-define
 634
 635 [
 636     ! temp0 temp1 MOV
 637     temp1 temp0 MOVr
 638     ! temp1/32 tag-mask get AND
 639     tag-mask get temp1 temp1 ANDi
 640     ! temp1/32 tuple type-number CMP
 641     tuple type-number temp1 CMPi
 642     ! [ JNE ]
 643     ! [ temp1 temp0 tuple-class-offset [+] MOV ]
 644     [ NE B.cond ] [
 645         tuple-class-offset temp0 temp1 LDUR
 646     ] jit-conditional
 647 ] PIC-TUPLE jit-define
 648
 649 [
 650     ! temp1/32 0x7f CMP f rc-absolute-1 rel-untagged
 651     4 words temp2 ADR
 652     3 temp2 temp2 LDRBuoff
 653     temp2 temp1 CMPr
 654     2 words Br
 655     NOP f rc-absolute-1 rel-untagged
 656 ] PIC-CHECK-TAG jit-define
 657
 658 [
 659     ! ! 0 JE f rc-relative rel-word
 660     ! 0 EQ B.cond f rc-relative-arm64-bcond rel-word
 661     5 words NE B.cond
 662     absolute-jump rel-word
 663 ] PIC-HIT jit-define
 664
 665 ! ! ! Megamorphic caches
 666
 667 [
 668     ! ! class = ...
 669     ! temp0 temp1 MOV
 670     temp1 temp0 MOVr
 671     ! temp1/32 tag-mask get AND
 672     tag-mask get temp1 temp1 ANDi
 673     ! temp1/32 tag-bits get SHL
 674     temp1 tag
 675     ! temp1/32 tuple type-number tag-fixnum CMP
 676     tuple type-number tag-fixnum temp1 CMPi
 677     ! [ JNE ]
 678     ! [ temp1 temp0 tuple-class-offset [+] MOV ]
 679     [ NE B.cond ] [
 680         tuple-class-offset temp0 temp1 LDUR
 681     ] jit-conditional
 682     ! ! cache = ...
 683     ! temp0 0 MOV f rc-absolute-cell rel-literal
 684     2 words temp0 LDRl
 685     3 words Br
 686     NOP NOP f rc-absolute-cell rel-literal
 687     ! ! key = hashcode(class)
 688     ! temp2 temp1 MOV
 689     temp1 temp2 MOVr
 690     ! ! key &= cache.length - 1
 691     ! temp2 mega-cache-size get 1 - bootstrap-cell * AND
 692     mega-cache-size get 1 - bootstrap-cells temp2 temp2 ANDi
 693     ! ! cache += array-start-offset
 694     ! temp0 array-start-offset ADD
 695     array-start-offset temp0 temp0 ADDi
 696     ! ! cache += key
 697     ! temp0 temp2 ADD
 698     temp2 temp0 temp0 ADDr
 699     ! ! if(get(cache) == class)
 700     ! temp0 [] temp1 CMP
 701     0 temp0 temp2 LDRuoff
 702     temp1 temp2 CMPr
 703     ! [ JNE ]
 704     [ NE B.cond ] [
 705         ! ! megamorphic_cache_hits++
 706         ! temp1 0 MOV rc-absolute-cell rel-megamorphic-cache-hits
 707         2 words temp1 LDRl
 708         3 words Br
 709         NOP NOP rc-absolute-cell rel-megamorphic-cache-hits
 710         ! temp1 [] 1 ADD
 711         1 temp3 MOVwi
 712         temp3 temp1 STADD
 713         ! ! goto get(cache + bootstrap-cell)
 714         ! temp0 temp0 bootstrap-cell [+] MOV
 715         bootstrap-cell temp0 temp0 LDRuoff
 716         ! temp0 word-entry-point-offset [+] JMP
 717         word-entry-point-offset temp0 temp0 ADDi
 718         temp0 BR
 719         ! ! fall-through on miss
 720     ] jit-conditional
 721 ] MEGA-LOOKUP jit-define
 722
 723 ! Comparisons
 724 : jit-compare ( cond -- )
 725     ! ! load t
 726     ! temp3 0 MOV t rc-absolute-cell rel-literal
 727     2 words temp3 LDRl
 728     3 words Br
 729     NOP NOP t rc-absolute-cell rel-literal
 730     ! ! load f
 731     ! temp1 \ f type-number MOV
 732     \ f type-number temp2 MOVwi
 733     ! ! load first value
 734     ! temp0 ds-reg [] MOV
 735     ! ! adjust stack pointer
 736     ! ds-reg bootstrap-cell SUB
 737     load1/0
 738     ! ! compare with second value
 739     ! ds-reg [] temp0 CMP
 740     temp1 temp0 CMPr
 741     ! ! move t if true
 742     ! [ temp1 temp3 ] dip execute( dst src -- )
 743     [ temp2 temp3 temp0 ] dip CSEL
 744     ! ! store
 745     ! ds-reg [] temp1 MOV
 746     1 push-down0 ;
 747
 748 ! Math
 749
 750 ! Overflowing fixnum arithmetic
 751 : jit-overflow ( insn func -- )
 752     ! ds-reg 8 SUB
 753     jit-save-context
 754     ! arg1 ds-reg [] MOV
 755     ! arg2 ds-reg 8 [+] MOV
 756     load-arg1/2
 757     ! arg3 arg1 MOV
 758     ! [ [ arg3 arg2 ] dip call ] dip
 759     [ [ arg2 arg1 arg3 ] dip call ] dip
 760     ! ds-reg [] arg3 MOV
 761     push-down-arg3
 762     ! [ JNO ]
 763     [ VC B.cond ] [
 764         ! arg3 vm-reg MOV
 765         vm-reg arg3 MOVr
 766         jit-call
 767     ] jit-conditional ; inline
 768
 769 : jit-math ( insn -- )
 770     ! ! load second input
 771     ! temp0 ds-reg [] MOV
 772     ! ! pop stack
 773     ! ds-reg bootstrap-cell SUB
 774     load1/0
 775     ! ! compute result
 776     ! [ ds-reg [] temp0 ] dip execute( dst src -- )
 777     [ temp0 temp1 temp0 ] dip execute( arg2 arg1 dst -- )
 778     1 push-down0 ;
 779
 780 : jit-fixnum-/mod ( -- )
 781     ! ! load second parameter
 782     ! temp1 ds-reg [] MOV
 783     ! ! load first parameter
 784     ! div-arg ds-reg bootstrap-cell neg [+] MOV
 785     load1/0
 786     ! ! divide
 787     temp0 temp1 temp2 SDIV
 788     temp1 temp0 temp2 temp0 MSUB ;
 789
 790 ! # All arm.64 subprimitives
 791 {
 792     ! ## Contexts
 793     { (set-context) [ jit-set-context ] }
 794     { (set-context-and-delete) [
 795         jit-delete-current-context
 796         jit-set-context
 797     ] }
 798     { (start-context) [ jit-start-context ] }
 799     { (start-context-and-delete) [ jit-start-context-and-delete ] }
 800
 801     ! ## Entry points
 802     { c-to-factor [
 803             arg1 arg2 MOVr
 804             vm-reg "begin_callback" jit-call-1arg
 805
 806             jit-call-quot
 807
 808             vm-reg "end_callback" jit-call-1arg
 809     ] }
 810     { unwind-native-frames [
 811         ! ! unwind-native-frames is marked as "special" in
 812         ! ! vm/quotations.cpp so it does not have a standard prolog
 813         ! ! Unwind stack frames
 814         ! RSP arg2 MOV
 815         arg2 stack-reg MOVsp
 816         ! ! Load VM pointer into vm-reg, since we're entering from
 817         ! ! C code
 818         ! vm-reg 0 MOV 0 rc-absolute-cell rel-vm
 819         2 words vm-reg LDRl
 820         3 words Br
 821         NOP NOP 0 rc-absolute-cell rel-vm
 822         ! ! Load ds and rs registers
 823         jit-load-context
 824         jit-restore-context
 825         ! ! Clear the fault flag
 826         ! vm-reg vm-fault-flag-offset [+] 0 MOV
 827         vm-fault-flag-offset vm-reg XZR STRuoff
 828         ! ! Call quotation
 829         jit-jump-quot
 830     ] }
 831
 832     ! ## Math
 833     { fixnum+ [ [ ADDr ] "overflow_fixnum_add" jit-overflow ] }
 834     { fixnum- [ [ SUBr ] "overflow_fixnum_subtract" jit-overflow ] }
 835     { fixnum* [
 836         ! ds-reg 8 SUB
 837         jit-save-context
 838         ! RCX ds-reg [] MOV
 839         ! RBX ds-reg 8 [+] MOV
 840         load1/0
 841         ! RBX tag-bits get SAR
 842         temp0 untag
 843         ! RAX RCX MOV
 844         ! RBX IMUL
 845         ! RAX * RBX = RDX:RAX
 846         temp1 temp0 temp0 MUL
 847         ! ds-reg [] RAX MOV
 848         1 push-down0
 849         ! [ JNO ]
 850         [ VC B.cond ] [
 851             ! arg1 RCX MOV
 852             temp1 arg1 MOVr
 853             ! arg1 tag-bits get SAR
 854             temp1 untag
 855             ! arg2 RBX MOV
 856             temp0 arg2 MOVr
 857             ! arg3 vm-reg MOV
 858             vm-reg arg3 MOVr
 859             "overflow_fixnum_multiply" jit-call
 860         ] jit-conditional
 861     ] }
 862
 863     ! ## Misc
 864     { fpu-state [
 865         ! RSP 2 SUB
 866         ! RSP [] FNSTCW
 867         ! FNINIT
 868         ! AX RSP [] MOV
 869         ! RSP 2 ADD
 870         FPSR XZR MSRr
 871         FPCR arg1 MRS
 872     ] }
 873     { set-fpu-state [
 874         ! RSP 2 SUB
 875         ! RSP [] arg1 16-bit-version-of MOV
 876         ! RSP [] FLDCW
 877         ! RSP 2 ADD
 878         FPCR arg1 MSRr
 879     ] }
 880     { set-callstack [
 881         ! ! Load callstack object
 882         ! arg4 ds-reg [] MOV
 883         ! ds-reg bootstrap-cell SUB
 884         pop0
 885         ! ! Get ctx->callstack_bottom
 886         jit-load-context
 887         ! arg1 ctx-reg context-callstack-bottom-offset [+] MOV
 888         context-callstack-bottom-offset ctx-reg arg1 LDRuoff
 889         ! ! Get top of callstack object -- 'src' for memcpy
 890         ! arg2 arg4 callstack-top-offset [+] LEA
 891         callstack-top-offset temp0 arg2 ADDi
 892         ! ! Get callstack length, in bytes --- 'len' for memcpy
 893         ! arg3 arg4 callstack-length-offset [+] MOV
 894         2 temp0 temp0 SUBi ! callstack-length-offset
 895         0 temp0 arg3 LDRuoff
 896         ! arg3 tag-bits get SHR
 897         tag-bits get arg3 arg3 LSRi
 898         ! ! Compute new stack pointer -- 'dst' for memcpy
 899         ! arg1 arg3 SUB
 900         arg3 arg1 arg1 SUBr
 901         ! ! Install new stack pointer
 902         ! RSP arg1 MOV
 903         arg1 stack-reg MOVsp
 904         ! ! Call memcpy; arguments are now in the correct registers
 905         ! ! Create register shadow area for Win64
 906         ! RSP 32 SUB
 907         32 stack-reg stack-reg SUBi
 908         "factor_memcpy" jit-call
 909         ! ! Tear down register shadow area
 910         ! RSP 32 ADD
 911         32 stack-reg stack-reg ADDi
 912         ! ! Return with new callstack
 913         ! 0 RET
 914         f RET
 915     ] }
 916
 917     ! ## Fixnums
 918
 919     ! ### Add
 920     { fixnum+fast [ \ ADDr jit-math ] }
 921
 922     ! ### Bit manipulation
 923     { fixnum-bitand [ \ ANDr jit-math ] }
 924     { fixnum-bitnot [
 925         ! ! complement
 926         ! ds-reg [] NOT
 927         load0
 928         temp0 temp0 MVN
 929         ! ! clear tag bits
 930         ! ds-reg [] tag-mask get XOR
 931         tag-mask get temp0 temp0 EORi
 932         store0
 933     ] }
 934     { fixnum-bitor [ \ ORRr jit-math ] }
 935     { fixnum-bitxor [ \ EORr jit-math ] }
 936     { fixnum-shift-fast [
 937         ! ! load shift count
 938         ! shift-arg ds-reg [] MOV
 939         ! ! adjust stack pointer
 940         ! ds-reg bootstrap-cell SUB
 941         ! ! load value
 942         ! temp3 ds-reg [] MOV
 943         load1/0
 944         ! ! untag shift count
 945         ! shift-arg tag-bits get SAR
 946         temp0 untag
 947         ! ! make a copy
 948         ! temp2 temp3 MOV
 949         temp1 temp2 MOVr
 950         ! ! compute positive shift value in temp2
 951         ! temp2 CL SHL
 952         temp0 temp1 temp1 LSLr
 953         ! ! compute negative shift value in temp3
 954         ! shift-arg NEG
 955         temp0 temp0 NEG
 956         ! temp3 CL SAR
 957         temp0 temp2 temp2 ASRr
 958         ! temp3 tag-mask get bitnot AND
 959         tag-mask get bitnot temp2 temp2 ANDi
 960         ! ! if shift count was negative, move temp3 to temp2
 961         ! shift-arg 0 CMP
 962         ! temp2 temp3 CMOVGE
 963         temp2 temp1 temp0 PL CSEL
 964         ! ! push to stack
 965         ! ds-reg [] temp2 MOV
 966         1 push-down0
 967     ] }
 968
 969     ! ### Comparisons
 970     { both-fixnums? [
 971         ! temp0 ds-reg [] MOV
 972         ! ds-reg bootstrap-cell SUB
 973         load1/0
 974         ! temp0 ds-reg [] OR
 975         temp1 temp0 temp0 ORRr
 976         ! temp0 tag-mask get TEST
 977         tag-mask get temp0 TSTi
 978         ! temp0 \ f type-number MOV
 979         \ f type-number temp0 MOVwi
 980         ! temp1 1 tag-fixnum MOV
 981         1 tag-fixnum temp1 MOVwi
 982         ! temp0 temp1 CMOVE
 983         temp0 temp1 temp0 EQ CSEL
 984         ! ds-reg [] temp0 MOV
 985         1 push-down0
 986     ] }
 987     { eq? [ EQ jit-compare ] }
 988     { fixnum> [ GT jit-compare ] }
 989     { fixnum>= [ GE jit-compare ] }
 990     { fixnum< [ LT jit-compare ] }
 991     { fixnum<= [ LE jit-compare ] }
 992
 993     ! ### Div/mod
 994     { fixnum-mod [
 995         jit-fixnum-/mod
 996         ! ! adjust stack pointer
 997         ! ds-reg bootstrap-cell SUB
 998         ! ! push to stack
 999         ! ds-reg [] mod-arg MOV
1000         1 push-down0
1001     ] }
1002     { fixnum/i-fast [
1003         jit-fixnum-/mod
1004         ! ! adjust stack pointer
1005         ! ds-reg bootstrap-cell SUB
1006         ! ! tag it
1007         ! div-arg tag-bits get SHL
1008         tag-bits get temp2 temp0 LSLi
1009         ! ! push to stack
1010         ! ds-reg [] div-arg MOV
1011         1 push-down0
1012     ] }
1013     { fixnum/mod-fast [
1014         jit-fixnum-/mod
1015         ! ! tag it
1016         ! div-arg tag-bits get SHL
1017         temp2 tag
1018         ! ! push to stack
1019         ! ds-reg [] mod-arg MOV
1020         ! ds-reg bootstrap-cell neg [+] div-arg MOV
1021         store0/2
1022     ] }
1023
1024     ! ### Mul
1025     { fixnum*fast [
1026         ! ! load second input
1027         ! temp0 ds-reg [] MOV
1028         ! ! pop stack
1029         ! ds-reg bootstrap-cell SUB
1030         ! ! load first input
1031         ! temp1 ds-reg [] MOV
1032         load1/0
1033         ! ! untag second input
1034         ! temp0 tag-bits get SAR
1035         temp0 untag
1036         ! ! multiply
1037         ! temp0 temp1 IMUL2
1038         temp1 temp0 temp0 MUL
1039         ! ! push result
1040         ! ds-reg [] temp0 MOV
1041         1 push-down0
1042     ] }
1043
1044     ! ### Sub
1045     { fixnum-fast [ \ SUBr jit-math ] }
1046
1047     ! ## Locals
1048     { drop-locals [
1049         ! ! load local count
1050         ! temp0 ds-reg [] MOV
1051         ! ! adjust stack pointer
1052         ! ds-reg bootstrap-cell SUB
1053         pop0
1054         ! ! turn local number into offset
1055         tagged>offset0
1056         ! ! decrement retain stack pointer
1057         ! rs-reg temp0 SUB
1058         temp0 rs-reg rs-reg SUBr
1059     ] }
1060     { get-local [
1061         ! ! load local number
1062         ! temp0 ds-reg [] MOV
1063         load0
1064         ! ! turn local number into offset
1065         tagged>offset0
1066         ! ! load local value
1067         ! temp0 rs-reg temp0 [+] MOV
1068         temp0 rs-reg temp0 LDRr
1069         ! ! push to stack
1070         ! ds-reg [] temp0 MOV
1071         store0
1072     ] }
1073     { load-local [ >r ] }
1074
1075     ! ## Objects
1076     { slot [
1077         ! ! load slot number
1078         ! temp0 ds-reg [] MOV
1079         ! ! adjust stack pointer
1080         ! ds-reg bootstrap-cell SUB
1081         ! ! load object
1082         ! temp1 ds-reg [] MOV
1083         load1/0
1084         ! ! turn slot number into offset
1085         tagged>offset0
1086         ! ! mask off tag
1087         ! temp1 tag-bits get SHR
1088         ! temp1 tag-bits get SHL
1089         tag-mask get bitnot temp1 temp1 ANDi
1090         ! ! load slot value
1091         ! temp0 temp1 temp0 [+] MOV
1092         temp1 temp0 temp0 LDRr
1093         ! ! push to stack
1094         ! ds-reg [] temp0 MOV
1095         1 push-down0
1096     ] }
1097     { string-nth-fast [
1098         ! ! load string index from stack
1099         ! temp0 ds-reg bootstrap-cell neg [+] MOV
1100         ! temp0 tag-bits get SHR
1101         ! ! load string from stack
1102         ! temp1 ds-reg [] MOV
1103         load1/0
1104         ! ! load character
1105         ! temp0 8-bit-version-of temp0 temp1 string-offset [++] MOV
1106         ! temp0 temp0 8-bit-version-of MOVZX
1107         ! temp0 tag-bits get SHL
1108         temp1 temp0 temp0 LDRBr
1109         temp0 tag
1110         ! ! store character to stack
1111         ! ds-reg bootstrap-cell SUB
1112         ! ds-reg [] temp0 MOV
1113         1 push-down0
1114     ] }
1115     { tag [
1116         ! ! load from stack
1117         ! temp0 ds-reg [] MOV
1118         load0
1119         ! ! compute tag
1120         ! temp0/32 tag-mask get AND
1121         tag-mask get temp0 temp0 ANDi
1122         ! ! tag the tag
1123         ! temp0/32 tag-bits get SHL
1124         temp0 tag
1125         ! ! push to stack
1126         ! ds-reg [] temp0 MOV
1127         store0
1128     ] }
1129
1130     ! ! ## Shufflers
1131
1132     ! ! ### Drops
1133     { drop [ 1 ndrop ] }
1134     { 2drop [ 2 ndrop ] }
1135     { 3drop [ 3 ndrop ] }
1136     { 4drop [ 4 ndrop ] }
1137
1138     ! ! ### Dups
1139     { dup [ load0 push0 ] }
1140     { 2dup [ load1/0 push1 push0 ] }
1141     { 3dup [ load2 load1/0 push2 push1 push0 ] }
1142     { 4dup [ load3/2 load1/0 push3 push2 push1 push0 ] }
1143     { dupd [ load1/0 store1 push0 ] }
1144
1145     ! ! ### Misc shufflers
1146     { over [ load1 push1 ] }
1147     { pick [ load2 push2 ] }
1148
1149     ! ! ### Nips
1150     { nip [ load0 1 push-down0 ] }
1151     { 2nip [ load0 2 push-down0 ] }
1152
1153     ! ! ### Swaps
1154     { -rot [ pop0 load2/1* store0/2 push1 ] }
1155     { rot [ pop0 load2/1* store1/0 push2 ] }
1156     { swap [ load1/0 store0/1 ] }
1157     { swapd [ load2/1 store1/2 ] }
1158
1159     ! ## Signal handling
1160     { leaf-signal-handler [
1161         jit-signal-handler-prolog
1162         jit-save-context
1163         ! temp0 vm-reg vm-signal-handler-addr-offset [+] MOV
1164         ! temp0 CALL
1165         vm-signal-handler-addr-offset vm-reg temp0 LDRuoff
1166         temp0 BLR
1167         jit-signal-handler-epilog
1168         ! Pop the fake leaf frame along with our return address
1169         ! leaf-stack-frame-size bootstrap-cell - RET
1170         leaf-stack-frame-size bootstrap-cell - SP SP ADDi
1171         f RET
1172     ] }
1173     { signal-handler [
1174         jit-signal-handler-prolog
1175         jit-save-context
1176         ! temp0 vm-reg vm-signal-handler-addr-offset [+] MOV
1177         ! temp0 CALL
1178         vm-signal-handler-addr-offset vm-reg temp0 LDRuoff
1179         temp0 BLR
1180         jit-signal-handler-epilog
1181         ! 0 RET
1182         f RET
1183     ] }
1184 } define-sub-primitives
1185
1186 [ "bootstrap.arm.64" forget-vocab ] with-compilation-unit