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
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 : nv-reg ( -- reg ) ESI ;
27 : ds-reg ( -- reg ) ESI ;
28 : rs-reg ( -- reg ) EDI ;
29 : link-reg ( -- reg ) EBX ;
30 : fixnum>slot@ ( -- ) temp0 2 SAR ;
31 : rex-length ( -- n ) 0 ;
33 : jit-call ( name -- )
34 0 CALL f rc-relative rel-dlsym ;
37 ! save stack frame size
40 0 PUSH rc-absolute-cell rel-this
42 ESP stack-frame-size 3 bootstrap-cells - SUB
43 ] jit-prolog jit-define
46 pic-tail-reg 0 MOV 0 rc-absolute-cell rel-here
47 0 JMP f rc-relative rel-word-pic-tail
48 ] jit-word-jump jit-define
51 vm-reg 0 MOV 0 rc-absolute-cell rel-vm ;
53 : jit-load-context ( -- )
54 ! VM pointer must be in vm-reg already
55 ctx-reg vm-reg vm-context-offset [+] MOV ;
57 : jit-save-context ( -- )
60 ctx-reg context-callstack-top-offset [+] ECX MOV
61 ctx-reg context-datastack-offset [+] ds-reg MOV
62 ctx-reg context-retainstack-offset [+] rs-reg MOV ;
64 : jit-restore-context ( -- )
65 ds-reg ctx-reg context-datastack-offset [+] MOV
66 rs-reg ctx-reg context-retainstack-offset [+] MOV ;
69 ! ctx-reg is preserved across the call because it is
70 ! non-volatile in the C ABI
75 0 CALL f f rc-relative rel-dlsym
77 ] jit-primitive jit-define
79 : jit-jump-quot ( -- )
80 EAX quot-entry-point-offset [+] JMP ;
82 : jit-call-quot ( -- )
83 EAX quot-entry-point-offset [+] CALL ;
90 "begin_callback" jit-call
96 "end_callback" jit-call
97 ] \ c-to-factor define-sub-primitive
101 ds-reg bootstrap-cell SUB
105 \ (call) define-combinator-primitive
108 ! Load ds and rs registers
113 ! Windows-specific setup
114 ctx-reg jit-update-seh
117 EAX ESP stack-frame-size [+] MOV
118 EDX ESP stack-frame-size 4 + [+] MOV
120 ! Unwind stack frames
124 ] \ unwind-native-frames define-sub-primitive
132 ] \ fpu-state define-sub-primitive
135 ESP stack-frame-size [+] FLDCW
136 ] \ set-fpu-state define-sub-primitive
139 ! Load callstack object
141 ds-reg bootstrap-cell SUB
142 ! Get ctx->callstack_bottom
145 temp0 ctx-reg context-callstack-bottom-offset [+] MOV
146 ! Get top of callstack object -- 'src' for memcpy
147 temp1 temp3 callstack-top-offset [+] LEA
148 ! Get callstack length, in bytes --- 'len' for memcpy
149 temp2 temp3 callstack-length-offset [+] MOV
150 temp2 tag-bits get SHR
151 ! Compute new stack pointer -- 'dst' for memcpy
153 ! Install new stack pointer
159 "factor_memcpy" jit-call
161 ! Return with new callstack
163 ] \ set-callstack define-sub-primitive
174 "lazy_jit_compile" jit-call
178 \ lazy-jit-compile define-combinator-primitive
181 temp1 HEX: ffffffff CMP f rc-absolute-cell rel-literal
182 ] pic-check-tuple jit-define
184 ! Inline cache miss entry points
185 : jit-load-return-address ( -- )
186 pic-tail-reg ESP stack-frame-size bootstrap-cell - [+] MOV ;
188 ! These are always in tail position with an existing stack
189 ! frame, and the stack. The frame setup takes this into account.
190 : jit-inline-cache-miss ( -- )
194 ESP [] pic-tail-reg MOV
195 "inline_cache_miss" jit-call
196 jit-restore-context ;
198 [ jit-load-return-address jit-inline-cache-miss ]
201 \ inline-cache-miss define-combinator-primitive
203 [ jit-inline-cache-miss ]
206 \ inline-cache-miss-tail define-combinator-primitive
208 ! Overflowing fixnum arithmetic
209 : jit-overflow ( insn func -- )
216 [ [ EBX EDX ] dip call( dst src -- ) ] dip
228 [ [ ADD ] "overflow_fixnum_add" jit-overflow ] \ fixnum+ define-sub-primitive
230 [ [ SUB ] "overflow_fixnum_subtract" jit-overflow ] \ fixnum- define-sub-primitive
249 "overflow_fixnum_multiply" jit-call
252 ] \ fixnum* define-sub-primitive
255 : jit-switch-context ( reg -- )
256 ! Reset return value since its bogus right now, to avoid
260 ! Make the new context the current one
262 vm-reg vm-context-offset [+] ctx-reg MOV
264 ! Load new stack pointer
265 ESP ctx-reg context-callstack-top-offset [+] MOV
267 ! Windows-specific setup
268 ctx-reg jit-update-tib
270 ! Load new ds, rs registers
271 jit-restore-context ;
273 : jit-set-context ( -- )
274 ! Load context and parameter from datastack
276 EAX EAX alien-offset [+] MOV
277 EDX ds-reg -4 [+] MOV
280 ! Save ds, rs registers
284 ! Make the new context active
285 EAX jit-switch-context
287 ! Windows-specific setup
288 ctx-reg jit-update-seh
290 ! Twiddle stack for return
293 ! Store parameter to datastack
297 [ jit-set-context ] \ (set-context) define-sub-primitive
299 : jit-save-quot-and-param ( -- )
303 : jit-push-param ( -- )
308 : jit-start-context ( -- )
309 ! Create the new context in return-reg
313 "new_context" jit-call
315 jit-save-quot-and-param
317 ! Make the new context active
320 EAX jit-switch-context
324 ! Windows-specific setup
327 ! Push a fake return address
330 ! Jump to initial quotation
334 [ jit-start-context ] \ (start-context) define-sub-primitive
336 : jit-delete-current-context ( -- )
340 ESP 4 [+] ctx-reg MOV
341 "delete_context" jit-call ;
344 jit-delete-current-context
346 ] \ (set-context-and-delete) define-sub-primitive
348 : jit-start-context-and-delete ( -- )
352 ESP 4 [+] ctx-reg MOV
353 "reset_context" jit-call
355 jit-save-quot-and-param
356 ctx-reg jit-switch-context
363 jit-start-context-and-delete
364 ] \ (start-context-and-delete) define-sub-primitive