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 ;
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 ;
37 : jit-call ( name -- )
38 0 CALL f rc-relative rel-dlsym ;
40 :: jit-call-1arg ( arg1s name -- )
44 :: jit-call-2arg ( arg1s arg2s name -- )
49 :: jit-call-3arg ( arg1s arg2s arg3s name -- )
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
61 vm-reg 0 MOV 0 rc-absolute-cell rel-vm ;
63 : jit-load-context ( -- )
64 ! VM pointer must be in vm-reg already
65 ctx-reg vm-reg vm-context-offset [+] MOV ;
67 : jit-save-context ( -- )
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 ;
74 : jit-restore-context ( -- )
75 ds-reg ctx-reg context-datastack-offset [+] MOV
76 rs-reg ctx-reg context-retainstack-offset [+] MOV ;
79 ! ctx-reg is preserved across the call because it is
80 ! non-volatile in the C ABI
85 0 CALL f f rc-relative rel-dlsym
87 ] jit-primitive jit-define
89 : jit-jump-quot ( -- )
90 EAX quot-entry-point-offset [+] JMP ;
92 : jit-call-quot ( -- )
93 EAX quot-entry-point-offset [+] CALL ;
98 vm-reg EAX "begin_callback" jit-call-2arg
103 vm-reg "end_callback" jit-call-1arg
104 ] \ c-to-factor define-sub-primitive
106 : signal-handler-save-regs ( -- regs )
107 { EAX ECX EDX EBX EBP ESI EDI } ;
111 ds-reg bootstrap-cell SUB
115 \ (call) define-combinator-primitive
117 ! unwind-native-frames is marked as "special" in vm/quotations.cpp
118 ! so it does not have a standard prolog
120 ! Load ds and rs registers
125 ! clear the fault flag
126 vm-reg vm-fault-flag-offset [+] 0 MOV
128 ! Windows-specific setup
129 ctx-reg jit-update-seh
132 EAX ESP bootstrap-cell [+] MOV
133 EDX ESP 2 bootstrap-cells [+] MOV
135 ! Unwind stack frames
139 ] \ unwind-native-frames define-sub-primitive
147 ] \ fpu-state define-sub-primitive
150 ESP stack-frame-size [+] FLDCW
151 ] \ set-fpu-state define-sub-primitive
154 ! Load callstack object
156 ds-reg bootstrap-cell SUB
157 ! Get ctx->callstack_bottom
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
168 ! Install new stack pointer
174 "factor_memcpy" jit-call
176 ! Return with new callstack
178 ] \ set-callstack define-sub-primitive
184 ! Call VM, quotation reference is in EAX
185 EAX vm-reg "lazy_jit_compile" jit-call-2arg
189 \ lazy-jit-compile define-combinator-primitive
192 temp1 0xffffffff CMP f rc-absolute-cell rel-literal
193 ] pic-check-tuple jit-define
195 ! Inline cache miss entry points
196 : jit-load-return-address ( -- )
197 pic-tail-reg ESP stack-frame-size bootstrap-cell - [+] MOV ;
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 ( -- )
205 ESP [] pic-tail-reg MOV
206 0 CALL rc-relative rel-inline-cache-miss
207 jit-restore-context ;
209 [ jit-load-return-address jit-inline-cache-miss ]
212 \ inline-cache-miss define-combinator-primitive
214 [ jit-inline-cache-miss ]
217 \ inline-cache-miss-tail define-combinator-primitive
219 ! Overflowing fixnum arithmetic
220 : jit-overflow ( insn func -- )
227 [ [ EBX EDX ] dip call( dst src -- ) ] dip
239 [ [ ADD ] "overflow_fixnum_add" jit-overflow ] \ fixnum+ define-sub-primitive
241 [ [ SUB ] "overflow_fixnum_subtract" jit-overflow ] \ fixnum- define-sub-primitive
258 EBX EBP vm-reg "overflow_fixnum_multiply" jit-call-3arg
261 ] \ fixnum* define-sub-primitive
264 : jit-switch-context ( reg -- )
265 ! Push a bogus return address so the GC can track this frame back
269 ! Make the new context the current one
271 vm-reg vm-context-offset [+] ctx-reg MOV
273 ! Load new stack pointer
274 ESP ctx-reg context-callstack-top-offset [+] MOV
276 ! Windows-specific setup
277 ctx-reg jit-update-tib
279 ! Load new ds, rs registers
280 jit-restore-context ;
282 : jit-set-context ( -- )
283 ! Load context and parameter from datastack
285 EAX EAX alien-offset [+] MOV
286 EDX ds-reg -4 [+] MOV
289 ! Save ds, rs registers
293 ! Make the new context active
294 EAX jit-switch-context
296 ! Windows-specific setup
297 ctx-reg jit-update-seh
299 ! Twiddle stack for return
302 ! Store parameter to datastack
306 [ jit-set-context ] \ (set-context) define-sub-primitive
308 : jit-save-quot-and-param ( -- )
312 : jit-push-param ( -- )
317 : jit-start-context ( -- )
318 ! Create the new context in return-reg
321 vm-reg "new_context" jit-call-1arg
323 jit-save-quot-and-param
325 ! Make the new context active
328 EAX jit-switch-context
332 ! Windows-specific setup
335 ! Push a fake return address
338 ! Jump to initial quotation
342 [ jit-start-context ] \ (start-context) define-sub-primitive
344 : jit-delete-current-context ( -- )
347 vm-reg ctx-reg "delete_context" jit-call-2arg ;
350 jit-delete-current-context
352 ] \ (set-context-and-delete) define-sub-primitive
354 : jit-start-context-and-delete ( -- )
357 vm-reg ctx-reg "reset_context" jit-call-2arg
359 jit-save-quot-and-param
360 ctx-reg jit-switch-context
367 0 EAX MOVABS rc-absolute rel-safepoint
368 ] \ jit-safepoint jit-define
371 jit-start-context-and-delete
372 ] \ (start-context-and-delete) define-sub-primitive