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