basis/cpu/x86/32/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 cpu.x86.assembler cpu.x86.assembler.operands layouts
   5 vocabs parser compiler.constants compiler.codegen.relocation
   6 sequences math math.private generic.single.private
   7 threads.private ;
   8 IN: bootstrap.x86
   9
  10 4 \ cell set
  11
  12 : stack-frame-size ( -- n ) 8 bootstrap-cells ;
  13 : shift-arg ( -- reg ) ECX ;
  14 : div-arg ( -- reg ) EAX ;
  15 : mod-arg ( -- reg ) EDX ;
  16 : temp0 ( -- reg ) EAX ;
  17 : temp1 ( -- reg ) ECX ;
  18 : temp2 ( -- reg ) EBX ;
  19 : temp3 ( -- reg ) EDX ;
  20 : pic-tail-reg ( -- reg ) EDX ;
  21 : stack-reg ( -- reg ) ESP ;
  22 : frame-reg ( -- reg ) EBP ;
  23 : vm-reg ( -- reg ) EBX ;
  24 : ctx-reg ( -- reg ) EBP ;
  25 : nv-regs ( -- seq ) { ESI EDI EBX } ;
  26 : nv-reg ( -- reg ) ESI ;
  27 : ds-reg ( -- reg ) ESI ;
  28 : rs-reg ( -- reg ) EDI ;
  29 : link-reg ( -- reg ) EBX ;
  30 : fixnum>slot@ ( -- ) temp0 2 SAR ;
  31 : rex-length ( -- n ) 0 ;
  32
  33 : jit-call ( name -- )
  34     0 CALL f rc-relative rel-dlsym ;
  35
  36 [
  37     ! save stack frame size
  38     stack-frame-size PUSH
  39     ! push entry point
  40     0 PUSH rc-absolute-cell rel-this
  41     ! alignment
  42     ESP stack-frame-size 3 bootstrap-cells - SUB
  43 ] jit-prolog jit-define
  44
  45 [
  46     pic-tail-reg 0 MOV 0 rc-absolute-cell rel-here
  47     0 JMP f rc-relative rel-word-pic-tail
  48 ] jit-word-jump jit-define
  49
  50 : jit-load-vm ( -- )
  51     vm-reg 0 MOV 0 rc-absolute-cell rel-vm ;
  52
  53 : jit-load-context ( -- )
  54     ! VM pointer must be in vm-reg already
  55     ctx-reg vm-reg vm-context-offset [+] MOV ;
  56
  57 : jit-save-context ( -- )
  58     jit-load-context
  59     ECX ESP -4 [+] LEA
  60     ctx-reg context-callstack-top-offset [+] ECX MOV
  61     ctx-reg context-datastack-offset [+] ds-reg MOV
  62     ctx-reg context-retainstack-offset [+] rs-reg MOV ;
  63
  64 : jit-restore-context ( -- )
  65     ds-reg ctx-reg context-datastack-offset [+] MOV
  66     rs-reg ctx-reg context-retainstack-offset [+] MOV ;
  67
  68 [
  69     ! ctx-reg is preserved across the call because it is
  70     ! non-volatile in the C ABI
  71     jit-load-vm
  72     jit-save-context
  73     ! call the primitive
  74     ESP [] vm-reg MOV
  75     0 CALL f f rc-relative rel-dlsym
  76     jit-restore-context
  77 ] jit-primitive jit-define
  78
  79 : jit-jump-quot ( -- )
  80     EAX quot-entry-point-offset [+] JMP ;
  81
  82 : jit-call-quot ( -- )
  83     EAX quot-entry-point-offset [+] CALL ;
  84
  85 [
  86     jit-load-vm
  87     ESP [] vm-reg MOV
  88     EAX EBP 8 [+] MOV
  89     ESP 4 [+] EAX MOV
  90     "begin_callback" jit-call
  91
  92     jit-call-quot
  93
  94     jit-load-vm
  95     ESP [] vm-reg MOV
  96     "end_callback" jit-call
  97 ] \ c-to-factor define-sub-primitive
  98
  99 [
 100     EAX 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     ! Load ds and rs registers
 109     jit-load-vm
 110     jit-load-context
 111     jit-restore-context
 112
 113     ! Windows-specific setup
 114     ctx-reg jit-update-seh
 115
 116     ! Load arguments
 117     EAX ESP stack-frame-size [+] MOV
 118     EDX ESP stack-frame-size 4 + [+] MOV
 119
 120     ! Unwind stack frames
 121     ESP EDX MOV
 122
 123     jit-jump-quot
 124 ] \ unwind-native-frames define-sub-primitive
 125
 126 [
 127     ESP 2 SUB
 128     ESP [] FNSTCW
 129     FNINIT
 130     AX ESP [] MOV
 131     ESP 2 ADD
 132 ] \ fpu-state define-sub-primitive
 133
 134 [
 135     ESP stack-frame-size [+] FLDCW
 136 ] \ set-fpu-state define-sub-primitive
 137
 138 [
 139     ! Load callstack object
 140     temp3 ds-reg [] MOV
 141     ds-reg bootstrap-cell SUB
 142     ! Get ctx->callstack_bottom
 143     jit-load-vm
 144     jit-load-context
 145     temp0 ctx-reg context-callstack-bottom-offset [+] MOV
 146     ! Get top of callstack object -- 'src' for memcpy
 147     temp1 temp3 callstack-top-offset [+] LEA
 148     ! Get callstack length, in bytes --- 'len' for memcpy
 149     temp2 temp3 callstack-length-offset [+] MOV
 150     temp2 tag-bits get SHR
 151     ! Compute new stack pointer -- 'dst' for memcpy
 152     temp0 temp2 SUB
 153     ! Install new stack pointer
 154     ESP temp0 MOV
 155     ! Call memcpy
 156     temp2 PUSH
 157     temp1 PUSH
 158     temp0 PUSH
 159     "factor_memcpy" jit-call
 160     ESP 12 ADD
 161     ! Return with new callstack
 162     0 RET
 163 ] \ set-callstack define-sub-primitive
 164
 165 [
 166     jit-load-vm
 167     jit-save-context
 168
 169     ! Store arguments
 170     ESP [] EAX MOV
 171     ESP 4 [+] vm-reg MOV
 172
 173     ! Call VM
 174     "lazy_jit_compile" jit-call
 175 ]
 176 [ jit-call-quot ]
 177 [ jit-jump-quot ]
 178 \ lazy-jit-compile define-combinator-primitive
 179
 180 [
 181     temp1 HEX: ffffffff CMP f rc-absolute-cell rel-literal
 182 ] pic-check-tuple jit-define
 183
 184 ! Inline cache miss entry points
 185 : jit-load-return-address ( -- )
 186     pic-tail-reg ESP stack-frame-size bootstrap-cell - [+] MOV ;
 187
 188 ! These are always in tail position with an existing stack
 189 ! frame, and the stack. The frame setup takes this into account.
 190 : jit-inline-cache-miss ( -- )
 191     jit-load-vm
 192     jit-save-context
 193     ESP 4 [+] vm-reg MOV
 194     ESP [] pic-tail-reg MOV
 195     0 CALL rc-relative rel-inline-cache-miss
 196     jit-restore-context ;
 197
 198 [ jit-load-return-address jit-inline-cache-miss ]
 199 [ EAX CALL ]
 200 [ EAX JMP ]
 201 \ inline-cache-miss define-combinator-primitive
 202
 203 [ jit-inline-cache-miss ]
 204 [ EAX CALL ]
 205 [ EAX JMP ]
 206 \ inline-cache-miss-tail define-combinator-primitive
 207
 208 ! Overflowing fixnum arithmetic
 209 : jit-overflow ( insn func -- )
 210     ds-reg 4 SUB
 211     jit-load-vm
 212     jit-save-context
 213     EAX ds-reg [] MOV
 214     EDX ds-reg 4 [+] MOV
 215     EBX EAX MOV
 216     [ [ EBX EDX ] dip call( dst src -- ) ] dip
 217     ds-reg [] EBX MOV
 218     [ JNO ]
 219     [
 220         ESP [] EAX MOV
 221         ESP 4 [+] EDX MOV
 222         jit-load-vm
 223         ESP 8 [+] vm-reg MOV
 224         jit-call
 225     ]
 226     jit-conditional ;
 227
 228 [ [ ADD ] "overflow_fixnum_add" jit-overflow ] \ fixnum+ define-sub-primitive
 229
 230 [ [ SUB ] "overflow_fixnum_subtract" jit-overflow ] \ fixnum- define-sub-primitive
 231
 232 [
 233     ds-reg 4 SUB
 234     jit-load-vm
 235     jit-save-context
 236     EBX ds-reg [] MOV
 237     EAX EBX MOV
 238     EBP ds-reg 4 [+] MOV
 239     EBP tag-bits get SAR
 240     EBP IMUL
 241     ds-reg [] EAX MOV
 242     [ JNO ]
 243     [
 244         EBX tag-bits get SAR
 245         ESP [] EBX MOV
 246         ESP 4 [+] EBP MOV
 247         jit-load-vm
 248         ESP 8 [+] vm-reg MOV
 249         "overflow_fixnum_multiply" jit-call
 250     ]
 251     jit-conditional
 252 ] \ fixnum* define-sub-primitive
 253
 254 ! Contexts
 255 : jit-switch-context ( reg -- )
 256     ! Reset return value since its bogus right now, to avoid
 257     ! confusing the GC
 258     ESP -4 [+] 0 MOV
 259
 260     ! Make the new context the current one
 261     ctx-reg swap MOV
 262     vm-reg vm-context-offset [+] ctx-reg MOV
 263
 264     ! Load new stack pointer
 265     ESP ctx-reg context-callstack-top-offset [+] MOV
 266
 267     ! Windows-specific setup
 268     ctx-reg jit-update-tib
 269
 270     ! Load new ds, rs registers
 271     jit-restore-context ;
 272
 273 : jit-set-context ( -- )
 274     ! Load context and parameter from datastack
 275     EAX ds-reg [] MOV
 276     EAX EAX alien-offset [+] MOV
 277     EDX ds-reg -4 [+] MOV
 278     ds-reg 8 SUB
 279
 280     ! Save ds, rs registers
 281     jit-load-vm
 282     jit-save-context
 283
 284     ! Make the new context active
 285     EAX jit-switch-context
 286
 287     ! Windows-specific setup
 288     ctx-reg jit-update-seh
 289
 290     ! Twiddle stack for return
 291     ESP 4 ADD
 292
 293     ! Store parameter to datastack
 294     ds-reg 4 ADD
 295     ds-reg [] EDX MOV ;
 296
 297 [ jit-set-context ] \ (set-context) define-sub-primitive
 298
 299 : jit-save-quot-and-param ( -- )
 300     EDX ds-reg MOV
 301     ds-reg 8 SUB ;
 302
 303 : jit-push-param ( -- )
 304     EAX EDX -4 [+] MOV
 305     ds-reg 4 ADD
 306     ds-reg [] EAX MOV ;
 307
 308 : jit-start-context ( -- )
 309     ! Create the new context in return-reg
 310     jit-load-vm
 311     jit-save-context
 312     ESP [] vm-reg MOV
 313     "new_context" jit-call
 314
 315     jit-save-quot-and-param
 316
 317     ! Make the new context active
 318     jit-load-vm
 319     jit-save-context
 320     EAX jit-switch-context
 321
 322     jit-push-param
 323
 324     ! Windows-specific setup
 325     jit-install-seh
 326
 327     ! Push a fake return address
 328     0 PUSH
 329
 330     ! Jump to initial quotation
 331     EAX EDX [] MOV
 332     jit-jump-quot ;
 333
 334 [ jit-start-context ] \ (start-context) define-sub-primitive
 335
 336 : jit-delete-current-context ( -- )
 337     jit-load-vm
 338     jit-load-context
 339     ESP [] vm-reg MOV
 340     ESP 4 [+] ctx-reg MOV
 341     "delete_context" jit-call ;
 342
 343 [
 344     jit-delete-current-context
 345     jit-set-context
 346 ] \ (set-context-and-delete) define-sub-primitive
 347
 348 : jit-start-context-and-delete ( -- )
 349     jit-load-vm
 350     jit-load-context
 351     ESP [] vm-reg MOV
 352     ESP 4 [+] ctx-reg MOV
 353     "reset_context" jit-call
 354
 355     jit-save-quot-and-param
 356     ctx-reg jit-switch-context
 357     jit-push-param
 358
 359     EAX EDX [] MOV
 360     jit-jump-quot ;
 361
 362 [
 363     jit-start-context-and-delete
 364 ] \ (start-context-and-delete) define-sub-primitive