From 8b74f721b55a420ed05185e540cff5b1dd3a1456 Mon Sep 17 00:00:00 2001 From: slava Date: Mon, 13 Feb 2006 22:16:34 +0000 Subject: [PATCH] Nullary callbacks are working --- TODO.FACTOR.txt | 8 +--- library/alien/alien-callback.factor | 24 ++++-------- library/alien/alien-invoke.factor | 1 + library/compiler/ppc/alien.factor | 5 +++ library/compiler/vops.factor | 4 ++ library/test/compiler/callbacks.factor | 52 ++++++++++++++++++++++---- native/factor.c | 4 +- native/ffi_test.c | 6 ++- native/run.h | 4 +- native/stack.c | 11 +++++- native/stack.h | 6 +-- native/unix/memory.c | 8 ++-- 12 files changed, 87 insertions(+), 46 deletions(-) diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index f7d99e3600..39ae4d512a 100644 --- a/TODO.FACTOR.txt +++ b/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 diff --git a/library/alien/alien-callback.factor b/library/alien/alien-callback.factor index 2081fb044e..ccdc573c92 100644 --- a/library/alien/alien-callback.factor +++ b/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 -- ... ) - #! 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 ( ... return parameters quot -- ... ) 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 ] 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 - 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 -- ) diff --git a/library/alien/alien-invoke.factor b/library/alien/alien-invoke.factor index cab6f1b08b..5ddb2ffa1b 100644 --- a/library/alien/alien-invoke.factor +++ b/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 diff --git a/library/compiler/ppc/alien.factor b/library/compiler/ppc/alien.factor index 8770114b47..1341d23df2 100644 --- a/library/compiler/ppc/alien.factor +++ b/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 ; diff --git a/library/compiler/vops.factor b/library/compiler/vops.factor index 943aa1c898..edf3f7b62a 100644 --- a/library/compiler/vops.factor +++ b/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> ; diff --git a/library/test/compiler/callbacks.factor b/library/test/compiler/callbacks.factor index e8af49db1d..4dbcb6de04 100644 --- a/library/test/compiler/callbacks.factor +++ b/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" { } \ no-op alien-callback ; compiled +: callback-1 "void" { } [ ] 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 diff --git a/native/factor.c b/native/factor.c index 185420984e..838a04cb71 100644 --- a/native/factor.c +++ b/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 cs_size = 512; + CELL ds_size = 128; + CELL cs_size = 128; CELL generations = 2; CELL young_size = 2 * CELLS; CELL aging_size = 4 * CELLS; diff --git a/native/ffi_test.c b/native/ffi_test.c index 213b2b5495..8f64b902e9 100644 --- a/native/ffi_test.c +++ b/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); } diff --git a/native/run.h b/native/run.h index 425289df26..ad70da8b0f 100644 --- a/native/run.h +++ b/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); -CELL run_unary_callback(CELL quot); +DLLEXPORT void run_nullary_callback(CELL quot); +DLLEXPORT CELL run_unary_callback(CELL quot); void platform_run(void); void undefined(F_WORD *word); void docol(F_WORD *word); diff --git a/native/stack.c b/native/stack.c index f6d341ae33..628ea195c3 100644 --- a/native/stack.c +++ b/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; } diff --git a/native/stack.h b/native/stack.h index 21662cbdce..d0ec0a2c6b 100644 --- a/native/stack.h +++ b/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); -void nest_stacks(void); -void unnest_stacks(void); +DLLEXPORT void save_stacks(void); +DLLEXPORT void nest_stacks(void); +DLLEXPORT void unnest_stacks(void); void init_stacks(CELL ds_size, CELL cs_size); void primitive_drop(void); diff --git a/native/unix/memory.c b/native/unix/memory.c index 2f3ab6c9c0..c2c7f38f52 100644 --- a/native/unix/memory.c +++ b/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);