basis/cpu/x86/64/bootstrap.factor

   1 ! Copyright (C) 2007, 2011 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: bootstrap.image.private kernel kernel.private namespaces
   4 system layouts vocabs parser compiler.constants
   5 compiler.codegen.relocation math math.private cpu.x86.assembler
   6 cpu.x86.assembler.operands sequences generic.single.private
   7 threads.private locals ;
   8 IN: bootstrap.x86
   9
  10 8 \ cell set
  11
  12 : shift-arg ( -- reg ) RCX ;
  13 : div-arg ( -- reg ) RAX ;
  14 : mod-arg ( -- reg ) RDX ;
  15 : temp0 ( -- reg ) RAX ;
  16 : temp1 ( -- reg ) RCX ;
  17 : temp2 ( -- reg ) RDX ;
  18 : temp3 ( -- reg ) RBX ;
  19 : pic-tail-reg ( -- reg ) RBX ;
  20 : return-reg ( -- reg ) RAX ;
  21 : nv-reg ( -- reg ) RBX ;
  22 : stack-reg ( -- reg ) RSP ;
  23 : frame-reg ( -- reg ) RBP ;
  24 : link-reg ( -- reg ) R11 ;
  25 : ctx-reg ( -- reg ) R12 ;
  26 : vm-reg ( -- reg ) R13 ;
  27 : ds-reg ( -- reg ) R14 ;
  28 : rs-reg ( -- reg ) R15 ;
  29 : fixnum>slot@ ( -- ) temp0 1 SAR ;
  30 : rex-length ( -- n ) 1 ;
  31
  32 : jit-call ( name -- )
  33     RAX 0 MOV f rc-absolute-cell rel-dlsym
  34     RAX CALL ;
  35
  36 [
  37     ! load entry point
  38     RAX 0 MOV rc-absolute-cell rel-this
  39     ! alignment
  40     RSP stack-frame-size bootstrap-cell - SUB
  41     ! store entry point
  42     RSP stack-frame-size 3 bootstrap-cells - [+] RAX MOV
  43     ! store stack frame size
  44     RSP stack-frame-size 2 bootstrap-cells - [+] stack-frame-size MOV
  45 ] jit-prolog jit-define
  46
  47 [
  48     pic-tail-reg 5 [RIP+] LEA
  49     0 JMP f rc-relative rel-word-pic-tail
  50 ] jit-word-jump jit-define
  51
  52 : jit-load-context ( -- )
  53     ctx-reg vm-reg vm-context-offset [+] MOV ;
  54
  55 : jit-save-context ( -- )
  56     jit-load-context
  57     R11 RSP -8 [+] LEA
  58     ctx-reg context-callstack-top-offset [+] R11 MOV
  59     ctx-reg context-datastack-offset [+] ds-reg MOV
  60     ctx-reg context-retainstack-offset [+] rs-reg MOV ;
  61
  62 : jit-restore-context ( -- )
  63     ds-reg ctx-reg context-datastack-offset [+] MOV
  64     rs-reg ctx-reg context-retainstack-offset [+] MOV ;
  65
  66 [
  67     ! ctx-reg is preserved across the call because it is non-volatile
  68     ! in the C ABI
  69     jit-save-context
  70     ! call the primitive
  71     arg1 vm-reg MOV
  72     RAX 0 MOV f f rc-absolute-cell rel-dlsym
  73     RAX CALL
  74     jit-restore-context
  75 ] jit-primitive jit-define
  76
  77 : jit-jump-quot ( -- ) arg1 quot-entry-point-offset [+] JMP ;
  78
  79 : jit-call-quot ( -- ) arg1 quot-entry-point-offset [+] CALL ;
  80
  81 [
  82     arg2 arg1 MOV
  83     arg1 vm-reg MOV
  84     "begin_callback" jit-call
  85
  86     ! call the quotation
  87     arg1 return-reg MOV
  88     jit-call-quot
  89
  90     arg1 vm-reg MOV
  91     "end_callback" jit-call
  92 ] \ c-to-factor define-sub-primitive
  93
  94 : signal-handler-save-regs ( -- regs )
  95     { RAX RCX RDX RBX RBP RSI RDI R8 R9 R10 R11 R12 R13 R14 R15 } ;
  96
  97 :: jit-signal-handler-prolog ( -- frame-size )
  98     signal-handler-save-regs :> save-regs
  99     save-regs length 1 + bootstrap-cells 16 align stack-frame-size + :> frame-size
 100     ! minus a cell each for flags, return address
 101     ! use LEA so we don't dirty flags
 102     RSP RSP frame-size 2 bootstrap-cells - neg [+] LEA
 103     save-regs [| r i | RSP i bootstrap-cells [+] r MOV ] each-index
 104     PUSHF
 105     ! Now that the registers are saved, we can make the stack frame
 106     RAX 0 MOV rc-absolute-cell rel-this
 107     RSP frame-size 3 bootstrap-cells - [+] RAX MOV
 108     RSP frame-size 2 bootstrap-cells - [+] frame-size MOV
 109     frame-size ;
 110
 111 :: jit-signal-handler-epilog ( frame-size -- )
 112     POPF
 113     signal-handler-save-regs
 114     [| r i | r RSP i bootstrap-cells [+] MOV ] each-index
 115     RSP RSP frame-size 2 bootstrap-cells - [+] LEA ;
 116
 117 [
 118     arg1 ds-reg [] MOV
 119     ds-reg bootstrap-cell SUB
 120 ]
 121 [ jit-call-quot ]
 122 [ jit-jump-quot ]
 123 \ (call) define-combinator-primitive
 124
 125 [
 126     ! Unwind stack frames
 127     RSP arg2 MOV
 128
 129     ! Load VM pointer into vm-reg, since we're entering from
 130     ! C code
 131     vm-reg 0 MOV 0 rc-absolute-cell rel-vm
 132
 133     ! Load ds and rs registers
 134     jit-load-context
 135     jit-restore-context
 136
 137     ! Clear the fault flag
 138     vm-reg vm-fault-flag-offset [+] 0 MOV
 139
 140     ! Call quotation
 141     jit-jump-quot
 142 ] \ unwind-native-frames define-sub-primitive
 143
 144 [
 145     RSP 2 SUB
 146     RSP [] FNSTCW
 147     FNINIT
 148     AX RSP [] MOV
 149     RSP 2 ADD
 150 ] \ fpu-state define-sub-primitive
 151
 152 [
 153     RSP 2 SUB
 154     RSP [] arg1 16-bit-version-of MOV
 155     RSP [] FLDCW
 156     RSP 2 ADD
 157 ] \ set-fpu-state define-sub-primitive
 158
 159 [
 160     ! Load callstack object
 161     arg4 ds-reg [] MOV
 162     ds-reg bootstrap-cell SUB
 163     ! Get ctx->callstack_bottom
 164     jit-load-context
 165     arg1 ctx-reg context-callstack-bottom-offset [+] MOV
 166     ! Get top of callstack object -- 'src' for memcpy
 167     arg2 arg4 callstack-top-offset [+] LEA
 168     ! Get callstack length, in bytes --- 'len' for memcpy
 169     arg3 arg4 callstack-length-offset [+] MOV
 170     arg3 tag-bits get SHR
 171     ! Compute new stack pointer -- 'dst' for memcpy
 172     arg1 arg3 SUB
 173     ! Install new stack pointer
 174     RSP arg1 MOV
 175     ! Call memcpy; arguments are now in the correct registers
 176     ! Create register shadow area for Win64
 177     RSP 32 SUB
 178     "factor_memcpy" jit-call
 179     ! Tear down register shadow area
 180     RSP 32 ADD
 181     ! Return with new callstack
 182     0 RET
 183 ] \ set-callstack define-sub-primitive
 184
 185 [
 186     jit-save-context
 187     arg2 vm-reg MOV
 188     "lazy_jit_compile" jit-call
 189     arg1 return-reg MOV
 190 ]
 191 [ return-reg quot-entry-point-offset [+] CALL ]
 192 [ jit-jump-quot ]
 193 \ lazy-jit-compile define-combinator-primitive
 194
 195 [
 196     temp2 0xffffffff MOV f rc-absolute-cell rel-literal
 197     temp1 temp2 CMP
 198 ] pic-check-tuple jit-define
 199
 200 ! Inline cache miss entry points
 201 : jit-load-return-address ( -- )
 202     RBX RSP stack-frame-size bootstrap-cell - [+] MOV ;
 203
 204 ! These are always in tail position with an existing stack
 205 ! frame, and the stack. The frame setup takes this into account.
 206 : jit-inline-cache-miss ( -- )
 207     jit-save-context
 208     arg1 RBX MOV
 209     arg2 vm-reg MOV
 210     RAX 0 MOV rc-absolute-cell rel-inline-cache-miss
 211     RAX CALL
 212     jit-load-context
 213     jit-restore-context ;
 214
 215 [ jit-load-return-address jit-inline-cache-miss ]
 216 [ RAX CALL ]
 217 [ RAX JMP ]
 218 \ inline-cache-miss define-combinator-primitive
 219
 220 [ jit-inline-cache-miss ]
 221 [ RAX CALL ]
 222 [ RAX JMP ]
 223 \ inline-cache-miss-tail define-combinator-primitive
 224
 225 ! Overflowing fixnum arithmetic
 226 : jit-overflow ( insn func -- )
 227     ds-reg 8 SUB
 228     jit-save-context
 229     arg1 ds-reg [] MOV
 230     arg2 ds-reg 8 [+] MOV
 231     arg3 arg1 MOV
 232     [ [ arg3 arg2 ] dip call ] dip
 233     ds-reg [] arg3 MOV
 234     [ JNO ]
 235     [ arg3 vm-reg MOV jit-call ]
 236     jit-conditional ; inline
 237
 238 [ [ ADD ] "overflow_fixnum_add" jit-overflow ] \ fixnum+ define-sub-primitive
 239
 240 [ [ SUB ] "overflow_fixnum_subtract" jit-overflow ] \ fixnum- define-sub-primitive
 241
 242 [
 243     ds-reg 8 SUB
 244     jit-save-context
 245     RCX ds-reg [] MOV
 246     RBX ds-reg 8 [+] MOV
 247     RBX tag-bits get SAR
 248     RAX RCX MOV
 249     RBX IMUL
 250     ds-reg [] RAX MOV
 251     [ JNO ]
 252     [
 253         arg1 RCX MOV
 254         arg1 tag-bits get SAR
 255         arg2 RBX MOV
 256         arg3 vm-reg MOV
 257         "overflow_fixnum_multiply" jit-call
 258     ]
 259     jit-conditional
 260 ] \ fixnum* define-sub-primitive
 261
 262 ! Contexts
 263 : jit-switch-context ( reg -- )
 264     ! Reset return value since its bogus right now, to avoid
 265     ! confusing the GC
 266     RSP -8 [+] 0 MOV
 267
 268     ! Make the new context the current one
 269     ctx-reg swap MOV
 270     vm-reg vm-context-offset [+] ctx-reg MOV
 271
 272     ! Load new stack pointer
 273     RSP ctx-reg context-callstack-top-offset [+] MOV
 274
 275     ! Load new ds, rs registers
 276     jit-restore-context
 277
 278     ctx-reg jit-update-tib ;
 279
 280 : jit-pop-context-and-param ( -- )
 281     arg1 ds-reg [] MOV
 282     arg1 arg1 alien-offset [+] MOV
 283     arg2 ds-reg -8 [+] MOV
 284     ds-reg 16 SUB ;
 285
 286 : jit-push-param ( -- )
 287     ds-reg 8 ADD
 288     ds-reg [] arg2 MOV ;
 289
 290 : jit-set-context ( -- )
 291     jit-pop-context-and-param
 292     jit-save-context
 293     arg1 jit-switch-context
 294     RSP 8 ADD
 295     jit-push-param ;
 296
 297 [ jit-set-context ] \ (set-context) define-sub-primitive
 298
 299 : jit-pop-quot-and-param ( -- )
 300     arg1 ds-reg [] MOV
 301     arg2 ds-reg -8 [+] MOV
 302     ds-reg 16 SUB ;
 303
 304 : jit-start-context ( -- )
 305     ! Create the new context in return-reg. Have to save context
 306     ! twice, first before calling new_context() which may GC,
 307     ! and again after popping the two parameters from the stack.
 308     jit-save-context
 309     arg1 vm-reg MOV
 310     "new_context" jit-call
 311
 312     jit-pop-quot-and-param
 313     jit-save-context
 314     return-reg jit-switch-context
 315     jit-push-param
 316     jit-jump-quot ;
 317
 318 [ jit-start-context ] \ (start-context) define-sub-primitive
 319
 320 : jit-delete-current-context ( -- )
 321     jit-load-context
 322     arg1 vm-reg MOV
 323     arg2 ctx-reg MOV
 324     "delete_context" jit-call ;
 325
 326 [
 327     jit-delete-current-context
 328     jit-set-context
 329 ] \ (set-context-and-delete) define-sub-primitive
 330
 331 : jit-start-context-and-delete ( -- )
 332     jit-load-context
 333     arg1 vm-reg MOV
 334     arg2 ctx-reg MOV
 335     "reset_context" jit-call
 336
 337     jit-pop-quot-and-param
 338     ctx-reg jit-switch-context
 339     jit-push-param
 340     jit-jump-quot ;
 341
 342 [
 343     0 [RIP+] EAX MOV rc-relative rel-safepoint
 344 ] \ jit-safepoint jit-define
 345
 346 [
 347     jit-start-context-and-delete
 348 ] \ (start-context-and-delete) define-sub-primitive