1 ! Copyright (C) 2005, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: locals alien.c-types alien.libraries alien.syntax arrays
4 kernel fry math namespaces sequences system layouts io
5 vocabs.loader accessors init combinators command-line make
6 compiler compiler.units compiler.constants compiler.alien
7 compiler.codegen compiler.codegen.fixup
8 compiler.cfg.instructions compiler.cfg.builder
9 compiler.cfg.intrinsics compiler.cfg.stack-frame
10 cpu.x86.assembler cpu.x86.assembler.operands cpu.x86
12 FROM: layouts => cell ;
15 M: x86.32 machine-registers
17 { int-regs { EAX ECX EDX EBP EBX } }
18 { float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } }
21 M: x86.32 ds-reg ESI ;
22 M: x86.32 rs-reg EDI ;
23 M: x86.32 stack-reg ESP ;
24 M: x86.32 frame-reg EBP ;
25 M: x86.32 temp-reg ECX ;
27 M: x86.32 %mov-vm-ptr ( reg -- )
28 0 MOV 0 rc-absolute-cell rel-vm ;
30 M: x86.32 %vm-field-ptr ( dst field -- )
31 [ 0 MOV ] dip vm-field-offset rc-absolute-cell rel-vm ;
34 stack-frame get extra-stack-space dup 16 assert= + stack@ ;
36 M: x86.32 extra-stack-space calls-vm?>> 16 0 ? ;
39 drop HEX: ffffffff [+] card-mark <byte> MOV
41 rc-absolute-cell rel-cards-offset
45 drop HEX: ffffffff [+] card-mark <byte> MOV
47 rc-absolute-cell rel-decks-offset
50 M:: x86.32 %dispatch ( src temp -- )
51 ! Load jump table base.
52 temp src HEX: ffffffff [+] LEA
53 building get length :> start
54 0 rc-absolute-cell rel-here
57 building get length :> end
58 ! Fix up the displacement above
60 [ end start - + building get dup pop* push ]
64 M: x86.32 pic-tail-reg EBX ;
66 M: x86.32 reserved-stack-space 4 cells ;
68 M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
70 : save-vm-ptr ( n -- )
71 stack@ 0 MOV 0 rc-absolute-cell rel-vm ;
73 M: x86.32 return-struct-in-registers? ( c-type -- ? )
75 [ return-in-registers?>> ]
76 [ heap-size { 1 2 4 8 } member? ] bi
77 os { linux netbsd solaris } member? not
80 : struct-return@ ( n -- operand )
81 [ next-stack@ ] [ stack-frame get params>> local@ ] if* ;
83 ! On x86, parameters are never passed in registers.
84 M: int-regs return-reg drop EAX ;
85 M: int-regs param-regs drop { } ;
86 M: float-regs param-regs drop { } ;
88 GENERIC: load-return-reg ( src rep -- )
89 GENERIC: store-return-reg ( dst rep -- )
91 M: int-rep load-return-reg drop EAX swap MOV ;
92 M: int-rep store-return-reg drop EAX MOV ;
94 M: float-rep load-return-reg drop FLDS ;
95 M: float-rep store-return-reg drop FSTPS ;
97 M: double-rep load-return-reg drop FLDL ;
98 M: double-rep store-return-reg drop FSTPL ;
100 M: x86.32 %prologue ( n -- )
102 0 PUSH rc-absolute-cell rel-this
103 3 cells - decr-stack-reg ;
105 M: x86.32 %load-param-reg
107 [ [ EAX ] dip local@ MOV ] dip
110 M: x86.32 %save-param-reg 3drop ;
112 : (%box) ( n rep -- )
113 #! If n is f, push the return register onto the stack; we
114 #! are boxing a return value of a C function. If n is an
115 #! integer, push [ESP+n] on the stack; we are boxing a
116 #! parameter being passed to a callback from C.
117 over [ [ next-stack@ ] dip load-return-reg ] [ 2drop ] if ;
119 M:: x86.32 %box ( n rep func -- )
121 rep rep-size save-vm-ptr
122 0 stack@ rep store-return-reg
123 func f %alien-invoke ;
125 : (%box-long-long) ( n -- )
127 EDX over next-stack@ MOV
128 EAX swap cell - next-stack@ MOV
131 M: x86.32 %box-long-long ( n func -- )
132 [ (%box-long-long) ] dip
138 M:: x86.32 %box-large-struct ( n c-type -- )
139 EDX n struct-return@ LEA
141 4 stack@ c-type heap-size MOV
143 "from_value_struct" f %alien-invoke ;
145 M: x86.32 %prepare-box-struct ( -- )
146 ! Compute target address for value struct return
147 EAX f struct-return@ LEA
148 ! Store it as the first parameter
151 M: x86.32 %box-small-struct ( c-type -- )
152 #! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
154 8 stack@ swap heap-size MOV
157 "from_small_struct" f %alien-invoke ;
159 M: x86.32 %pop-stack ( n -- )
160 EAX swap ds-reg reg-stack MOV ;
162 M: x86.32 %pop-context-stack ( -- )
163 temp-reg %load-context-datastack
166 temp-reg [] bootstrap-cell SUB ;
168 : call-unbox-func ( func -- )
173 M: x86.32 %unbox ( n rep func -- )
174 #! The value being unboxed must already be in EAX.
175 #! If n is f, we're unboxing a return value about to be
176 #! returned by the callback. Otherwise, we're unboxing
177 #! a parameter to a C function about to be called.
179 ! Store the return value on the C stack
180 over [ [ local@ ] dip store-return-reg ] [ 2drop ] if ;
182 M: x86.32 %unbox-long-long ( n func -- )
184 ! Store the return value on the C stack
187 [ 4 + local@ EDX MOV ] bi
190 : %unbox-struct-1 ( -- )
191 #! Alien must be in EAX.
194 "alien_offset" f %alien-invoke
198 : %unbox-struct-2 ( -- )
199 #! Alien must be in EAX.
202 "alien_offset" f %alien-invoke
208 M: x86 %unbox-small-struct ( size -- )
209 #! Alien must be in EAX.
210 heap-size cell align cell /i {
211 { 1 [ %unbox-struct-1 ] }
212 { 2 [ %unbox-struct-2 ] }
215 M:: x86.32 %unbox-large-struct ( n c-type -- )
216 ! Alien must be in EAX.
217 ! Compute destination address
220 8 stack@ c-type heap-size MOV
223 "to_value_struct" f %alien-invoke ;
225 M: x86.32 %nest-stacks ( -- )
227 "nest_stacks" f %alien-invoke ;
229 M: x86.32 %unnest-stacks ( -- )
231 "unnest_stacks" f %alien-invoke ;
233 M: x86.32 %prepare-alien-indirect ( -- )
238 "pinned_alien_offset" f %alien-invoke
241 M: x86.32 %alien-indirect ( -- )
244 M: x86.32 %alien-callback ( quot -- )
245 EAX EDX %restore-context
246 EAX swap %load-reference
247 EAX quot-entry-point-offset [+] CALL
248 EAX EDX %save-context ;
250 M: x86.32 %callback-value ( ctype -- )
254 ! Restore data/call/retain stacks
255 "unnest_stacks" f %alien-invoke
256 ! Place former top of data stack back in EAX
261 GENERIC: float-function-param ( stack-slot dst src -- )
263 M:: spill-slot float-function-param ( stack-slot dst src -- )
264 ! We can clobber dst here since its going to contain the
266 dst src double-rep %copy
267 stack-slot dst double-rep %copy ;
269 M: register float-function-param
270 nip double-rep %copy ;
272 : float-function-return ( reg -- )
277 M:: x86.32 %unary-float-function ( dst src func -- )
278 ESP -16 [+] dst src float-function-param
280 func "libm" load-library %alien-invoke
281 dst float-function-return ;
283 M:: x86.32 %binary-float-function ( dst src1 src2 func -- )
284 ESP -16 [+] dst src1 float-function-param
285 ESP -8 [+] dst src2 float-function-param
287 func "libm" load-library %alien-invoke
288 dst float-function-return ;
290 : stdcall? ( params -- ? )
293 : funny-large-struct-return? ( params -- ? )
294 #! MINGW ABI incompatibility disaster
295 [ return>> large-struct? ]
296 [ abi>> "mingw" = os windows? not or ]
299 M: x86.32 %cleanup ( params -- )
300 #! a) If we just called an stdcall function in Windows, it
301 #! cleaned up the stack frame for us. But we don't want that
302 #! so we 'undo' the cleanup since we do that in %epilogue.
303 #! b) If we just called a function returning a struct, we
306 { [ dup stdcall? ] [ drop ESP stack-frame get params>> SUB ] }
307 { [ dup funny-large-struct-return? ] [ drop EAX PUSH ] }
311 M:: x86.32 %call-gc ( gc-root-count temp -- )
312 temp gc-root-base special@ LEA
314 4 stack@ gc-root-count MOV
316 "inline_gc" f %alien-invoke ;
318 M: x86.32 dummy-stack-params? f ;
320 M: x86.32 dummy-int-params? f ;
322 M: x86.32 dummy-fp-params? f ;
324 M: x86.32 callback-return-rewind ( params -- n )
325 #! a) If the callback is stdcall, we have to clean up the
326 #! caller's stack frame.
327 #! b) If the callback is returning a large struct, we have
330 { [ dup stdcall? ] [ <alien-stack-frame> [ params>> ] [ return>> ] bi + ] }
331 { [ dup funny-large-struct-return? ] [ drop 4 ] }
336 M: object flatten-value-type (flatten-int-type) ;