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