basis/bootstrap/assembler/x86.64.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     pic-tail-reg 5 [RIP+] LEA
  38     0 JMP f rc-relative rel-word-pic-tail
  39 ] jit-word-jump jit-define
  40
  41 : jit-load-vm ( -- )
  42     ! no-op on x86-64. in factor contexts vm-reg always contains the
  43     ! vm pointer.
  44     ;
  45
  46 : jit-load-context ( -- )
  47     ctx-reg vm-reg vm-context-offset [+] MOV ;
  48
  49 : jit-save-context ( -- )
  50     jit-load-context
  51     R11 RSP -8 [+] LEA
  52     ctx-reg context-callstack-top-offset [+] R11 MOV
  53     ctx-reg context-datastack-offset [+] ds-reg MOV
  54     ctx-reg context-retainstack-offset [+] rs-reg MOV ;
  55
  56 : jit-restore-context ( -- )
  57     ds-reg ctx-reg context-datastack-offset [+] MOV
  58     rs-reg ctx-reg context-retainstack-offset [+] MOV ;
  59
  60 [
  61     ! ctx-reg is preserved across the call because it is non-volatile
  62     ! in the C ABI
  63     jit-save-context
  64     ! call the primitive
  65     arg1 vm-reg MOV
  66     RAX 0 MOV f f rc-absolute-cell rel-dlsym
  67     RAX CALL
  68     jit-restore-context
  69 ] jit-primitive jit-define
  70
  71 : jit-jump-quot ( -- ) arg1 quot-entry-point-offset [+] JMP ;
  72
  73 : jit-call-quot ( -- ) arg1 quot-entry-point-offset [+] CALL ;
  74
  75 [
  76     arg2 arg1 MOV
  77     arg1 vm-reg MOV
  78     "begin_callback" jit-call
  79
  80     ! call the quotation
  81     arg1 return-reg MOV
  82     jit-call-quot
  83
  84     arg1 vm-reg MOV
  85     "end_callback" jit-call
  86 ] \ c-to-factor define-sub-primitive
  87
  88 : signal-handler-save-regs ( -- regs )
  89     { RAX RCX RDX RBX RBP RSI RDI R8 R9 R10 R11 R12 R13 R14 R15 } ;
  90
  91 [
  92     arg1 ds-reg [] MOV
  93     ds-reg bootstrap-cell SUB
  94 ]
  95 [ jit-call-quot ]
  96 [ jit-jump-quot ]
  97 \ (call) define-combinator-primitive
  98
  99 [
 100     ! Unwind stack frames
 101     RSP arg2 MOV
 102
 103     ! Load VM pointer into vm-reg, since we're entering from
 104     ! C code
 105     vm-reg 0 MOV 0 rc-absolute-cell rel-vm
 106
 107     ! Load ds and rs registers
 108     jit-load-context
 109     jit-restore-context
 110
 111     ! Clear the fault flag
 112     vm-reg vm-fault-flag-offset [+] 0 MOV
 113
 114     ! Call quotation
 115     jit-jump-quot
 116 ] \ unwind-native-frames define-sub-primitive
 117
 118 [
 119     RSP 2 SUB
 120     RSP [] FNSTCW
 121     FNINIT
 122     AX RSP [] MOV
 123     RSP 2 ADD
 124 ] \ fpu-state define-sub-primitive
 125
 126 [
 127     RSP 2 SUB
 128     RSP [] arg1 16-bit-version-of MOV
 129     RSP [] FLDCW
 130     RSP 2 ADD
 131 ] \ set-fpu-state define-sub-primitive
 132
 133 [
 134     ! Load callstack object
 135     arg4 ds-reg [] MOV
 136     ds-reg bootstrap-cell SUB
 137     ! Get ctx->callstack_bottom
 138     jit-load-context
 139     arg1 ctx-reg context-callstack-bottom-offset [+] MOV
 140     ! Get top of callstack object -- 'src' for memcpy
 141     arg2 arg4 callstack-top-offset [+] LEA
 142     ! Get callstack length, in bytes --- 'len' for memcpy
 143     arg3 arg4 callstack-length-offset [+] MOV
 144     arg3 tag-bits get SHR
 145     ! Compute new stack pointer -- 'dst' for memcpy
 146     arg1 arg3 SUB
 147     ! Install new stack pointer
 148     RSP arg1 MOV
 149     ! Call memcpy; arguments are now in the correct registers
 150     ! Create register shadow area for Win64
 151     RSP 32 SUB
 152     "factor_memcpy" jit-call
 153     ! Tear down register shadow area
 154     RSP 32 ADD
 155     ! Return with new callstack
 156     0 RET
 157 ] \ set-callstack define-sub-primitive
 158
 159 [
 160     jit-save-context
 161     arg2 vm-reg MOV
 162     "lazy_jit_compile" jit-call
 163     arg1 return-reg MOV
 164 ]
 165 [ return-reg quot-entry-point-offset [+] CALL ]
 166 [ jit-jump-quot ]
 167 \ lazy-jit-compile define-combinator-primitive
 168
 169 [
 170     temp2 0xffffffff MOV f rc-absolute-cell rel-literal
 171     temp1 temp2 CMP
 172 ] pic-check-tuple jit-define
 173
 174 ! Inline cache miss entry points
 175 : jit-load-return-address ( -- )
 176     RBX RSP stack-frame-size bootstrap-cell - [+] MOV ;
 177
 178 ! These are always in tail position with an existing stack
 179 ! frame, and the stack. The frame setup takes this into account.
 180 : jit-inline-cache-miss ( -- )
 181     jit-save-context
 182     arg1 RBX MOV
 183     arg2 vm-reg MOV
 184     RAX 0 MOV rc-absolute-cell rel-inline-cache-miss
 185     RAX CALL
 186     jit-load-context
 187     jit-restore-context ;
 188
 189 [ jit-load-return-address jit-inline-cache-miss ]
 190 [ RAX CALL ]
 191 [ RAX JMP ]
 192 \ inline-cache-miss define-combinator-primitive
 193
 194 [ jit-inline-cache-miss ]
 195 [ RAX CALL ]
 196 [ RAX JMP ]
 197 \ inline-cache-miss-tail define-combinator-primitive
 198
 199 ! Overflowing fixnum arithmetic
 200 : jit-overflow ( insn func -- )
 201     ds-reg 8 SUB
 202     jit-save-context
 203     arg1 ds-reg [] MOV
 204     arg2 ds-reg 8 [+] MOV
 205     arg3 arg1 MOV
 206     [ [ arg3 arg2 ] dip call ] dip
 207     ds-reg [] arg3 MOV
 208     [ JNO ]
 209     [ arg3 vm-reg MOV jit-call ]
 210     jit-conditional ; inline
 211
 212 [ [ ADD ] "overflow_fixnum_add" jit-overflow ] \ fixnum+ define-sub-primitive
 213
 214 [ [ SUB ] "overflow_fixnum_subtract" jit-overflow ] \ fixnum- define-sub-primitive
 215
 216 [
 217     ds-reg 8 SUB
 218     jit-save-context
 219     RCX ds-reg [] MOV
 220     RBX ds-reg 8 [+] MOV
 221     RBX tag-bits get SAR
 222     RAX RCX MOV
 223     RBX IMUL
 224     ds-reg [] RAX MOV
 225     [ JNO ]
 226     [
 227         arg1 RCX MOV
 228         arg1 tag-bits get SAR
 229         arg2 RBX MOV
 230         arg3 vm-reg MOV
 231         "overflow_fixnum_multiply" jit-call
 232     ]
 233     jit-conditional
 234 ] \ fixnum* define-sub-primitive
 235
 236 ! Contexts
 237 : jit-switch-context ( reg -- )
 238     ! Push a bogus return address so the GC can track this frame back
 239     ! to the owner
 240     0 CALL
 241
 242     ! Make the new context the current one
 243     ctx-reg swap MOV
 244     vm-reg vm-context-offset [+] ctx-reg MOV
 245
 246     ! Load new stack pointer
 247     RSP ctx-reg context-callstack-top-offset [+] MOV
 248
 249     ! Load new ds, rs registers
 250     jit-restore-context
 251
 252     ctx-reg jit-update-tib ;
 253
 254 : jit-pop-context-and-param ( -- )
 255     arg1 ds-reg [] MOV
 256     arg1 arg1 alien-offset [+] MOV
 257     arg2 ds-reg -8 [+] MOV
 258     ds-reg 16 SUB ;
 259
 260 : jit-push-param ( -- )
 261     ds-reg 8 ADD
 262     ds-reg [] arg2 MOV ;
 263
 264 : jit-set-context ( -- )
 265     jit-pop-context-and-param
 266     jit-save-context
 267     arg1 jit-switch-context
 268     RSP 8 ADD
 269     jit-push-param ;
 270
 271 [ jit-set-context ] \ (set-context) define-sub-primitive
 272
 273 : jit-pop-quot-and-param ( -- )
 274     arg1 ds-reg [] MOV
 275     arg2 ds-reg -8 [+] MOV
 276     ds-reg 16 SUB ;
 277
 278 : jit-start-context ( -- )
 279     ! Create the new context in return-reg. Have to save context
 280     ! twice, first before calling new_context() which may GC,
 281     ! and again after popping the two parameters from the stack.
 282     jit-save-context
 283     arg1 vm-reg MOV
 284     "new_context" jit-call
 285
 286     jit-pop-quot-and-param
 287     jit-save-context
 288     return-reg jit-switch-context
 289     jit-push-param
 290     jit-jump-quot ;
 291
 292 [ jit-start-context ] \ (start-context) define-sub-primitive
 293
 294 : jit-delete-current-context ( -- )
 295     jit-load-context
 296     arg1 vm-reg MOV
 297     arg2 ctx-reg MOV
 298     "delete_context" jit-call ;
 299
 300 [
 301     jit-delete-current-context
 302     jit-set-context
 303 ] \ (set-context-and-delete) define-sub-primitive
 304
 305 : jit-start-context-and-delete ( -- )
 306     jit-load-context
 307     arg1 vm-reg MOV
 308     arg2 ctx-reg MOV
 309     "reset_context" jit-call
 310
 311     jit-pop-quot-and-param
 312     ctx-reg jit-switch-context
 313     jit-push-param
 314     jit-jump-quot ;
 315
 316 [
 317     0 [RIP+] EAX MOV rc-relative rel-safepoint
 318 ] \ jit-safepoint jit-define
 319
 320 [
 321     jit-start-context-and-delete
 322 ] \ (start-context-and-delete) define-sub-primitive