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