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     ! clear the fault flag
 150     vm-reg vm-fault-flag-offset [+] 0 MOV
 151
 152     ! Windows-specific setup
 153     ctx-reg jit-update-seh
 154
 155     ! Load arguments
 156     EAX ESP stack-frame-size [+] MOV
 157     EDX ESP stack-frame-size 4 + [+] MOV
 158
 159     ! Unwind stack frames
 160     ESP EDX MOV
 161
 162     jit-jump-quot
 163 ] \ unwind-native-frames define-sub-primitive
 164
 165 [
 166     ESP 2 SUB
 167     ESP [] FNSTCW
 168     FNINIT
 169     AX ESP [] MOV
 170     ESP 2 ADD
 171 ] \ fpu-state define-sub-primitive
 172
 173 [
 174     ESP stack-frame-size [+] FLDCW
 175 ] \ set-fpu-state define-sub-primitive
 176
 177 [
 178     ! Load callstack object
 179     temp3 ds-reg [] MOV
 180     ds-reg bootstrap-cell SUB
 181     ! Get ctx->callstack_bottom
 182     jit-load-vm
 183     jit-load-context
 184     temp0 ctx-reg context-callstack-bottom-offset [+] MOV
 185     ! Get top of callstack object -- 'src' for memcpy
 186     temp1 temp3 callstack-top-offset [+] LEA
 187     ! Get callstack length, in bytes --- 'len' for memcpy
 188     temp2 temp3 callstack-length-offset [+] MOV
 189     temp2 tag-bits get SHR
 190     ! Compute new stack pointer -- 'dst' for memcpy
 191     temp0 temp2 SUB
 192     ! Install new stack pointer
 193     ESP temp0 MOV
 194     ! Call memcpy
 195     temp2 PUSH
 196     temp1 PUSH
 197     temp0 PUSH
 198     "factor_memcpy" jit-call
 199     ESP 12 ADD
 200     ! Return with new callstack
 201     0 RET
 202 ] \ set-callstack define-sub-primitive
 203
 204 [
 205     jit-load-vm
 206     jit-save-context
 207
 208     ! Store arguments
 209     ESP [] EAX MOV
 210     ESP 4 [+] vm-reg MOV
 211
 212     ! Call VM
 213     "lazy_jit_compile" jit-call
 214 ]
 215 [ jit-call-quot ]
 216 [ jit-jump-quot ]
 217 \ lazy-jit-compile define-combinator-primitive
 218
 219 [
 220     temp1 0xffffffff CMP f rc-absolute-cell rel-literal
 221 ] pic-check-tuple jit-define
 222
 223 ! Inline cache miss entry points
 224 : jit-load-return-address ( -- )
 225     pic-tail-reg ESP stack-frame-size bootstrap-cell - [+] MOV ;
 226
 227 ! These are always in tail position with an existing stack
 228 ! frame, and the stack. The frame setup takes this into account.
 229 : jit-inline-cache-miss ( -- )
 230     jit-load-vm
 231     jit-save-context
 232     ESP 4 [+] vm-reg MOV
 233     ESP [] pic-tail-reg MOV
 234     0 CALL rc-relative rel-inline-cache-miss
 235     jit-restore-context ;
 236
 237 [ jit-load-return-address jit-inline-cache-miss ]
 238 [ EAX CALL ]
 239 [ EAX JMP ]
 240 \ inline-cache-miss define-combinator-primitive
 241
 242 [ jit-inline-cache-miss ]
 243 [ EAX CALL ]
 244 [ EAX JMP ]
 245 \ inline-cache-miss-tail define-combinator-primitive
 246
 247 ! Overflowing fixnum arithmetic
 248 : jit-overflow ( insn func -- )
 249     ds-reg 4 SUB
 250     jit-load-vm
 251     jit-save-context
 252     EAX ds-reg [] MOV
 253     EDX ds-reg 4 [+] MOV
 254     EBX EAX MOV
 255     [ [ EBX EDX ] dip call( dst src -- ) ] dip
 256     ds-reg [] EBX MOV
 257     [ JNO ]
 258     [
 259         ESP [] EAX MOV
 260         ESP 4 [+] EDX MOV
 261         jit-load-vm
 262         ESP 8 [+] vm-reg MOV
 263         jit-call
 264     ]
 265     jit-conditional ;
 266
 267 [ [ ADD ] "overflow_fixnum_add" jit-overflow ] \ fixnum+ define-sub-primitive
 268
 269 [ [ SUB ] "overflow_fixnum_subtract" jit-overflow ] \ fixnum- define-sub-primitive
 270
 271 [
 272     ds-reg 4 SUB
 273     jit-load-vm
 274     jit-save-context
 275     EBX ds-reg [] MOV
 276     EAX EBX MOV
 277     EBP ds-reg 4 [+] MOV
 278     EBP tag-bits get SAR
 279     EBP IMUL
 280     ds-reg [] EAX MOV
 281     [ JNO ]
 282     [
 283         EBX tag-bits get SAR
 284         ESP [] EBX MOV
 285         ESP 4 [+] EBP MOV
 286         jit-load-vm
 287         ESP 8 [+] vm-reg MOV
 288         "overflow_fixnum_multiply" jit-call
 289     ]
 290     jit-conditional
 291 ] \ fixnum* define-sub-primitive
 292
 293 ! Contexts
 294 : jit-switch-context ( reg -- )
 295     ! Reset return value since its bogus right now, to avoid
 296     ! confusing the GC
 297     ESP -4 [+] 0 MOV
 298
 299     ! Make the new context the current one
 300     ctx-reg swap MOV
 301     vm-reg vm-context-offset [+] ctx-reg MOV
 302
 303     ! Load new stack pointer
 304     ESP ctx-reg context-callstack-top-offset [+] MOV
 305
 306     ! Windows-specific setup
 307     ctx-reg jit-update-tib
 308
 309     ! Load new ds, rs registers
 310     jit-restore-context ;
 311
 312 : jit-set-context ( -- )
 313     ! Load context and parameter from datastack
 314     EAX ds-reg [] MOV
 315     EAX EAX alien-offset [+] MOV
 316     EDX ds-reg -4 [+] MOV
 317     ds-reg 8 SUB
 318
 319     ! Save ds, rs registers
 320     jit-load-vm
 321     jit-save-context
 322
 323     ! Make the new context active
 324     EAX jit-switch-context
 325
 326     ! Windows-specific setup
 327     ctx-reg jit-update-seh
 328
 329     ! Twiddle stack for return
 330     ESP 4 ADD
 331
 332     ! Store parameter to datastack
 333     ds-reg 4 ADD
 334     ds-reg [] EDX MOV ;
 335
 336 [ jit-set-context ] \ (set-context) define-sub-primitive
 337
 338 : jit-save-quot-and-param ( -- )
 339     EDX ds-reg MOV
 340     ds-reg 8 SUB ;
 341
 342 : jit-push-param ( -- )
 343     EAX EDX -4 [+] MOV
 344     ds-reg 4 ADD
 345     ds-reg [] EAX MOV ;
 346
 347 : jit-start-context ( -- )
 348     ! Create the new context in return-reg
 349     jit-load-vm
 350     jit-save-context
 351     ESP [] vm-reg MOV
 352     "new_context" jit-call
 353
 354     jit-save-quot-and-param
 355
 356     ! Make the new context active
 357     jit-load-vm
 358     jit-save-context
 359     EAX jit-switch-context
 360
 361     jit-push-param
 362
 363     ! Windows-specific setup
 364     jit-install-seh
 365
 366     ! Push a fake return address
 367     0 PUSH
 368
 369     ! Jump to initial quotation
 370     EAX EDX [] MOV
 371     jit-jump-quot ;
 372
 373 [ jit-start-context ] \ (start-context) define-sub-primitive
 374
 375 : jit-delete-current-context ( -- )
 376     jit-load-vm
 377     jit-load-context
 378     ESP [] vm-reg MOV
 379     ESP 4 [+] ctx-reg MOV
 380     "delete_context" jit-call ;
 381
 382 [
 383     jit-delete-current-context
 384     jit-set-context
 385 ] \ (set-context-and-delete) define-sub-primitive
 386
 387 : jit-start-context-and-delete ( -- )
 388     jit-load-vm
 389     jit-load-context
 390     ESP [] vm-reg MOV
 391     ESP 4 [+] ctx-reg MOV
 392     "reset_context" jit-call
 393
 394     jit-save-quot-and-param
 395     ctx-reg jit-switch-context
 396     jit-push-param
 397
 398     EAX EDX [] MOV
 399     jit-jump-quot ;
 400
 401 [
 402     0 EAX MOVABS rc-absolute rel-safepoint
 403 ] \ jit-safepoint jit-define
 404
 405 [
 406     jit-start-context-and-delete
 407 ] \ (start-context-and-delete) define-sub-primitive