VM: always use undecorated names when loading ffi functions

For win32, Factor tries four different function names when loading
stdcall and fastcall functions, in case decorated names are used in the
dll. It seems to not be necessary because a dll meant for 3rd party use
will always export undecorated
names (http://blogs.msdn.com/b/oldnewthing/archive/2004/01/12/57833.aspx).

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
 

basis/compiler/cfg/builder/alien/alien-docs.factor

@@ -1,5 +1,6 @@
-USING: help.markup help.syntax literals make multiline sequences
+USING: alien alien.libraries compiler.cfg.builder help.markup
-stack-checker.alien ;
+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"

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 -- ? )
+: check-dlsym ( symbol library -- )
-
-M: string dlsym-valid? dlsym ;
-
-M: array dlsym-valid? '[ _ dlsym ] any? ;
-
-: check-dlsym ( symbols 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 )
+: caller-linkage ( params -- symbol dll )
-    [ function>> ] [ parameters>> [ stack-size ] map-sum number>string ] bi
+    [ function>> ] [ library>> lookup-library ] bi
-    {
+    2dup check-dlsym library-dll ;
-        [ 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-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
+        needs-frame-pointer begin-word
-
-        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 ;

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
+    3 4 &: ffi_test_50 fastcall-ii-indirect
-    win32? [ &: @ffi_test_50@8 ] [ &: ffi_test_50 ] if
-    fastcall-ii-indirect
 ] unit-test
 
 [ 13 ] [
-    3 4 5
+    3 4 5 &: ffi_test_51 fastcall-iii-indirect
-    win32? [ &: @ffi_test_51@12 ] [ &: ffi_test_51 ] if
-    fastcall-iii-indirect
 ] unit-test
 
 mingw? [
     [ 13 ] [
-        3 4.0 5
+        3 4.0 5 &: ffi_test_52 fastcall-ifi-indirect
-        win32? [ &: @ffi_test_52@12 ] [ &: ffi_test_52 ] if
-        fastcall-ifi-indirect
     ] unit-test
 
     [ 19 ] [
-        3 4.0 5 6
+        3 4.0 5 6 &: ffi_test_53 fastcall-ifii-indirect
-        win32? [ &: @ffi_test_53@16 ] [ &: ffi_test_53 ] if
-        fastcall-ifii-indirect
     ] unit-test
 ] unless
 
 [ S{ test-struct-11 f 7 -1 } ]
 [
-    3 4
+    3 4 &: ffi_test_57 fastcall-struct-return-ii-indirect
-    win32? [ &: @ffi_test_57@8 ] [ &: ffi_test_57 ] if
-    fastcall-struct-return-ii-indirect
 ] unit-test
 
 [ S{ test-struct-11 f 7 -3 } ]
 [
-    3 4 7
+    3 4 7 &: ffi_test_58 fastcall-struct-return-iii-indirect
-    win32? [ &: @ffi_test_58@12 ] [ &: ffi_test_58 ] if
-    fastcall-struct-return-iii-indirect
 ] unit-test
 
 : fastcall-ii-callback ( -- ptr )

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);
+  FACTOR_ASSERT(TAG(symbol) == BYTE_ARRAY_TYPE);
-  if (type == BYTE_ARRAY_TYPE) {
+  symbol_char* name = alien_offset(symbol);
-
+  cell sym = ffi_dlsym_raw(d, name);
-    symbol_char* name = alien_offset(symbol);
+  sym = toc ? FUNCTION_TOC_POINTER(sym) : FUNCTION_CODE_POINTER(sym);
-    cell sym = ffi_dlsym_raw(d, name);
+  return sym ? sym : undef;
-    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;
 }
 
 cell factor_vm::compute_vm_address(cell arg) {

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