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