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