Nullary callbacks are working

TODO.FACTOR.txt

@@ -65,14 +65,10 @@
 
 + misc:
 
+- aliens are just a special case of displaced aliens -- so we can remove
+  one built in type
 - code walker & exceptions
 - slice: if sequence or seq start is changed, abstraction violation
 - delegating generic words with a non-standard picker
   - pass an integer stack pos instead of a quotation
 - make 3.4 bits>double an error
-- 2220.446049250313 [ dup float? [ tanh ] when ] 
-  - call and compile-1 give  C{ 0.0/0.0 0.0/0.0 }  0.0/0.0
-- 2.718281828459045e+19 [ dup float? [ sech ] when ]
-  - call/compile-1:  C{ 0.0/0.0 0.0/0.0 }  0.0
-- 0.0/0.0 next-power-of-2 never terminates -- comparison always returns false
-- 0.0/0.0 >fixnum .  -> 0    0.0/0.0 >bignum .  -> 0

library/alien/alien-callback.factor

@@ -5,7 +5,7 @@ USING: compiler-backend compiler-frontend errors generic
 hashtables inference inspector kernel lists namespaces sequences
 strings words ;
 
-TUPLE: alien-callback return parameters word xt ;
+TUPLE: alien-callback return parameters quot xt ;
 C: alien-callback make-node ;
 
 TUPLE: alien-callback-error ;
@@ -13,40 +13,30 @@ 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 -- ... )
+: alien-callback ( ... return parameters quot -- ... )
-    #! 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 ] ]
+\ alien-callback [ [ string object general-list ] [ 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-quot
     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 -- )
     dup alien-callback-xt [
-        alien-callback-word %jump ,
+        "nest_stacks" f %alien-invoke ,
+        alien-callback-quot %nullary-callback ,
+        %return ,
     ] make-linear ;
 
 M: alien-callback linearize* ( node -- )

library/alien/alien-invoke.factor

@@ -110,6 +110,7 @@ M: alien-invoke-error summary ( error -- )
 
 M: alien-invoke linearize* ( node -- )
     dup alien-invoke-parameters linearize-parameters
+    "save_stacks" f %alien-invoke ,
     dup alien-invoke-dlsym %alien-invoke ,
     dup linearize-cleanup
     dup linearize-return

library/compiler/ppc/alien.factor

@@ -45,3 +45,8 @@ M: %parameter generate-node ( vop -- )
 M: %box generate-node ( vop -- ) drop 1 input f compile-c-call ;
 
 M: %cleanup generate-node ( vop -- ) drop ;
+
+M: %nullary-callback generate-node ( vop -- )
+    drop
+    3 0 input load-indirect
+    "run_nullary_callback" f compile-c-call ;

library/compiler/vops.factor

@@ -377,3 +377,7 @@ C: %box make-vop ;
 TUPLE: %alien-invoke ;
 C: %alien-invoke make-vop ;
 : %alien-invoke ( func lib -- vop ) 2-in-vop <%alien-invoke> ;
+
+TUPLE: %nullary-callback ;
+C: %nullary-callback make-vop ;
+: %nullary-callback ( quot -- vop ) src-vop <%nullary-callback> ;

library/test/compiler/callbacks.factor

@@ -1,18 +1,54 @@
 IN: temporary
-USING: alien compiler inference namespaces test ;
+USING: alien compiler errors inference io kernel memory
+namespaces test threads ;
 
-: no-op ;
+: callback-1 "void" { } [ ] alien-callback ; compiled
-
-: 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
+
+: callback-2 "void" { } [ 5 throw ] alien-callback ; compiled
+
+[ 5 ] [ [ callback-2 callback_test_1 ] catch ] unit-test
+
+: callback-3 "void" { } [ 5 "x" set ] alien-callback ; compiled
+
+[ t ] [ 
+    namestack*
+    3 "x" set callback-3 callback_test_1
+    namestack* eq?
+] unit-test
+
+[ 5 ] [ 
+    [
+        3 "x" set callback-3 callback_test_1 "x" get
+    ] with-scope
+] unit-test
+
+: callback-4 "void" { } [ "Hello world" write ] alien-callback ; compiled
+
+[ "Hello world" ] [ 
+    [ callback-4 callback_test_1 ] string-out
+] unit-test
+
+: callback-5
+    "void" { } [ full-gc ] alien-callback ; compiled
+
+[ "testing" ] [
+    "testing" callback-5 callback_test_1
+] unit-test
+
+: callback-6
+    "void" { } [ [ continue ] callcc0 ] alien-callback ; compiled
+
+[ ] [ callback-6 callback_test_1 ] unit-test
+
+: callback-7
+    "void" { } [ yield "hi" print flush yield ] alien-callback ; compiled
+
+[ ] [ callback-7 callback_test_1 ] unit-test

native/factor.c

@@ -39,8 +39,8 @@ INLINE bool factor_arg(const char* str, const char* arg, CELL* value)
 int main(int argc, char** argv)
 {
 	char *image;
-	CELL ds_size = 512;
+	CELL ds_size = 128;
-	CELL cs_size = 512;
+	CELL cs_size = 128;
 	CELL generations = 2;
 	CELL young_size = 2 * CELLS;
 	CELL aging_size = 4 * CELLS;

native/ffi_test.c

@@ -85,7 +85,9 @@ int ffi_test_12(int a, int b, struct rect c, int d, int e, int f)
 
 void callback_test_1(void (*callback)())
 {
-	printf("callback_test_1 entry");
+	printf("callback_test_1 entry\n");
+	fflush(stdout);
 	callback();
-	printf("callback_test_1 leaving");
+	printf("callback_test_1 leaving\n");
+	fflush(stdout);
 }

native/run.h

@@ -80,8 +80,8 @@ INLINE void call(CELL quot)
 
 void run(bool handle_errors);
 void run_toplevel(void);
-void run_nullary_callback(CELL quot);
+DLLEXPORT void run_nullary_callback(CELL quot);
-CELL run_unary_callback(CELL quot);
+DLLEXPORT CELL run_unary_callback(CELL quot);
 void platform_run(void);
 void undefined(F_WORD *word);
 void docol(F_WORD *word);

native/stack.c

@@ -22,9 +22,13 @@ void fix_stacks(void)
 		reset_callstack();
 }
 
-/* called before entry into foreign C code */
+/* called before entry into foreign C code. Note that ds and cs are stored
+in registers, so callbacks must save and restore the correct values */
 void save_stacks(void)
 {
+	/* we want to save the current callframe along with the call stack */
+	call(F);
+
 	stack_chain->ds = ds;
 	stack_chain->cs = cs;
 }
@@ -33,6 +37,9 @@ void save_stacks(void)
 void nest_stacks(void)
 {
 	STACKS *new_stacks = malloc(sizeof(STACKS));
+	if(new_stacks == NULL)
+		fatal_error("Cannot allocate saved stacks struct",0);
+	
 	new_stacks->ds_save = ds;
 	new_stacks->cs_save = cs;
 	new_stacks->ds_region = alloc_bounded_block(ds_size);
@@ -49,7 +56,7 @@ void unnest_stacks(void)
 	dealloc_bounded_block(stack_chain->ds_region);
 	dealloc_bounded_block(stack_chain->cs_region);
 	ds = stack_chain->ds_save;
-	ds = stack_chain->cs_save;
+	cs = stack_chain->cs_save;
 	stack_chain = stack_chain->next;
 }
 

native/stack.h

@@ -21,9 +21,9 @@ CELL ds_size, cs_size;
 void reset_datastack(void);
 void reset_callstack(void);
 void fix_stacks(void);
-void save_stacks(void);
+DLLEXPORT void save_stacks(void);
-void nest_stacks(void);
+DLLEXPORT void nest_stacks(void);
-void unnest_stacks(void);
+DLLEXPORT void unnest_stacks(void);
 void init_stacks(CELL ds_size, CELL cs_size);
 
 void primitive_drop(void);

native/unix/memory.c

@@ -4,7 +4,7 @@ BOUNDED_BLOCK *alloc_bounded_block(CELL size)
 {
 	int pagesize = getpagesize();
 
-	char* array = mmap((void*)0,pagesize + size + pagesize,
+	char *array = mmap((void*)0,pagesize + size + pagesize,
 		PROT_READ | PROT_WRITE | PROT_EXEC,
 		MAP_ANON | MAP_PRIVATE,-1,0);
 
@@ -12,10 +12,10 @@ BOUNDED_BLOCK *alloc_bounded_block(CELL size)
 		fatal_error("Cannot allocate memory region",0);
 
 	if(mprotect(array,pagesize,PROT_NONE) == -1)
-		fatal_error("Cannot allocate low guard page",(CELL)array);
+		fatal_error("Cannot protect low guard page",(CELL)array);
 
 	if(mprotect(array + pagesize + size,pagesize,PROT_NONE) == -1)
-		fatal_error("Cannot allocate high guard page",(CELL)array);
+		fatal_error("Cannot protect high guard page",(CELL)array);
 
 	BOUNDED_BLOCK *retval = malloc(sizeof(BOUNDED_BLOCK));
 	if(retval == NULL)
@@ -34,7 +34,7 @@ void dealloc_bounded_block(BOUNDED_BLOCK *block)
 	int retval = munmap((void*)(block->start - pagesize),
 		pagesize + block->size + pagesize);
 	
-	if(!retval)
+	if(retval)
 		fatal_error("Failed to unmap region",0);
 
 	free(block);