Starting work on callbacks

TODO.FACTOR.txt

@@ -44,3 +44,9 @@
 - document tools
 - document conventions
 - new turtle graphics tutorial
+- better line spacing in ui
+- use vertex arrays and display lists to speed up ui
+- tabular formatting
+- float intrinsics
+- complex float type
+- complex float intrinsics

library/alien/alien-callback.factor

@@ -0,0 +1,52 @@
+! Copyright (C) 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: alien
+USING: compiler-backend compiler-frontend errors generic
+hashtables inference inspector kernel lists namespaces sequences
+strings words ;
+
+TUPLE: alien-callback return parameters word xt ;
+C: alien-callback make-node ;
+
+TUPLE: alien-callback-error ;
+
+M: alien-callback-error summary ( error -- )
+    drop "Words calling ``alien-callback'' cannot run in the interpreter. Compile the caller word and try again." ;
+
+: alien-callback ( ... return parameters word -- ... )
+    #! Call a C library function.
+    #! 'return' is a type spec, and 'parameters' is a list of
+    #! type specs. 'library' is an entry in the "libraries"
+    #! namespace.
+    <alien-callback-error> throw ;
+
+: check-callback ( node -- )
+    dup alien-callback-word unit infer dup first
+    pick alien-callback-parameters length = >r
+    second swap alien-callback-return "void" = 0 1 ? = r> and [
+        "Callback word stack effect does not match callback signature" throw
+    ] unless ;
+
+: callback-bottom ( node -- )
+    alien-callback-xt [ word-xt <alien> ] curry infer-quot ;
+
+\ alien-callback [ [ string object word ] [ alien ] ]
+"infer-effect" set-word-prop
+
+\ alien-callback [
+    empty-node <alien-callback>
+    pop-literal nip over set-alien-callback-word
+    pop-literal nip over set-alien-callback-parameters
+    pop-literal nip over set-alien-callback-return
+    gensym over set-alien-callback-xt
+    dup check-callback
+    dup node,
+    callback-bottom
+] "infer" set-word-prop
+
+: linearize-callback ( node -- linear )
+    [ %prologue , alien-callback-word %jump , ] { } make ;
+
+M: alien-callback linearize* ( node -- )
+    dup linearize-callback over alien-callback-xt
+    linearized get set-hash linearize-next ;

library/alien/alien-invoke.factor

@@ -6,24 +6,20 @@ compiler-frontend errors generic hashtables inference inspector
 io kernel kernel-internals lists math namespaces parser
 prettyprint sequences strings words ;
 
-! USAGE:
-! 
-! Command line parameters given to the runtime specify libraries
-! to load.
-!
-! -libraries:<foo>:name=<soname> -- define a library <foo>, to be
-! loaded from the <soname> DLL.
-!
-! -libraries:<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.
+TUPLE: alien-invoke library function return parameters ;
+C: alien-invoke make-node ;
 
-! FFI code does not run in the interpreter.
+: alien-invoke-stack ( node -- )
+    dup alien-invoke-parameters length over consume-values
+    dup alien-invoke-return "void" = 0 1 ? swap produce-values ;
 
-TUPLE: alien-error library symbol ;
+: alien-invoke-dlsym ( node -- symbol dll )
+    dup alien-invoke-function swap alien-invoke-library
+    load-library ;
 
-M: alien-error summary ( error -- )
+TUPLE: alien-invoke-error library symbol ;
+
+M: alien-invoke-error summary ( error -- )
     drop "Words calling ``alien-invoke'' cannot run in the interpreter. Compile the caller word and try again." ;
 
 : alien-invoke ( ... return library function parameters -- ... )
@@ -31,30 +27,21 @@ M: alien-error summary ( error -- )
     #! 'return' is a type spec, and 'parameters' is a list of
     #! type specs. 'library' is an entry in the "libraries"
     #! namespace.
-    drop <alien-error> throw ;
+    pick pick <alien-invoke-error> throw ;
 
-TUPLE: alien-node return parameters ;
-C: alien-node make-node ;
+\ alien-invoke [ [ string object string object ] [ ] ]
+"infer-effect" set-word-prop
 
-: set-alien-return ( return node -- )
-    2dup set-alien-node-return
-    swap "void" = [ 1 over produce-values ] unless drop ;
-
-: set-alien-parameters ( parameters node -- )
-    2dup set-alien-node-parameters
-    >r length r> consume-values ;
-
-: ensure-dlsym ( symbol library -- ) load-library dlsym drop ;
-
-: alien-node ( return 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 ensure-dlsym
-    cons param-node <alien-node>
-    [ set-alien-parameters ] keep
-    [ set-alien-return ] keep
-    node, ;
+\ alien-invoke [
+    empty-node <alien-invoke>
+    pop-literal nip over set-alien-invoke-parameters
+    pop-literal nip over set-alien-invoke-function
+    pop-literal nip over set-alien-invoke-library
+    pop-literal nip over set-alien-invoke-return
+    dup alien-invoke-dlsym dlsym drop
+    dup alien-invoke-stack
+    node,
+] "infer" set-word-prop
 
 : parameter-size c-size cell align ;
 
@@ -108,20 +95,22 @@ C: alien-node make-node ;
     dup unbox-parameters load-parameters ;
 
 : linearize-return ( node -- )
-    alien-node-return dup "void" = [
+    alien-invoke-return dup "void" = [
         drop
     ] [
         c-type [ "reg-class" get "boxer" get ] bind call ,
     ] if ;
 
 : linearize-cleanup ( node -- )
-    node-param cdr library-abi "stdcall" = [
-        dup alien-node-parameters stack-space %cleanup ,
-    ] unless ;
+    dup alien-invoke-library library-abi "stdcall" = [
+        drop
+    ] [
+        alien-invoke-parameters stack-space %cleanup ,
+    ] if ;
 
-M: alien-node linearize* ( node -- )
-    dup alien-node-parameters linearize-parameters
-    dup node-param uncons %alien-invoke ,
+M: alien-invoke linearize* ( node -- )
+    dup alien-invoke-parameters linearize-parameters
+    dup alien-invoke-dlsym %alien-invoke ,
     dup linearize-cleanup
     dup linearize-return
     linearize-next ;
@@ -139,24 +128,12 @@ M: alien-node linearize* ( node -- )
 : define-c-word ( type lib func function-args -- )
     [ "()" subseq? not ] subset parse-arglist (define-c-word) ;
 
-\ alien-invoke [ [ string object string object ] [ ] ]
-"infer-effect" set-word-prop
-
-\ alien-invoke [
-    pop-literal nip
-    pop-literal nip >r
-    pop-literal nip
-    pop-literal nip -rot
-    r> swap alien-node
-] "infer" set-word-prop
-
-global [ "libraries" nest drop ] bind
-
 M: compound (uncrossref)
     dup word-def \ alien-invoke swap member?
     over "infer" word-prop or [
         drop
     ] [
-        dup { "infer-effect" "base-case" "no-effect" "terminates" }
+        dup
+        { "infer-effect" "base-case" "no-effect" "terminates" }
         reset-props update-xt
     ] if ;

library/alien/aliens.factor

@@ -1,19 +1,30 @@
-! Copyright (C) 2004, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
+! Copyright (C) 2004, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
 IN: alien
-USING: arrays hashtables io kernel lists math namespaces parser sequences ;
+USING: arrays hashtables io kernel lists math namespaces parser
+sequences ;
+
+! USAGE:
+! 
+! Command line parameters given to the runtime specify libraries
+! to load.
+!
+! -libraries:<foo>:name=<soname> -- define a library <foo>, to be
+! loaded from the <soname> DLL.
+!
+! -libraries:<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.
 
 UNION: c-ptr byte-array alien displaced-alien ;
 
-M: alien hashcode ( obj -- n )
-    alien-address >fixnum ;
+M: alien hashcode ( obj -- n ) alien-address >fixnum ;
 
 M: alien = ( obj obj -- ? )
-    over alien? [
-        alien-address swap alien-address =
-    ] [
-        2drop f
-    ] if ;
+    over alien? [ [ alien-address ] 2apply = ] [ 2drop f ] if ;
+
+global [ "libraries" nest drop ] bind
 
 : library ( name -- object ) "libraries" get hash ;
 

library/bootstrap/boot-stage1.factor

@@ -140,7 +140,8 @@ vectors words ;
 
         "/library/alien/c-types.factor"
         "/library/alien/structs.factor"
-        "/library/alien/compiler.factor"
+        "/library/alien/alien-invoke.factor"
+        "/library/alien/alien-callback.factor"
         "/library/alien/syntax.factor"
         "/library/alien/malloc.factor"
         

library/compiler/generator.factor

@@ -64,7 +64,7 @@ M: %parameter generate-node ( vop -- ) drop ;
 
 M: %alien-invoke generate-node
     #! call a C function.
-    drop 0 input 1 input load-library compile-c-call ;
+    drop 0 input 1 input compile-c-call ;
 
 : dest/src ( -- dest src ) 0 output-operand 0 input-operand ;
 

library/compiler/linearizer.factor

@@ -25,12 +25,12 @@ SYMBOL: renamed-labels
 
 GENERIC: linearize* ( node -- )
 
+: make-linear ( word quot -- )
+    swap >r [ %prologue , call ] { } make r>
+    linearized get set-hash ; inline
+
 : linearize-1 ( word dataflow -- )
-    #! Transform dataflow IR into linear IR. This strips out
-    #! stack flow information, and flattens conditionals into
-    #! jumps and labels.
-    [ %prologue , linearize* ] { } make
-    swap linearized get set-hash ;
+    swap [ linearize* ] make-linear ;
 
 : init-linearizer ( -- )
     H{ } clone linearized set

library/test/compiler/alien.factor

@@ -1,4 +1,5 @@
-USING: alien compiler kernel test ;
+IN: temporary
+USING: alien compiler kernel namespaces namespaces test ;
 
 FUNCTION: void ffi_test_0 ; compiled
 [ ] [ ffi_test_0 ] unit-test

library/test/compiler/callbacks.factor

@@ -0,0 +1,18 @@
+IN: temporary
+USING: alien compiler inference namespaces test ;
+
+: no-op ;
+
+: callback-1 "void" { } \ no-op alien-callback ; compiled
+
+[ { 0 1 } ] [ [ callback-1 ] infer ] unit-test
+
+: callback-1-bad "int" { } \ no-op alien-callback ;
+
+[ [ callback-1-bad ] infer ] unit-test-fails
+
+[ t ] [ callback-1 alien? ] unit-test
+
+FUNCTION: void callback_test_1 void* callback ; compiled
+
+[ ] [ callback-1 callback_test_1 ] unit-test

library/test/test.factor

@@ -109,5 +109,5 @@ SYMBOL: failures
         "compiler/generic" "compiler/bail-out"
         "compiler/linearizer" "compiler/intrinsics"
         "compiler/identities" "compiler/optimizer"
-        "compiler/alien"
+        "compiler/alien" "compiler/callbacks"
     } run-tests ;

native/ffi_test.c

@@ -82,3 +82,10 @@ int ffi_test_12(int a, int b, struct rect c, int d, int e, int f)
 	printf("ffi_test_12(%d,%d,{%f,%f,%f,%f},%d,%d,%d)\n",a,b,c.x,c.y,c.w,c.h,d,e,f);
 	return a + b + c.x + c.y + c.w + c.h + d + e + f;
 }
+
+void callback_test_1(void (*callback)())
+{
+	printf("callback_test_1 entry");
+	callback();
+	printf("callback_test_1 leaving");
+}