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 : jit-scrub-return ( n -- )
  68     ESP swap [+] 0 MOV ;
  69
  70 [
  71     ! ctx-reg is preserved across the call because it is non-volatile
  72     ! in the C ABI
  73     jit-load-vm
  74     jit-save-context
  75     ! call the primitive
  76     ESP [] vm-reg MOV
  77     0 CALL rc-relative rt-dlsym jit-rel
  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 [
 102     EAX ds-reg [] MOV
 103     ds-reg bootstrap-cell SUB
 104 ]
 105 [ jit-call-quot ]
 106 [ jit-jump-quot ]
 107 \ (call) define-combinator-primitive
 108
 109 [
 110     ! Load ds and rs registers
 111     jit-load-vm
 112     jit-load-context
 113     jit-restore-context
 114
 115     ! Windows-specific setup
 116     ctx-reg jit-update-seh
 117
 118     ! Clear x87 stack, but preserve rounding mode and exception flags
 119     ESP 2 SUB
 120     ESP [] FNSTCW
 121     FNINIT
 122     ESP [] FLDCW
 123     ESP 2 ADD
 124
 125     ! Load arguments
 126     EAX ESP stack-frame-size [+] MOV
 127     EDX ESP stack-frame-size 4 + [+] MOV
 128
 129     ! Unwind stack frames
 130     ESP EDX MOV
 131     0 jit-scrub-return
 132
 133     jit-jump-quot
 134 ] \ unwind-native-frames define-sub-primitive
 135
 136 [
 137     ! Load callstack object
 138     temp3 ds-reg [] MOV
 139     ds-reg bootstrap-cell SUB
 140     ! Get ctx->callstack_bottom
 141     jit-load-vm
 142     jit-load-context
 143     temp0 ctx-reg context-callstack-bottom-offset [+] MOV
 144     ! Get top of callstack object -- 'src' for memcpy
 145     temp1 temp3 callstack-top-offset [+] LEA
 146     ! Get callstack length, in bytes --- 'len' for memcpy
 147     temp2 temp3 callstack-length-offset [+] MOV
 148     temp2 tag-bits get SHR
 149     ! Compute new stack pointer -- 'dst' for memcpy
 150     temp0 temp2 SUB
 151     ! Install new stack pointer
 152     ESP temp0 MOV
 153     ! Call memcpy
 154     temp2 PUSH
 155     temp1 PUSH
 156     temp0 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 [
 179     temp1 HEX: ffffffff CMP rc-absolute-cell rt-literal jit-rel
 180 ] pic-check-tuple jit-define
 181
 182 ! Inline cache miss entry points
 183 : jit-load-return-address ( -- )
 184     pic-tail-reg ESP stack-frame-size bootstrap-cell - [+] MOV ;
 185
 186 ! These are always in tail position with an existing stack
 187 ! frame, and the stack. The frame setup takes this into account.
 188 : jit-inline-cache-miss ( -- )
 189     jit-load-vm
 190     jit-save-context
 191     ESP 4 [+] vm-reg MOV
 192     ESP [] pic-tail-reg MOV
 193     "inline_cache_miss" jit-call
 194     jit-restore-context ;
 195
 196 [ jit-load-return-address jit-inline-cache-miss ]
 197 [ EAX CALL ]
 198 [ EAX JMP ]
 199 \ inline-cache-miss define-combinator-primitive
 200
 201 [ jit-inline-cache-miss ]
 202 [ EAX CALL ]
 203 [ EAX JMP ]
 204 \ inline-cache-miss-tail define-combinator-primitive
 205
 206 ! Overflowing fixnum arithmetic
 207 : jit-overflow ( insn func -- )
 208     ds-reg 4 SUB
 209     jit-load-vm
 210     jit-save-context
 211     EAX ds-reg [] MOV
 212     EDX ds-reg 4 [+] MOV
 213     EBX EAX MOV
 214     [ [ EBX EDX ] dip call( dst src -- ) ] dip
 215     ds-reg [] EBX MOV
 216     [ JNO ]
 217     [
 218         ESP [] EAX MOV
 219         ESP 4 [+] EDX MOV
 220         jit-load-vm
 221         ESP 8 [+] vm-reg MOV
 222         jit-call
 223     ]
 224     jit-conditional ;
 225
 226 [ [ ADD ] "overflow_fixnum_add" jit-overflow ] \ fixnum+ define-sub-primitive
 227
 228 [ [ SUB ] "overflow_fixnum_subtract" jit-overflow ] \ fixnum- define-sub-primitive
 229
 230 [
 231     ds-reg 4 SUB
 232     jit-load-vm
 233     jit-save-context
 234     EBX ds-reg [] MOV
 235     EAX EBX MOV
 236     EBP ds-reg 4 [+] MOV
 237     EBP tag-bits get SAR
 238     EBP IMUL
 239     ds-reg [] EAX MOV
 240     [ JNO ]
 241     [
 242         EBX tag-bits get SAR
 243         ESP [] EBX MOV
 244         ESP 4 [+] EBP MOV
 245         jit-load-vm
 246         ESP 8 [+] vm-reg MOV
 247         "overflow_fixnum_multiply" jit-call
 248     ]
 249     jit-conditional
 250 ] \ fixnum* define-sub-primitive
 251
 252 ! Contexts
 253 : jit-switch-context ( reg -- )
 254     -4 jit-scrub-return
 255
 256     ! Save ds, rs registers
 257     jit-load-vm
 258     jit-save-context
 259
 260     ! Make the new context the current one
 261     ctx-reg swap MOV
 262     vm-reg vm-context-offset [+] ctx-reg MOV
 263
 264     ! Load new stack pointer
 265     ESP ctx-reg context-callstack-top-offset [+] MOV
 266
 267     ! Windows-specific setup
 268     ctx-reg jit-update-tib
 269
 270     ! Load new ds, rs registers
 271     jit-restore-context ;
 272
 273 : jit-set-context ( -- )
 274     ! Load context and parameter from datastack
 275     EAX ds-reg [] MOV
 276     EAX EAX alien-offset [+] MOV
 277     EDX ds-reg -4 [+] MOV
 278     ds-reg 8 SUB
 279
 280     ! Make the new context active
 281     EAX jit-switch-context
 282
 283     ! Windows-specific setup
 284     ctx-reg jit-update-seh
 285
 286     ! Twiddle stack for return
 287     ESP 4 ADD
 288
 289     ! Store parameter to datastack
 290     ds-reg 4 ADD
 291     ds-reg [] EDX MOV ;
 292
 293 [ jit-set-context ] \ (set-context) define-sub-primitive
 294
 295 : jit-save-quot-and-param ( -- )
 296     EDX ds-reg MOV
 297     ds-reg 8 SUB ;
 298
 299 : jit-push-param ( -- )
 300     EAX EDX -4 [+] MOV
 301     ds-reg 4 ADD
 302     ds-reg [] EAX MOV ;
 303
 304 : jit-start-context ( -- )
 305     ! Create the new context in return-reg
 306     jit-load-vm
 307     jit-save-context
 308     ESP [] vm-reg MOV
 309     "new_context" jit-call
 310
 311     jit-save-quot-and-param
 312
 313     ! Make the new context active
 314     EAX jit-switch-context
 315
 316     jit-push-param
 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 : jit-start-context-and-delete ( -- )
 343     jit-load-vm
 344     jit-load-context
 345     ESP [] vm-reg MOV
 346     ESP 4 [+] ctx-reg MOV
 347     "reset_context" jit-call
 348
 349     jit-save-quot-and-param
 350     ctx-reg jit-switch-context
 351     jit-push-param
 352
 353     EAX EDX [] MOV
 354     jit-jump-quot ;
 355
 356 [
 357     jit-start-context-and-delete
 358 ] \ (start-context-and-delete) define-sub-primitive