1 ! Copyright (C) 2006, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays generator generator.registers generator.fixup
4 hashtables kernel math namespaces sequences words
5 inference.state inference.backend inference.dataflow system
6 math.parser classes alien.arrays alien.c-types alien.strings
7 alien.structs alien.syntax cpu.architecture alien inspector
8 quotations assocs kernel.private threads continuations.private
9 libc combinators compiler.errors continuations layouts accessors
13 TUPLE: #alien-node < node return parameters abi ;
15 TUPLE: #alien-callback < #alien-node quot xt ;
17 TUPLE: #alien-indirect < #alien-node ;
19 TUPLE: #alien-invoke < #alien-node library function ;
21 : large-struct? ( ctype -- ? )
23 heap-size struct-small-enough? not
26 : alien-node-parameters* ( node -- seq )
28 swap return>> large-struct? [ "void*" prefix ] when ;
30 : alien-node-return* ( node -- ctype )
31 return>> dup large-struct? [ drop "void" ] when ;
33 : c-type-stack-align ( type -- align )
34 dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
36 : parameter-align ( n type -- n delta )
37 over >r c-type-stack-align align dup r> - ;
39 : parameter-sizes ( types -- total offsets )
40 #! Compute stack frame locations.
43 [ parameter-align drop dup , ] keep stack-size +
47 : return-size ( ctype -- n )
48 #! Amount of space we reserve for a return value.
49 dup large-struct? [ heap-size ] [ drop 0 ] if ;
51 : alien-stack-frame ( node -- n )
52 alien-node-parameters* parameter-sizes drop ;
54 : alien-invoke-frame ( node -- n )
55 #! One cell is temporary storage, temp@
56 dup return>> return-size
57 swap alien-stack-frame +
60 : set-stack-frame ( n -- )
61 dup [ frame-required ] when* \ stack-frame set ;
63 : with-stack-frame ( n quot -- )
66 f set-stack-frame ; inline
68 GENERIC: reg-size ( register-class -- n )
70 M: int-regs reg-size drop cell ;
72 M: single-float-regs reg-size drop 4 ;
74 M: double-float-regs reg-size drop 8 ;
76 GENERIC: reg-class-variable ( register-class -- symbol )
78 M: reg-class reg-class-variable ;
80 M: float-regs reg-class-variable drop float-regs ;
82 GENERIC: inc-reg-class ( register-class -- )
84 M: reg-class inc-reg-class
85 dup reg-class-variable inc
86 fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
88 M: float-regs inc-reg-class
90 fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
92 : reg-class-full? ( class -- ? )
93 [ reg-class-variable get ] [ param-regs length ] bi >= ;
95 : spill-param ( reg-class -- n reg-class )
97 >r reg-size stack-params +@ r>
100 : fastcall-param ( reg-class -- n reg-class )
101 [ reg-class-variable get ] [ inc-reg-class ] [ ] tri ;
103 : alloc-parameter ( parameter -- reg reg-class )
104 c-type-reg-class dup reg-class-full?
105 [ spill-param ] [ fastcall-param ] if
108 : (flatten-int-type) ( size -- )
109 cell /i "void*" c-type <repetition> % ;
111 GENERIC: flatten-value-type ( type -- )
113 M: object flatten-value-type , ;
115 M: struct-type flatten-value-type ( type -- )
116 stack-size cell align (flatten-int-type) ;
118 M: long-long-type flatten-value-type ( type -- )
119 stack-size cell align (flatten-int-type) ;
121 : flatten-value-types ( params -- params )
122 #! Convert value type structs to consecutive void*s.
126 [ parameter-align (flatten-int-type) ] keep
127 [ stack-size cell align + ] keep
132 : each-parameter ( parameters quot -- )
133 >r [ parameter-sizes nip ] keep r> 2each ; inline
135 : reverse-each-parameter ( parameters quot -- )
136 >r [ parameter-sizes nip ] keep r> 2reverse-each ; inline
138 : reset-freg-counts ( -- )
139 { int-regs float-regs stack-params } [ 0 swap set ] each ;
141 : with-param-regs ( quot -- )
142 #! In quot you can call alloc-parameter
143 [ reset-freg-counts call ] with-scope ; inline
145 : move-parameters ( node word -- )
146 #! Moves values from C stack to registers (if word is
147 #! %load-param-reg) and registers to C stack (if word is
150 alien-node-parameters*
152 r> [ >r alloc-parameter r> execute ] curry each-parameter ;
155 : if-void ( type true false -- )
156 pick "void" = [ drop nip call ] [ nip call ] if ; inline
158 : alien-invoke-stack ( node extra -- )
159 over parameters>> length + dup reify-curries
161 dup return>> "void" = 0 1 ?
162 swap produce-values ;
164 : param-prep-quot ( node -- quot )
165 parameters>> [ c-type c-type-unboxer-quot ] map spread>quot ;
167 : unbox-parameters ( offset node -- )
169 %prepare-unbox >r over + r> unbox-parameter
170 ] reverse-each-parameter drop ;
172 : prepare-box-struct ( node -- offset )
173 #! Return offset on C stack where to store unboxed
174 #! parameters. If the C function is returning a structure,
175 #! the first parameter is an implicit target area pointer,
176 #! so we need to use a different offset.
177 return>> dup large-struct?
178 [ heap-size %prepare-box-struct cell ] [ drop 0 ] if ;
180 : objects>registers ( node -- )
181 #! Generate code for unboxing a list of C types, then
182 #! generate code for moving these parameters to register on
183 #! architectures where parameters are passed in registers.
185 [ prepare-box-struct ] keep
186 [ unbox-parameters ] keep
187 \ %load-param-reg move-parameters
190 : box-return* ( node -- )
191 return>> [ ] [ box-return ] if-void ;
193 : callback-prep-quot ( node -- quot )
194 parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
196 : return-prep-quot ( node -- quot )
197 return>> [ [ ] ] [ c-type c-type-boxer-quot ] if-void ;
199 M: alien-invoke-error summary
201 "Words calling ``alien-invoke'' must be compiled with the optimizing compiler." ;
203 : pop-parameters ( -- seq )
204 pop-literal nip [ expand-constants ] map ;
206 : stdcall-mangle ( symbol node -- symbol )
208 swap parameters>> parameter-sizes drop
209 number>string 3append ;
211 TUPLE: no-such-library name ;
213 M: no-such-library summary
214 drop "Library not found" ;
216 M: no-such-library compiler-error-type
219 : no-such-library ( name -- )
220 \ no-such-library boa
221 compiling-word get compiler-error ;
223 TUPLE: no-such-symbol name ;
225 M: no-such-symbol summary
226 drop "Symbol not found" ;
228 M: no-such-symbol compiler-error-type
231 : no-such-symbol ( name -- )
233 compiling-word get compiler-error ;
235 : check-dlsym ( symbols dll -- )
237 dupd [ dlsym ] curry contains?
238 [ drop ] [ no-such-symbol ] if
240 dll-path no-such-library drop
243 : alien-invoke-dlsym ( node -- symbols dll )
244 dup function>> dup pick stdcall-mangle 2array
245 swap library>> library dup [ dll>> ] when
252 ! Compile-time parameters
253 pop-parameters >>parameters
254 pop-literal nip >>function
255 pop-literal nip >>library
256 pop-literal nip >>return
257 ! Quotation which coerces parameters to required types
258 dup param-prep-quot recursive-state get infer-quot
260 dup library>> library [ abi>> ] [ "cdecl" ] if* >>abi
263 ! Magic #: consume exactly the number of inputs
264 dup 0 alien-invoke-stack
265 ! Quotation which coerces return value to required type
266 return-prep-quot recursive-state get infer-quot
267 ] "infer" set-word-prop
269 M: #alien-invoke generate-node
270 dup alien-invoke-frame [
272 %prepare-alien-invoke
273 dup objects>registers
275 dup alien-invoke-dlsym %alien-invoke
281 M: alien-indirect-error summary
282 drop "Words calling ``alien-indirect'' must be compiled with the optimizing compiler." ;
285 ! Three literals and function pointer
289 ! Compile-time parameters
290 pop-literal nip >>abi
291 pop-parameters >>parameters
292 pop-literal nip >>return
293 ! Quotation which coerces parameters to required types
294 dup param-prep-quot [ dip ] curry recursive-state get infer-quot
297 ! Magic #: consume the function pointer, too
298 dup 1 alien-invoke-stack
299 ! Quotation which coerces return value to required type
300 return-prep-quot recursive-state get infer-quot
301 ] "infer" set-word-prop
303 M: #alien-indirect generate-node
304 dup alien-invoke-frame [
307 ! Save registers for GC
308 %prepare-alien-invoke
309 ! Save alien at top of stack to temporary storage
310 %prepare-alien-indirect
311 dup objects>registers
313 ! Call alien in temporary storage
320 ! Callbacks are registered in a global hashtable. If you clear
321 ! this hashtable, they will all be blown away by code GC, beware
324 [ H{ } clone callbacks set-global ] "alien.compiler" add-init-hook
326 : register-callback ( word -- ) callbacks get conjoin ;
328 M: alien-callback-error summary
329 drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ;
331 : callback-bottom ( node -- )
332 xt>> [ [ register-callback ] [ word-xt drop <alien> ] bi ] curry
333 recursive-state get infer-quot ;
337 #alien-callback new dup node,
338 pop-literal nip >>quot
339 pop-literal nip >>abi
340 pop-parameters >>parameters
341 pop-literal nip >>return
344 ] "infer" set-word-prop
346 : box-parameters ( node -- )
347 alien-node-parameters* [ box-parameter ] each-parameter ;
349 : registers>objects ( node -- )
351 dup \ %save-param-reg move-parameters
352 "nest_stacks" f %alien-invoke
356 TUPLE: callback-context ;
358 : current-callback 2 getenv ;
360 : wait-to-return ( token -- )
361 dup current-callback eq? [
367 : do-callback ( quot token -- )
371 wait-to-return ; inline
373 : callback-return-quot ( ctype -- quot )
375 { [ dup "void" = ] [ drop [ ] ] }
376 { [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
377 [ c-type c-type-unboxer-quot ]
380 : wrap-callback-quot ( node -- quot )
382 [ callback-prep-quot ]
384 [ callback-return-quot ] tri 3append ,
385 [ callback-context new do-callback ] %
388 : %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
390 : callback-unwind ( node -- n )
392 { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
393 { [ dup return>> large-struct? ] [ drop 4 ] }
397 : %callback-return ( node -- )
398 #! All the extra book-keeping for %unwind is only for x86.
399 #! On other platforms its an alias for %return.
400 dup alien-node-return*
401 [ %unnest-stacks ] [ %callback-value ] if-void
402 callback-unwind %unwind ;
404 : generate-callback ( node -- )
408 dup alien-stack-frame [
409 [ registers>objects ]
410 [ wrap-callback-quot %alien-callback ]
416 M: #alien-callback generate-node
417 end-basic-block generate-callback iterate-next ;