basis/cpu/x86/64/bootstrap.factor

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