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 ;
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 ;
32 : jit-call ( name -- )
33 0 CALL rc-relative jit-dlsym ;
36 ! save stack frame size
39 0 PUSH rc-absolute-cell rt-this jit-rel
41 ESP stack-frame-size 3 bootstrap-cells - SUB
42 ] jit-prolog jit-define
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
50 vm-reg 0 MOV 0 rc-absolute-cell jit-vm ;
52 : jit-load-context ( -- )
53 ! VM pointer must be in vm-reg already
54 ctx-reg vm-reg vm-context-offset [+] MOV ;
56 : jit-save-context ( -- )
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 ;
63 : jit-restore-context ( -- )
64 ds-reg ctx-reg context-datastack-offset [+] MOV
65 rs-reg ctx-reg context-retainstack-offset [+] MOV ;
68 ! ctx-reg is preserved across the call because it is non-volatile
74 0 CALL rc-relative rt-dlsym jit-rel
76 ] jit-primitive jit-define
78 : jit-jump-quot ( -- )
79 EAX quot-entry-point-offset [+] JMP ;
81 : jit-call-quot ( -- )
82 EAX quot-entry-point-offset [+] CALL ;
89 "begin_callback" jit-call
95 "end_callback" jit-call
96 ] \ c-to-factor define-sub-primitive
100 ds-reg bootstrap-cell SUB
104 \ (call) define-combinator-primitive
107 ! Load ds and rs registers
112 ! Windows-specific setup
113 ctx-reg jit-update-seh
116 EAX ESP stack-frame-size [+] MOV
117 EDX ESP stack-frame-size 4 + [+] MOV
119 ! Unwind stack frames
123 ] \ unwind-native-frames define-sub-primitive
131 ] \ get-fpu-state define-sub-primitive
134 ESP stack-frame-size [+] FLDCW
135 ] \ set-fpu-state define-sub-primitive
138 ! Load callstack object
140 ds-reg bootstrap-cell SUB
141 ! Get ctx->callstack_bottom
144 temp0 ctx-reg context-callstack-bottom-offset [+] MOV
145 ! Get top of callstack object -- 'src' for memcpy
146 temp1 temp3 callstack-top-offset [+] LEA
147 ! Get callstack length, in bytes --- 'len' for memcpy
148 temp2 temp3 callstack-length-offset [+] MOV
149 temp2 tag-bits get SHR
150 ! Compute new stack pointer -- 'dst' for memcpy
152 ! Install new stack pointer
158 "factor_memcpy" jit-call
160 ! Return with new callstack
162 ] \ set-callstack define-sub-primitive
173 "lazy_jit_compile" jit-call
177 \ lazy-jit-compile define-combinator-primitive
180 temp1 HEX: ffffffff CMP rc-absolute-cell rt-literal jit-rel
181 ] pic-check-tuple jit-define
183 ! Inline cache miss entry points
184 : jit-load-return-address ( -- )
185 pic-tail-reg ESP stack-frame-size bootstrap-cell - [+] MOV ;
187 ! These are always in tail position with an existing stack
188 ! frame, and the stack. The frame setup takes this into account.
189 : jit-inline-cache-miss ( -- )
193 ESP [] pic-tail-reg MOV
194 "inline_cache_miss" jit-call
195 jit-restore-context ;
197 [ jit-load-return-address jit-inline-cache-miss ]
200 \ inline-cache-miss define-combinator-primitive
202 [ jit-inline-cache-miss ]
205 \ inline-cache-miss-tail define-combinator-primitive
207 ! Overflowing fixnum arithmetic
208 : jit-overflow ( insn func -- )
215 [ [ EBX EDX ] dip call( dst src -- ) ] dip
227 [ [ ADD ] "overflow_fixnum_add" jit-overflow ] \ fixnum+ define-sub-primitive
229 [ [ SUB ] "overflow_fixnum_subtract" jit-overflow ] \ fixnum- define-sub-primitive
248 "overflow_fixnum_multiply" jit-call
251 ] \ fixnum* define-sub-primitive
254 : jit-switch-context ( reg -- )
255 ! Reset return value since its bogus right now, to avoid
259 ! Make the new context the current one
261 vm-reg vm-context-offset [+] ctx-reg MOV
263 ! Load new stack pointer
264 ESP ctx-reg context-callstack-top-offset [+] MOV
266 ! Windows-specific setup
267 ctx-reg jit-update-tib
269 ! Load new ds, rs registers
270 jit-restore-context ;
272 : jit-set-context ( -- )
273 ! Load context and parameter from datastack
275 EAX EAX alien-offset [+] MOV
276 EDX ds-reg -4 [+] MOV
279 ! Save ds, rs registers
283 ! Make the new context active
284 EAX jit-switch-context
286 ! Windows-specific setup
287 ctx-reg jit-update-seh
289 ! Twiddle stack for return
292 ! Store parameter to datastack
296 [ jit-set-context ] \ (set-context) define-sub-primitive
298 : jit-save-quot-and-param ( -- )
302 : jit-push-param ( -- )
307 : jit-start-context ( -- )
308 ! Create the new context in return-reg
312 "new_context" jit-call
314 jit-save-quot-and-param
316 ! Make the new context active
319 EAX jit-switch-context
323 ! Windows-specific setup
326 ! Push a fake return address
329 ! Jump to initial quotation
333 [ jit-start-context ] \ (start-context) define-sub-primitive
335 : jit-delete-current-context ( -- )
339 ESP 4 [+] ctx-reg MOV
340 "delete_context" jit-call ;
343 jit-delete-current-context
345 ] \ (set-context-and-delete) define-sub-primitive
347 : jit-start-context-and-delete ( -- )
351 ESP 4 [+] ctx-reg MOV
352 "reset_context" jit-call
354 jit-save-quot-and-param
355 ctx-reg jit-switch-context
362 jit-start-context-and-delete
363 ] \ (start-context-and-delete) define-sub-primitive