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