some FFI cleanups

library/compiler/alien.factor

@@ -38,6 +38,17 @@ USE: namespaces
 USE: parser
 USE: words
 USE: hashtables
+USE: strings
+
+! Command line parameters specify libraries to load.
+!
+! -library:<foo>:name=<soname> -- define a library <foo>, to be
+! loaded from the <soname> DLL.
+!
+! -library:<foo>:abi=stdcall -- define a library using the
+! stdcall ABI. This ABI is usually used on Win32. Any other abi
+! parameter, or a missing abi parameter indicates the cdecl ABI
+! should be used, which is common on Unix.
 
 BUILTIN: dll   15
 BUILTIN: alien 16
@@ -56,8 +67,8 @@ M: alien = ( obj obj -- ? )
         2drop f
     ] ifte ;
 
-: (library) ( name -- object )
+: library ( name -- object )
-    "libraries" get hash ;
+    dup [ "libraries" get hash ] when ;
 
 : load-dll ( library -- dll )
     "dll" get dup [
@@ -72,7 +83,6 @@ M: alien = ( obj obj -- ? )
         ] extend put
     ] bind ;
     
-SYMBOL: #c-invoke ( C ABI -- Unix and some Windows libs )
 SYMBOL: #cleanup ( unwind stack by parameter )
 
 SYMBOL: #c-call ( jump to raw address )
@@ -80,74 +90,81 @@ SYMBOL: #c-call ( jump to raw address )
 SYMBOL: #unbox ( move top of datastack to C stack )
 SYMBOL: #box ( move EAX to datastack )
 
-SYMBOL: #std-invoke ( stdcall ABI -- Win32 )
+: library-abi ( library -- abi )
+    library [ [ "abi" get ] bind ] [ "cdecl" ] ifte* ;
 
-: abi ( -- abi )
+: alien-symbol ( function library -- address )
-    "abi" get "stdcall" = #std-invoke #c-invoke ? ;
+    library [ [ load-dll ] bind dlsym ] [ dlsym-self ] ifte* ;
 
-: alien-function ( function library -- address abi )
+SYMBOL: #alien-invoke
-    [
-        (library) [ load-dll dlsym abi ] bind
-    ] [
-        dlsym-self #c-invoke
-    ] ifte* ;
 
-! These are set in the #c-invoke and #std-invoke dataflow IR
+! These are set in the #alien-invoke dataflow IR node.
-! nodes.
 SYMBOL: alien-returns
 SYMBOL: alien-parameters
 
+: set-alien-returns ( returns node -- )
+    [ dup alien-returns set ] bind
+    "void" = [
+        [ object ] produce-d 1 0 node-outputs
+    ] unless ;
+
+: set-alien-parameters ( parameters node -- )
+    [ dup alien-parameters set ] bind
+    [ drop object ] map dup dup ensure-d
+    length 0 node-inputs consume-d ;
+
+: alien-node ( returns params function library -- )
+    cons #alien-invoke dataflow,
+    [ set-alien-parameters ] keep
+    set-alien-returns ;
+
 : infer-alien ( -- )
     [ object object object object ] ensure-d
     dataflow-drop, pop-d literal-value
+    dataflow-drop, pop-d literal-value >r
     dataflow-drop, pop-d literal-value
-    dataflow-drop, pop-d literal-value alien-function >r
+    dataflow-drop, pop-d literal-value -rot
-    dataflow-drop, pop-d literal-value swap
+    r> swap alien-node ;
-    r> dataflow, [
-        alien-returns set
-        alien-parameters set
-    ] bind ;
 
-: unbox-parameter ( function -- )
+: box-parameter
-    dlsym-self #unbox swons , ;
+    c-type [
+        "width" get cell align
+        "unboxer" get
+    ] bind #unbox swons , ;
 
 : linearize-parameters ( params -- count )
     #! Generate code for boxing a list of C types.
     #! Return amount stack must be unwound by.
     [ alien-parameters get reverse ] bind 0 swap [
-        c-type [
+        box-parameter +
-            "width" get cell align +
-            "unboxer" get
-        ] bind unbox-parameter
     ] each ;
 
-: box-parameter ( function -- )
-    dlsym-self #box swons , ;
-
 : linearize-returns ( returns -- )
     [ alien-returns get ] bind dup "void" = [
         drop
     ] [
-        c-type [ "boxer" get ] bind box-parameter
+        c-type [ "boxer" get ] bind #box swons ,
     ] ifte ;
 
 : linearize-alien ( node -- )
     dup linearize-parameters >r
     dup [ node-param get ] bind #c-call swons ,
-    dup [ node-op get #c-invoke = ] bind
+    dup [ node-param get car "stdcall" = ] bind
-    r> swap [ #cleanup swons , ] [ drop ] ifte
+    r> swap [ drop ] [ #cleanup swons , ] ifte
     linearize-returns ;
 
-#c-invoke [ linearize-alien ] "linearizer" set-word-property
+#alien-invoke [ linearize-alien ] "linearizer" set-word-property
-
-#std-invoke [ linearize-alien ] "linearizer" set-word-property
 
 : alien-invoke ( ... returns library function parameters -- ... )
     #! Call a C library function.
     #! 'returns' is a type spec, and 'parameters' is a list of
     #! type specs. 'library' is an entry in the "libraries"
     #! namespace.
-    "alien-invoke cannot be interpreted." throw ;
+    [
+        "alien-invoke cannot be interpreted. " ,
+        "Either the compiler is disabled, " ,
+        "or the ``" , rot , "'' library is missing. " ,
+    ] make-string throw ;
 
 \ alien-invoke [ [ object object object object ] [ ] ]
 "infer-effect" set-word-property
@@ -157,4 +174,3 @@ SYMBOL: alien-parameters
 global [
     "libraries" get [ <namespace> "libraries" set ] unless
 ] bind
-

library/compiler/compiler.factor

@@ -28,6 +28,7 @@
 IN: compiler
 USE: inference
 USE: errors
+USE: generic
 USE: hashtables
 USE: kernel
 USE: lists
@@ -56,7 +57,11 @@ USE: words
     ] when
     dup word-parameter ;
 
-: (compile) ( word -- )
+GENERIC: (compile) ( word -- )
+
+M: word (compile) drop ;
+
+M: compound (compile) ( word -- )
     #! Should be called inside the with-compiler scope.
     compiling dataflow optimize linearize simplify generate ;
 

library/compiler/generator-x86.factor

@@ -128,16 +128,18 @@ USE: math
     compiled-offset 0 compile-cell 0 defer-xt rel-address
 ] "generator" set-word-property
 
-#c-call [ CALL JUMP-FIXUP ] "generator" set-word-property
+#c-call [
+    uncons alien-symbol CALL JUMP-FIXUP
+] "generator" set-word-property
 
 #unbox [
-    CALL JUMP-FIXUP
+    dlsym-self CALL JUMP-FIXUP
     EAX PUSH-R
 ] "generator" set-word-property
 
 #box [
     EAX PUSH-R
-    CALL JUMP-FIXUP
+    dlsym-self CALL JUMP-FIXUP
     4 ESP R+I
 ] "generator" set-word-property
 

library/compiler/generator.factor

@@ -81,7 +81,7 @@ SYMBOL: relocation-table
     dup [ compile-cell ] vector-each
     vector-length cell * ;
 
-: generate ( word linear -- )
+: (generate) ( word linear -- )
     #! Compile a word definition from linear IR.
     100 <vector> relocation-table set
     begin-assembly swap >r >r
@@ -90,4 +90,18 @@ SYMBOL: relocation-table
     r> set-compiled-cell
     r> set-compiled-cell ;
 
+SYMBOL: previous-offset
+
+: generate ( word linear -- )
+    #! If generation fails, reset compiled offset.
+    [
+        compiled-offset previous-offset set
+        (generate)
+    ] [
+        [
+            previous-offset get set-compiled-offset
+            rethrow
+        ] when*
+    ] catch ;
+
 #label [ save-xt ] "generator" set-word-property

library/hashtables.factor

@@ -83,13 +83,13 @@ PREDICATE: vector hashtable ( obj -- ? )
 
 : hash-each ( hash code -- )
     #! Apply the code to each key/value pair of the hashtable.
-    swap [ swap dup >r each r> ] vector-each drop ;
+    swap [ swap dup >r each r> ] vector-each drop ; inline
 
 : hash-subset ( hash code -- hash )
     #! Return a new hashtable containing all key/value pairs
     #! for which the predicate yielded a true value. The
     #! predicate must have stack effect ( obj -- ? ).
-    swap [ swap dup >r subset r> swap ] vector-map nip ;
+    swap [ swap dup >r subset r> swap ] vector-map nip ; inline
 
 : hash-keys ( hash -- list )
     #! Push a list of keys in a hashtable.

library/inference/words.factor

@@ -39,7 +39,7 @@ USE: words
 USE: hashtables
 USE: parser
 
-: with-dataflow ( param op [ in | out ] quot -- )
+: with-dataflow ( param op [ intypes outtypes ] quot -- )
     #! Take input parameters, execute quotation, take output
     #! parameters, add node. The quotation is called with the
     #! stack effect.

library/test/alien.factor

@@ -2,6 +2,7 @@ IN: scratchpad
 USE: alien
 USE: kernel
 USE: test
+USE: inference
 
 [ t ] [ 0 <alien> 0 <alien> = ] unit-test
 [ f ] [ 0 <alien> local-alien? ] unit-test
@@ -9,3 +10,13 @@ USE: test
 [ f ] [ 0 <alien> 1024 <alien> = ] unit-test
 [ f ] [ "hello" 1024 <alien> = ] unit-test
 [ t ] [ 1024 <local-alien> local-alien? ] unit-test
+
+: alien-inference-1
+    "void" "foobar" "boo" [ "short" "short" ] alien-invoke ;
+
+[ [ 2 | 0 ] ] [ [ alien-inference-1 ] infer old-effect ] unit-test
+
+: alien-inference-2
+    "int" "foobar" "boo" [ "short" "short" ] alien-invoke ;
+
+[ [ 2 | 1 ] ] [ [ alien-inference-2 ] infer old-effect ] unit-test

library/test/inference.factor

@@ -196,6 +196,8 @@ SYMBOL: sym-test
 
 [ [ 1 | 1 ] ] [ [ get ] infer old-effect ] unit-test
 
+[ [ 1 | 1 ] ] [ [ str>number ] infer old-effect ] unit-test
+
 ! Type inference
 
 [ [ [ object ] [ ] ] ] [ [ drop ] infer ] unit-test