diff --git a/Nmakefile b/Nmakefile index 9085867b0d..d7a5d26122 100644 --- a/Nmakefile +++ b/Nmakefile @@ -116,7 +116,7 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \ 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) @@ -160,6 +160,9 @@ clean: 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 diff --git a/basis/compiler/cfg/builder/alien/alien-docs.factor b/basis/compiler/cfg/builder/alien/alien-docs.factor index fa22861bca..3586f654a9 100644 --- a/basis/compiler/cfg/builder/alien/alien-docs.factor +++ b/basis/compiler/cfg/builder/alien/alien-docs.factor @@ -1,5 +1,6 @@ -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 << @@ -16,11 +17,29 @@ USING: compiler.cfg.builder.alien make prettyprint ; ; >> +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" diff --git a/basis/compiler/cfg/builder/alien/alien.factor b/basis/compiler/cfg/builder/alien/alien.factor index ff500fb809..ad75cd38b9 100644 --- a/basis/compiler/cfg/builder/alien/alien.factor +++ b/basis/compiler/cfg/builder/alien/alien.factor @@ -59,38 +59,21 @@ IN: 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>> [ ] [ @@ -186,10 +169,7 @@ M: #alien-assembly emit-node ( node -- ) 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 ] @@ -197,6 +177,5 @@ M: #alien-callback emit-node [ params>> emit-callback-return ] [ params>> callback-stack-cleanup ] } cleave - basic-block get [ end-word ] when ] with-cfg-builder ; diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index d3e1dfbf5d..0e388f2407 100755 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -718,46 +718,32 @@ mingw? [ : 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 ) diff --git a/vm/code_blocks.cpp b/vm/code_blocks.cpp index d3a2f88f4d..0eb1ed338f 100644 --- a/vm/code_blocks.cpp +++ b/vm/code_blocks.cpp @@ -156,28 +156,11 @@ cell factor_vm::compute_dlsym_address(array* parameters, 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(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) { diff --git a/vm/ffi_test.def b/vm/ffi_test.def new file mode 100644 index 0000000000..7afa9a949c --- /dev/null +++ b/vm/ffi_test.def @@ -0,0 +1,14 @@ +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