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