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 locals ;
   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 : volatile-regs ( -- seq ) { EAX ECX EDX } ;
  27 : nv-reg ( -- reg ) ESI ;
  28 : ds-reg ( -- reg ) ESI ;
  29 : rs-reg ( -- reg ) EDI ;
  30 : link-reg ( -- reg ) EBX ;
  31 : fixnum>slot@ ( -- ) temp0 2 SAR ;
  32 : rex-length ( -- n ) 0 ;
  33 : red-zone-size ( -- n ) 0 ;
  34
  35 : jit-call ( name -- )
  36     0 CALL f rc-relative rel-dlsym ;
  37
  38 [
  39     ! alignment
  40     ESP stack-frame-size bootstrap-cell - SUB
  41     ! store entry point
  42     ESP stack-frame-size 3 bootstrap-cells - [+] 0 MOV rc-absolute-cell rel-this
  43     ! store stack frame size
  44     ESP stack-frame-size 2 bootstrap-cells - [+] stack-frame-size MOV
  45 ] jit-prolog jit-define
  46
  47 [
  48     pic-tail-reg 0 MOV 0 rc-absolute-cell rel-here
  49     0 JMP f rc-relative rel-word-pic-tail
  50 ] jit-word-jump jit-define
  51
  52 : jit-load-vm ( -- )
  53     vm-reg 0 MOV 0 rc-absolute-cell rel-vm ;
  54
  55 : jit-load-context ( -- )
  56     ! VM pointer must be in vm-reg already
  57     ctx-reg vm-reg vm-context-offset [+] MOV ;
  58
  59 : jit-save-context ( -- )
  60     jit-load-context
  61     ECX ESP -4 [+] LEA
  62     ctx-reg context-callstack-top-offset [+] ECX MOV
  63     ctx-reg context-datastack-offset [+] ds-reg MOV
  64     ctx-reg context-retainstack-offset [+] rs-reg MOV ;
  65
  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
  72     ! non-volatile in the C ABI
  73     jit-load-vm
  74     jit-save-context
  75     ! call the primitive
  76     ESP [] vm-reg MOV
  77     0 CALL f f rc-relative rel-dlsym
  78     jit-restore-context
  79 ] jit-primitive jit-define
  80
  81 : jit-jump-quot ( -- )
  82     EAX quot-entry-point-offset [+] JMP ;
  83
  84 : jit-call-quot ( -- )
  85     EAX quot-entry-point-offset [+] CALL ;
  86
  87 [
  88     jit-load-vm
  89     ESP [] vm-reg MOV
  90     EAX EBP 8 [+] MOV
  91     ESP 4 [+] EAX MOV
  92     "begin_callback" jit-call
  93
  94     jit-call-quot
  95
  96     jit-load-vm
  97     ESP [] vm-reg MOV
  98     "end_callback" jit-call
  99 ] \ c-to-factor define-sub-primitive
 100
 101 ! The signal-handler and leaf-signal-handler subprimitives are special-cased
 102 ! in vm/quotations.cpp not to trigger generation of a stack frame, so they can
 103 ! peform their own prolog/epilog preserving registers.
 104
 105 :: jit-signal-handler-prolog ( -- frame-size )
 106     stack-frame-size 8 bootstrap-cells + :> frame-size
 107     ! minus a cell each for flags and return address
 108     ! use LEA so we don't dirty flags
 109     ESP ESP frame-size 2 bootstrap-cells - neg [+] LEA
 110     ESP []                    EAX MOV
 111     ESP 1 bootstrap-cells [+] ECX MOV
 112     ESP 2 bootstrap-cells [+] EDX MOV
 113     ESP 3 bootstrap-cells [+] EBX MOV
 114     ESP 4 bootstrap-cells [+] EBP MOV
 115     ESP 5 bootstrap-cells [+] ESI MOV
 116     ESP 6 bootstrap-cells [+] EDI MOV
 117     PUSHF
 118     ESP frame-size 3 bootstrap-cells - [+] 0 MOV rc-absolute-cell rel-this
 119     ESP frame-size 2 bootstrap-cells - [+] frame-size MOV
 120     ! subprimitive definition assumes vm's been loaded
 121     jit-load-vm
 122     frame-size ;
 123
 124 :: jit-signal-handler-epilog ( frame-size -- )
 125     POPF
 126     EAX ESP []                    MOV
 127     ECX ESP 1 bootstrap-cells [+] MOV
 128     EDX ESP 2 bootstrap-cells [+] MOV
 129     EBX ESP 3 bootstrap-cells [+] MOV
 130     EBP ESP 4 bootstrap-cells [+] MOV
 131     ESI ESP 5 bootstrap-cells [+] MOV
 132     EDI ESP 6 bootstrap-cells [+] MOV
 133     ESP ESP frame-size 2 bootstrap-cells - [+] LEA ;
 134
 135 [
 136     EAX ds-reg [] MOV
 137     ds-reg bootstrap-cell SUB
 138 ]
 139 [ jit-call-quot ]
 140 [ jit-jump-quot ]
 141 \ (call) define-combinator-primitive
 142
 143 [
 144     ! Load ds and rs registers
 145     jit-load-vm
 146     jit-load-context
 147     jit-restore-context
 148
 149     ! Windows-specific setup
 150     ctx-reg jit-update-seh
 151
 152     ! Load arguments
 153     EAX ESP stack-frame-size [+] MOV
 154     EDX ESP stack-frame-size 4 + [+] MOV
 155
 156     ! Unwind stack frames
 157     ESP EDX MOV
 158
 159     jit-jump-quot
 160 ] \ unwind-native-frames define-sub-primitive
 161
 162 [
 163     ESP 2 SUB
 164     ESP [] FNSTCW
 165     FNINIT
 166     AX ESP [] MOV
 167     ESP 2 ADD
 168 ] \ fpu-state define-sub-primitive
 169
 170 [
 171     ESP stack-frame-size [+] FLDCW
 172 ] \ set-fpu-state define-sub-primitive
 173
 174 [
 175     ! Load callstack object
 176     temp3 ds-reg [] MOV
 177     ds-reg bootstrap-cell SUB
 178     ! Get ctx->callstack_bottom
 179     jit-load-vm
 180     jit-load-context
 181     temp0 ctx-reg context-callstack-bottom-offset [+] MOV
 182     ! Get top of callstack object -- 'src' for memcpy
 183     temp1 temp3 callstack-top-offset [+] LEA
 184     ! Get callstack length, in bytes --- 'len' for memcpy
 185     temp2 temp3 callstack-length-offset [+] MOV
 186     temp2 tag-bits get SHR
 187     ! Compute new stack pointer -- 'dst' for memcpy
 188     temp0 temp2 SUB
 189     ! Install new stack pointer
 190     ESP temp0 MOV
 191     ! Call memcpy
 192     temp2 PUSH
 193     temp1 PUSH
 194     temp0 PUSH
 195     "factor_memcpy" jit-call
 196     ESP 12 ADD
 197     ! Return with new callstack
 198     0 RET
 199 ] \ set-callstack define-sub-primitive
 200
 201 [
 202     jit-load-vm
 203     jit-save-context
 204
 205     ! Store arguments
 206     ESP [] EAX MOV
 207     ESP 4 [+] vm-reg MOV
 208
 209     ! Call VM
 210     "lazy_jit_compile" jit-call
 211 ]
 212 [ jit-call-quot ]
 213 [ jit-jump-quot ]
 214 \ lazy-jit-compile define-combinator-primitive
 215
 216 [
 217     temp1 HEX: ffffffff CMP f rc-absolute-cell rel-literal
 218 ] pic-check-tuple jit-define
 219
 220 ! Inline cache miss entry points
 221 : jit-load-return-address ( -- )
 222     pic-tail-reg ESP stack-frame-size bootstrap-cell - [+] MOV ;
 223
 224 ! These are always in tail position with an existing stack
 225 ! frame, and the stack. The frame setup takes this into account.
 226 : jit-inline-cache-miss ( -- )
 227     jit-load-vm
 228     jit-save-context
 229     ESP 4 [+] vm-reg MOV
 230     ESP [] pic-tail-reg MOV
 231     0 CALL rc-relative rel-inline-cache-miss
 232     jit-restore-context ;
 233
 234 [ jit-load-return-address jit-inline-cache-miss ]
 235 [ EAX CALL ]
 236 [ EAX JMP ]
 237 \ inline-cache-miss define-combinator-primitive
 238
 239 [ jit-inline-cache-miss ]
 240 [ EAX CALL ]
 241 [ EAX JMP ]
 242 \ inline-cache-miss-tail define-combinator-primitive
 243
 244 ! Overflowing fixnum arithmetic
 245 : jit-overflow ( insn func -- )
 246     ds-reg 4 SUB
 247     jit-load-vm
 248     jit-save-context
 249     EAX ds-reg [] MOV
 250     EDX ds-reg 4 [+] MOV
 251     EBX EAX MOV
 252     [ [ EBX EDX ] dip call( dst src -- ) ] dip
 253     ds-reg [] EBX MOV
 254     [ JNO ]
 255     [
 256         ESP [] EAX MOV
 257         ESP 4 [+] EDX MOV
 258         jit-load-vm
 259         ESP 8 [+] vm-reg MOV
 260         jit-call
 261     ]
 262     jit-conditional ;
 263
 264 [ [ ADD ] "overflow_fixnum_add" jit-overflow ] \ fixnum+ define-sub-primitive
 265
 266 [ [ SUB ] "overflow_fixnum_subtract" jit-overflow ] \ fixnum- define-sub-primitive
 267
 268 [
 269     ds-reg 4 SUB
 270     jit-load-vm
 271     jit-save-context
 272     EBX ds-reg [] MOV
 273     EAX EBX MOV
 274     EBP ds-reg 4 [+] MOV
 275     EBP tag-bits get SAR
 276     EBP IMUL
 277     ds-reg [] EAX MOV
 278     [ JNO ]
 279     [
 280         EBX tag-bits get SAR
 281         ESP [] EBX MOV
 282         ESP 4 [+] EBP MOV
 283         jit-load-vm
 284         ESP 8 [+] vm-reg MOV
 285         "overflow_fixnum_multiply" jit-call
 286     ]
 287     jit-conditional
 288 ] \ fixnum* define-sub-primitive
 289
 290 ! Contexts
 291 : jit-switch-context ( reg -- )
 292     ! Reset return value since its bogus right now, to avoid
 293     ! confusing the GC
 294     ESP -4 [+] 0 MOV
 295
 296     ! Make the new context the current one
 297     ctx-reg swap MOV
 298     vm-reg vm-context-offset [+] ctx-reg MOV
 299
 300     ! Load new stack pointer
 301     ESP ctx-reg context-callstack-top-offset [+] MOV
 302
 303     ! Windows-specific setup
 304     ctx-reg jit-update-tib
 305
 306     ! Load new ds, rs registers
 307     jit-restore-context ;
 308
 309 : jit-set-context ( -- )
 310     ! Load context and parameter from datastack
 311     EAX ds-reg [] MOV
 312     EAX EAX alien-offset [+] MOV
 313     EDX ds-reg -4 [+] MOV
 314     ds-reg 8 SUB
 315
 316     ! Save ds, rs registers
 317     jit-load-vm
 318     jit-save-context
 319
 320     ! Make the new context active
 321     EAX jit-switch-context
 322
 323     ! Windows-specific setup
 324     ctx-reg jit-update-seh
 325
 326     ! Twiddle stack for return
 327     ESP 4 ADD
 328
 329     ! Store parameter to datastack
 330     ds-reg 4 ADD
 331     ds-reg [] EDX MOV ;
 332
 333 [ jit-set-context ] \ (set-context) define-sub-primitive
 334
 335 : jit-save-quot-and-param ( -- )
 336     EDX ds-reg MOV
 337     ds-reg 8 SUB ;
 338
 339 : jit-push-param ( -- )
 340     EAX EDX -4 [+] MOV
 341     ds-reg 4 ADD
 342     ds-reg [] EAX MOV ;
 343
 344 : jit-start-context ( -- )
 345     ! Create the new context in return-reg
 346     jit-load-vm
 347     jit-save-context
 348     ESP [] vm-reg MOV
 349     "new_context" jit-call
 350
 351     jit-save-quot-and-param
 352
 353     ! Make the new context active
 354     jit-load-vm
 355     jit-save-context
 356     EAX jit-switch-context
 357
 358     jit-push-param
 359
 360     ! Windows-specific setup
 361     jit-install-seh
 362
 363     ! Push a fake return address
 364     0 PUSH
 365
 366     ! Jump to initial quotation
 367     EAX EDX [] MOV
 368     jit-jump-quot ;
 369
 370 [ jit-start-context ] \ (start-context) define-sub-primitive
 371
 372 : jit-delete-current-context ( -- )
 373     jit-load-vm
 374     jit-load-context
 375     ESP [] vm-reg MOV
 376     ESP 4 [+] ctx-reg MOV
 377     "delete_context" jit-call ;
 378
 379 [
 380     jit-delete-current-context
 381     jit-set-context
 382 ] \ (set-context-and-delete) define-sub-primitive
 383
 384 : jit-start-context-and-delete ( -- )
 385     jit-load-vm
 386     jit-load-context
 387     ESP [] vm-reg MOV
 388     ESP 4 [+] ctx-reg MOV
 389     "reset_context" jit-call
 390
 391     jit-save-quot-and-param
 392     ctx-reg jit-switch-context
 393     jit-push-param
 394
 395     EAX EDX [] MOV
 396     jit-jump-quot ;
 397
 398 [
 399     0 EAX MOVABS rc-absolute rel-safepoint
 400 ] \ jit-safepoint jit-define
 401
 402 [
 403     jit-start-context-and-delete
 404 ] \ (start-context-and-delete) define-sub-primitive