accessing global variables with FFI

TODO.FACTOR.txt

@@ -24,10 +24,7 @@
 
 + compiler/ffi:
 
-- ffi global variables, and get rid of factor_str_error hack
 - box/unbox_signed/unsigned_8
-- unsigned versions of all alien accessors and setters
-
 - [ [ dup call ] dup call ] infer hangs
 - ffi unicode strings: null char security hole
 - utf16 string boxing

library/compiler/alien.factor

@@ -75,8 +75,6 @@ M: alien unparse ( obj -- str )
     
 SYMBOL: #cleanup ( unwind stack by parameter )
 
-SYMBOL: #c-call ( jump to raw address )
-
 SYMBOL: #unbox ( move top of datastack to C stack )
 SYMBOL: #box ( move EAX to datastack )
 
@@ -84,6 +82,7 @@ SYMBOL: #box ( move EAX to datastack )
     library [ [ "abi" get ] bind ] [ "cdecl" ] ifte* ;
 
 SYMBOL: #alien-invoke
+SYMBOL: #alien-global
 
 ! These are set in the #alien-invoke dataflow IR node.
 SYMBOL: alien-returns
@@ -100,22 +99,36 @@ SYMBOL: alien-parameters
     [ drop object ] map dup dup ensure-d
     length 0 node-inputs consume-d ;
 
-: alien-node ( returns params function library -- )
+: ensure-dlsym ( symbol library -- ) load-dll dlsym drop ;
+
+: alien-invoke-node ( returns params function library -- )
     #! We should fail if the library does not exist, so that
     #! compilation does not keep trying to compile FFI words
     #! over and over again if the library is not loaded.
-    2dup load-dll dlsym drop
+    2dup ensure-dlsym
     cons #alien-invoke dataflow,
     [ set-alien-parameters ] keep
     set-alien-returns ;
 
-: infer-alien ( -- )
+: infer-alien-invoke ( -- )
-    [ string string string general-list ] ensure-d
+    \ alien-invoke "infer-effect" word-prop car ensure-d
-    dataflow-drop, pop-d literal-value
+    pop-literal
-    dataflow-drop, pop-d literal-value >r
+    pop-literal >r
-    dataflow-drop, pop-d literal-value
+    pop-literal
-    dataflow-drop, pop-d literal-value -rot
+    pop-literal -rot
-    r> swap alien-node ;
+    r> swap alien-invoke-node ;
+
+: alien-global-node ( type name library -- )
+    2dup ensure-dlsym
+    cons #alien-global dataflow,
+    set-alien-returns ;
+
+: infer-alien-global ( -- )
+    \ alien-global "infer-effect" word-prop car ensure-d
+    pop-literal
+    pop-literal
+    pop-literal -rot
+    alien-global-node ;
 
 : box-parameter
     c-type [
@@ -137,14 +150,20 @@ SYMBOL: alien-parameters
         c-type [ "boxer" get ] bind #box swons ,
     ] ifte ;
 
-: linearize-alien ( node -- )
+: linearize-alien-invoke ( node -- )
     dup linearize-parameters >r
-    dup [ node-param get ] bind #c-call swons ,
+    dup [ node-param get ] bind #alien-invoke swons ,
     dup [ node-param get cdr library-abi "stdcall" = ] bind
     r> swap [ drop ] [ #cleanup swons , ] ifte
     linearize-returns ;
 
-#alien-invoke [ linearize-alien ] "linearizer" set-word-prop
+#alien-invoke [ linearize-alien-invoke ] "linearizer" set-word-prop
+
+: linearize-alien-global ( node -- )
+    dup [ node-param get ] bind #alien-global swons ,
+    linearize-returns ;
+
+#alien-global [ linearize-alien-global ] "linearizer" set-word-prop
 
 TUPLE: alien-error lib ;
 
@@ -152,7 +171,7 @@ C: alien-error ( lib -- ) [ set-alien-error-lib ] keep ;
 
 M: alien-error error. ( error -- )
     [
-        "alien-invoke cannot be interpreted. " ,
+        "C library interface words cannot be interpreted. " ,
         "Either the compiler is disabled, " ,
         "or the ``" , alien-error-lib ,
         "'' library is missing." ,
@@ -165,10 +184,21 @@ M: alien-error error. ( error -- )
     #! namespace.
     rot <alien-error> throw ;
 
-\ alien-invoke [ [ object object object object ] [ ] ]
+\ alien-invoke [ [ string string string general-list ] [ ] ]
 "infer-effect" set-word-prop
 
-\ alien-invoke [ infer-alien ] "infer" set-word-prop
+\ alien-invoke [ infer-alien-invoke ] "infer" set-word-prop
+
+: alien-global ( type library name -- value )
+    #! Fetch the value of C global variable.
+    #! 'type' is a type spec. 'library' is an entry in the
+    #! "libraries" namespace.
+    swap <alien-error> throw ;
+
+\ alien-global [ [ string string string ] [ object ] ]
+"infer-effect" set-word-prop
+
+\ alien-global [ infer-alien-global ] "infer" set-word-prop
 
 global [
     "libraries" get [ <namespace> "libraries" set ] unless

library/compiler/x86/generator.factor

@@ -55,10 +55,14 @@ math memory namespaces words ;
     compiled-offset swap set-compiled-cell ( fixup -- )
 ] "generator" set-word-prop
 
-#c-call [
+#alien-invoke [
     uncons load-dll 2dup dlsym CALL t rel-dlsym
 ] "generator" set-word-prop
 
+#alien-global [
+    uncons load-dll 2dup dlsym EAX swap unit MOV f rel-dlsym
+] "generator" set-word-prop
+
 #unbox [
     dup f dlsym CALL f t rel-dlsym
     EAX PUSH

library/inference/branches.factor

@@ -227,7 +227,7 @@ SYMBOL: cloned
 USE: kernel-internals
 
 : static-dispatch ( vtable -- )
-    >r dataflow-drop, pop-d literal-value r>
+    >r pop-literal r>
     dup literal-value swap value-recursion
     >r vector-nth r> <literal> infer-quot-value ;
 

library/inference/inference.factor

@@ -79,6 +79,9 @@ M: computed literal-value ( value -- )
     "A literal value was expected where a computed value was"
     " found: " rot unparse cat3 inference-error ;
 
+: pop-literal ( -- obj )
+    dataflow-drop, pop-d literal-value ;
+
 : (ensure-types) ( typelist n stack -- )
     pick [
         3dup >r >r car r> r> vector-nth value-class-and

library/inference/types.factor

@@ -12,7 +12,7 @@ lists math namespaces strings vectors words stdio prettyprint ;
     peek-next-d value-class builtin-supertypes length 1 = and ;
 
 : fast-slot ( -- )
-    dataflow-drop, pop-d literal-value
+    pop-literal
     peek-d value-class builtin-supertypes cons
     \ slot [ [ object ] [ object ] ] (consume/produce) ;
 

native/unix/io.c

@@ -303,9 +303,3 @@ void collect_io_tasks(void)
 		COPY_OBJECT(write_io_tasks[i].callbacks);
 	}
 }
-
-/* FFI calls this */
-char* factor_str_error(void)
-{
-	return strerror(errno);
-}