rc $<
libfactor-ffi-test.dll: vm/ffi_test.obj
- link $(LINK_FLAGS) /out:libfactor-ffi-test.dll /dll vm/ffi_test.obj
+ link $(LINK_FLAGS) /out:libfactor-ffi-test.dll /dll /def:vm\ffi_test.def vm/ffi_test.obj
factor.dll.lib: $(DLL_OBJS)
link $(LINK_FLAGS) /implib:factor.dll.lib /out:factor.dll /dll $(DLL_OBJS)
if exist factor.exe del factor.exe
if exist factor.dll del factor.dll
if exist factor.dll.lib del factor.dll.lib
+ if exist libfactor-ffi-test.dll del libfactor-ffi-test.dll
+ if exist libfactor-ffi-test.exp del libfactor-ffi-test.exp
+ if exist libfactor-ffi-test.lib del libfactor-ffi-test.lib
.PHONY: all default x86-32 x86-64 x86-32-vista x86-64-vista clean
-USING: help.markup help.syntax literals make multiline sequences
-stack-checker.alien ;
+USING: alien alien.libraries compiler.cfg.builder help.markup
+help.syntax literals make multiline sequences stack-checker.alien
+strings ;
IN: compiler.cfg.builder.alien
<<
;
>>
+HELP: caller-linkage
+{ $values
+ { "params" alien-node-params }
+ { "symbol" string }
+ { "dll" dll }
+}
+{ $description "This word gets the name and library to use when linking to a function in a dynamically loaded dll. It is assumed that the library exports the undecorated name, regardless of calling convention." } ;
+
HELP: caller-return
{ $values { "params" alien-node-params } }
{ $description "If the last alien call returns a value, then this word will emit an instruction to the current sequence being constructed by " { $link make } " that boxes it." }
{ $examples { $unchecked-example $[ ex-caller-return ] } } ;
+HELP: check-dlsym
+{ $values { "symbol" string } { "library" library } }
+{ $description "Checks that a symbol with the given name exists in the given library. Throws an error if not." } ;
+
HELP: unbox-parameters
{ $values { "parameters" sequence } { "vregs" sequence } { "reps" sequence } }
{ $description "Unboxes a sequence of parameters to send to an ffi function." } ;
+
+ARTICLE: "compiler.cfg.builder.alien"
+"CFG node emitter for alien nodes"
+"The " { $vocab-link "compiler.cfg.builder.alien" } " vocab implements " { $link emit-node } " methods for alien nodes." ;
+
+ABOUT: "compiler.cfg.builder.alien"
[ stack-params get ] dip [ return>> ] [ abi>> ] bi stack-cleanup
stack-params get ;
-GENERIC# dlsym-valid? 1 ( symbols dll -- ? )
-
-M: string dlsym-valid? dlsym ;
-
-M: array dlsym-valid? '[ _ dlsym ] any? ;
-
-: check-dlsym ( symbols library -- )
+: check-dlsym ( symbol library -- )
{
{ [ dup library-dll dll-valid? not ] [
[ library-dll dll-path ] [ dlerror>> ] bi
cfg get word>> no-such-library-error drop
] }
- { [ 2dup library-dll dlsym-valid? not ] [
+ { [ 2dup library-dll dlsym not ] [
drop dlerror cfg get word>> no-such-symbol-error
] }
[ 2drop ]
} cond ;
-: decorated-symbol ( params -- symbols )
- [ function>> ] [ parameters>> [ stack-size ] map-sum number>string ] bi
- {
- [ drop ]
- [ "@" glue ]
- [ "@" glue "_" prepend ]
- [ "@" glue "@" prepend ]
- } 2cleave
- 4array ;
-
-: caller-linkage ( params -- symbols dll )
- [ dup abi>> callee-cleanup? [ decorated-symbol ] [ function>> ] if ]
- [ library>> lookup-library ]
- bi 2dup check-dlsym library-dll ;
+: caller-linkage ( params -- symbol dll )
+ [ function>> ] [ library>> lookup-library ] bi
+ 2dup check-dlsym library-dll ;
: caller-return ( params -- )
return>> [ ] [
M: #alien-callback emit-node
dup params>> xt>> dup
[
- needs-frame-pointer
-
- begin-word
-
+ needs-frame-pointer begin-word
{
[ params>> callee-parameters ##callback-inputs, ]
[ params>> box-parameters ]
[ params>> emit-callback-return ]
[ params>> callback-stack-cleanup ]
} cleave
-
basic-block get [ end-word ] when
] with-cfg-builder ;
: fastcall-struct-return-iii-indirect ( x y z ptr -- result )
test-struct-11 { int int int } fastcall alien-indirect ;
-: win32? ( -- ? ) os windows? cpu x86.32? and ;
-
[ 8 ] [
- 3 4
- win32? [ &: @ffi_test_50@8 ] [ &: ffi_test_50 ] if
- fastcall-ii-indirect
+ 3 4 &: ffi_test_50 fastcall-ii-indirect
] unit-test
[ 13 ] [
- 3 4 5
- win32? [ &: @ffi_test_51@12 ] [ &: ffi_test_51 ] if
- fastcall-iii-indirect
+ 3 4 5 &: ffi_test_51 fastcall-iii-indirect
] unit-test
mingw? [
[ 13 ] [
- 3 4.0 5
- win32? [ &: @ffi_test_52@12 ] [ &: ffi_test_52 ] if
- fastcall-ifi-indirect
+ 3 4.0 5 &: ffi_test_52 fastcall-ifi-indirect
] unit-test
[ 19 ] [
- 3 4.0 5 6
- win32? [ &: @ffi_test_53@16 ] [ &: ffi_test_53 ] if
- fastcall-ifii-indirect
+ 3 4.0 5 6 &: ffi_test_53 fastcall-ifii-indirect
] unit-test
] unless
[ S{ test-struct-11 f 7 -1 } ]
[
- 3 4
- win32? [ &: @ffi_test_57@8 ] [ &: ffi_test_57 ] if
- fastcall-struct-return-ii-indirect
+ 3 4 &: ffi_test_57 fastcall-struct-return-ii-indirect
] unit-test
[ S{ test-struct-11 f 7 -3 } ]
[
- 3 4 7
- win32? [ &: @ffi_test_58@12 ] [ &: ffi_test_58 ] if
- fastcall-struct-return-iii-indirect
+ 3 4 7 &: ffi_test_58 fastcall-struct-return-iii-indirect
] unit-test
: fastcall-ii-callback ( -- ptr )
if (d != NULL && !d->handle)
return undef;
- cell type = TAG(symbol);
- if (type == BYTE_ARRAY_TYPE) {
-
- symbol_char* name = alien_offset(symbol);
- cell sym = ffi_dlsym_raw(d, name);
- sym = toc ? FUNCTION_TOC_POINTER(sym) : FUNCTION_CODE_POINTER(sym);
- return sym ? sym : undef;
-
- } else if (type == ARRAY_TYPE) {
-
- array* names = untag<array>(symbol);
- for (cell i = 0; i < array_capacity(names); i++) {
- symbol_char* name = alien_offset(array_nth(names, i));
- cell sym = ffi_dlsym_raw(d, name);
- sym = toc ? FUNCTION_TOC_POINTER(sym) : FUNCTION_CODE_POINTER(sym);
- if (sym)
- return sym;
- }
- return undef;
-
- }
- return -1;
+ FACTOR_ASSERT(TAG(symbol) == BYTE_ARRAY_TYPE);
+ symbol_char* name = alien_offset(symbol);
+ cell sym = ffi_dlsym_raw(d, name);
+ sym = toc ? FUNCTION_TOC_POINTER(sym) : FUNCTION_CODE_POINTER(sym);
+ return sym ? sym : undef;
}
cell factor_vm::compute_vm_address(cell arg) {
--- /dev/null
+EXPORTS
+ ffi_test_0
+ ffi_test_18
+ ffi_test_19
+ ffi_test_49
+ ffi_test_50
+ ffi_test_51
+ ffi_test_52
+ ffi_test_53
+ ffi_test_54
+ ffi_test_55
+ ffi_test_56
+ ffi_test_57
+ ffi_test_58