Runtime changes to support callbacks, and other cleanups

TODO.FACTOR.txt

@@ -1,45 +1,35 @@
++ portability:
+
+- port ffi to win64
+- x86 %unbox-struct
+- amd64 %unbox-struct
+- get factor running on mac intel
+
++ io:
+
 - if select() returns an error, fep
 - FILE* leaked in process.factor
-- fix remaining HTML stream issues
-- help cross-referencing
-- UI browser pane needs 'back' button
 - runtime primitives like fopen: check for null input
-- port ffi to win64
-- fix up the min thumb size hack
-- the invalid recursion form case needs to be fixed, for inlines too
-- code walker & exceptions
-- signal handler should not lose stack pointers
-- FIELD: char key_vector[32];
-- FIELD: union { char b[20]; short s[10]; long l[5]; } data;
-- MEMBER: long pad[24];
-- C structs, enums, unions: use new-style string mode parsing
-- ffi unicode strings: null char security hole
-- utf16 string boxing
-- [ [ dup call ] dup call ] infer hangs
-- slice: if sequence or seq start is changed, abstraction violation
-- out of memory error when printing global namespace
-- delegating generic words with a non-standard picker
-  - pass an integer stack pos instead of a quotation
-- code gc
 - stream server can hang because of exception handler limitations
 - better i/o scheduler
 - if two tasks write to a unix stream, the buffer can overflow
-- make 3.4 bits>double an error
+- out of memory error when printing global namespace
-- 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
 - "localhost" 50 <client> won't fail
-- out of memory from ffi calls
+
-- out of memory from overflow check
++ objective C/cocoa:
-- x86 %unbox-struct
+
-- amd64 %unbox-struct
-- remove literal table
-- callbacks
 - CFBundle error handling
 - autoload frameworks in cocoa class words
+- exceptions
+- subclassing
+- messages returning structs by value
+
++ ui/help:
+
+- fix remaining HTML stream issues
+- UI browser pane needs 'back' button
+- fix up the min thumb size hack
+- help cross-referencing
 - document FFI
 - document tools
 - document conventions
@@ -47,6 +37,41 @@
 - better line spacing in ui
 - use vertex arrays and display lists to speed up ui
 - tabular formatting
+
++ compiler/ffi:
+
 - float intrinsics
 - complex float type
 - complex float intrinsics
+- out of memory from ffi calls
+- out of memory from overflow check
+- remove literal table
+- callbacks
+  - zero-arity
+  - return-only
+  - input values
+  - value type struct inputs
+- ffi unicode strings: null char security hole
+- utf16 string boxing
+- signal handler should not lose stack pointers
+- FIELD: char key_vector[32];
+- FIELD: union { char b[20]; short s[10]; long l[5]; } data;
+- MEMBER: long pad[24];
+- C structs, enums, unions: use new-style string mode parsing
+- [ [ dup call ] dup call ] infer hangs
+- the invalid recursion form case needs to be fixed, for inlines too
+- code gc
+
++ misc:
+
+- 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/test/alien.factor

@@ -1,5 +1,5 @@
 IN: temporary
-USING: alien arrays kernel kernel-internals namespaces objc test ;
+USING: alien arrays kernel kernel-internals namespaces test ;
 
 [ t ] [ 0 <alien> 0 <alien> = ] unit-test
 [ f ] [ 0 <alien> 1024 <alien> = ] unit-test
@@ -50,8 +50,4 @@ cell 8 = [
 [ "hello world" ]
 [ "hello world" string>alien alien>string ] unit-test
 
-[ "example" ] [ "{example=@*i}" parse-objc-type ] unit-test
-[ "void*" ] [ "[12^f]" parse-objc-type ] unit-test
-[ "void*" ] [ "^f" parse-objc-type ] unit-test
-
 [ t ] [ f expired? ] unit-test

native/alien.c

@@ -1,5 +1,6 @@
 #include "factor.h"
 
+/* test if alien is no longer valid (it survived an image save/load) */
 void primitive_expired(void)
 {
 	CELL object = dpeek();
@@ -15,6 +16,7 @@ void primitive_expired(void)
 		drepl(F);
 }
 
+/* gets the address of an object representing a C pointer */
 void *alien_offset(CELL object)
 {
 	ALIEN *alien;
@@ -42,17 +44,20 @@ void *alien_offset(CELL object)
 	}
 }
 
+/* pop ( alien n ) from datastack, return alien's address plus n */
 INLINE void *alien_pointer(void)
 {
 	F_FIXNUM offset = unbox_signed_cell();
 	return alien_offset(dpop()) + offset;
 }
 
+/* pop an object representing a C pointer */
 void *unbox_alien(void)
 {
 	return alien_offset(dpop());
 }
 
+/* make an alien */
 ALIEN *alien(void* ptr)
 {
 	ALIEN* alien = allot_object(ALIEN_TYPE,sizeof(ALIEN));
@@ -61,6 +66,7 @@ ALIEN *alien(void* ptr)
 	return alien;
 }
 
+/* make an alien and push */
 void box_alien(void *ptr)
 {
 	if(ptr == NULL)
@@ -69,6 +75,7 @@ void box_alien(void *ptr)
 		dpush(tag_object(alien(ptr)));
 }
 
+/* make an alien form an address on the stack */
 void primitive_alien(void)
 {
 	void* ptr = (void*)unbox_signed_cell();
@@ -76,6 +83,7 @@ void primitive_alien(void)
 	box_alien(ptr);
 }
 
+/* make an alien pointing at an offset of another alien */
 void primitive_displaced_alien(void)
 {
 	CELL alien;
@@ -90,38 +98,45 @@ void primitive_displaced_alien(void)
 	dpush(tag_object(d));
 }
 
+/* address of an object representing a C pointer */
 void primitive_alien_address(void)
 {
 	box_unsigned_cell((CELL)alien_offset(dpop()));
 }
 
+/* convert C string at address to Factor string */
 void primitive_alien_to_string(void)
 {
 	maybe_gc(0);
 	drepl(tag_object(from_c_string(alien_offset(dpeek()))));
 }
 
+/* convert Factor string to C string allocated in the Factor heap */
 void primitive_string_to_alien(void)
 {
 	maybe_gc(0);
 	drepl(tag_object(string_to_alien(untag_string(dpeek()),true)));
 }
 
+/* expire aliens when loading the image */
 void fixup_alien(ALIEN *alien)
 {
 	alien->expired = true;
 }
 
+/* image loading */
 void fixup_displaced_alien(DISPLACED_ALIEN *d)
 {
 	data_fixup(&d->alien);
 }
 
+/* GC */
 void collect_displaced_alien(DISPLACED_ALIEN *d)
 {
 	copy_handle(&d->alien);
 }
 
+/* define words to read/write numericals values at an alien address */
 #define DEF_ALIEN_SLOT(name,type,boxer) \
 void primitive_alien_##name (void) \
 { \

native/array.c

@@ -14,6 +14,7 @@ F_ARRAY* allot_array(CELL type, F_FIXNUM capacity)
 	return array;
 }
 
+/* make a new array with an initial element */
 F_ARRAY* array(CELL type, F_FIXNUM capacity, CELL fill)
 {
 	int i;
@@ -23,6 +24,7 @@ F_ARRAY* array(CELL type, F_FIXNUM capacity, CELL fill)
 	return array;
 }
 
+/* push a new array on the stack */
 void primitive_array(void)
 {
 	CELL initial;
@@ -33,6 +35,7 @@ void primitive_array(void)
 	dpush(tag_object(array(ARRAY_TYPE,size,initial)));
 }
 
+/* push a new tuple on the stack */
 void primitive_tuple(void)
 {
 	F_FIXNUM size = to_fixnum(dpop());
@@ -40,6 +43,7 @@ void primitive_tuple(void)
 	dpush(tag_object(array(TUPLE_TYPE,size,F)));
 }
 
+/* push a new byte on the stack */
 void primitive_byte_array(void)
 {
 	F_FIXNUM size = to_fixnum(dpop());
@@ -48,7 +52,6 @@ void primitive_byte_array(void)
 	dpush(tag_object(array(BYTE_ARRAY_TYPE,byte_size,0)));
 }
 
-/* see note about fill in array() */
 F_ARRAY* resize_array(F_ARRAY* array, F_FIXNUM capacity, CELL fill)
 {
 	int i;
@@ -95,6 +98,7 @@ void primitive_tuple_to_array(void)
 	drepl(tuple);
 }
 
+/* image loading */
 void fixup_array(F_ARRAY* array)
 {
 	int i = 0; CELL capacity = array_capacity(array);
@@ -102,6 +106,7 @@ void fixup_array(F_ARRAY* array)
 		data_fixup((void*)AREF(array,i));
 }
 
+/* GC */
 void collect_array(F_ARRAY* array)
 {
 	int i = 0; CELL capacity = array_capacity(array);

native/compiler.c

@@ -2,7 +2,7 @@
 
 void init_compiler(CELL size)
 {
-	compiling.base = compiling.here = (CELL)alloc_guarded(size);
+	compiling.base = compiling.here = (CELL)(alloc_bounded_block(size)->start);
 	if(compiling.base == 0)
 		fatal_error("Cannot allocate code heap",size);
 	compiling.limit = compiling.base + size;

native/error.c

@@ -1,10 +1,5 @@
 #include "factor.h"
 
-void init_errors(void)
-{
-	thrown_error = F;
-}
-
 void fatal_error(char* msg, CELL tagged)
 {
 	fprintf(stderr,"Fatal error: %s %ld\n",msg,tagged);

native/error.h

@@ -28,7 +28,6 @@ CELL thrown_cs;
 CELL thrown_callframe;
 CELL thrown_executing;
 
-void init_errors(void);
 void fatal_error(char* msg, CELL tagged);
 void critical_error(char* msg, CELL tagged);
 void throw_error(CELL error, bool keep_stacks);

native/factor.c

@@ -15,7 +15,6 @@ void init_factor(char* image, CELL ds_size, CELL cs_size,
 	callframe = userenv[BOOT_ENV];
 	init_c_io();
 	init_signals();
-	init_errors();
 	userenv[CPU_ENV] = tag_object(from_c_string(FACTOR_CPU_STRING));
 	userenv[OS_ENV] = tag_object(from_c_string(FACTOR_OS_STRING));
 	userenv[GEN_ENV] = tag_fixnum(gen_count);

native/gc.c

@@ -33,10 +33,10 @@ void init_arena(CELL gens, CELL young_size, CELL aging_size)
 	if(generations == 0)
 		fatal_error("Cannot allocate zone head array",0);
 
-	heap_start = (CELL)alloc_guarded(total_size);
+	heap_start = (CELL)(alloc_bounded_block(total_size)->start);
 	heap_end = heap_start + total_size;
 
-	cards = alloc_guarded(cards_size);
+	cards = malloc(cards_size);
 	cards_end = cards + cards_size;
 	cards_offset = (CELL)cards - (heap_start >> CARD_BITS);
 
@@ -66,21 +66,34 @@ void collect_roots(void)
 {
 	int i;
 	CELL ptr;
+	STACKS *stacks;
 
 	copy_handle(&T);
 	copy_handle(&bignum_zero);
 	copy_handle(&bignum_pos_one);
 	copy_handle(&bignum_neg_one);
-	/* we can't use & here since these two are in
+	copy_handle(&callframe);
-	registers on PowerPC */
+	copy_handle(&executing);
-	COPY_OBJECT(callframe);
-	COPY_OBJECT(executing);
 
-	for(ptr = ds_bot; ptr <= ds; ptr += CELLS)
+	save_stacks();
-		copy_handle((CELL*)ptr);
+	stacks = stack_chain;
 
-	for(ptr = cs_bot; ptr <= cs; ptr += CELLS)
+	while(stacks)
-		copy_handle((CELL*)ptr);
+	{
+		CELL bottom = stacks->ds_region->start;
+		CELL top = stacks->ds;
+		
+		for(ptr = bottom; ptr <= top; ptr += CELLS)
+			copy_handle((CELL*)ptr);
+	
+		bottom = stacks->cs_region->start;
+		top = stacks->cs;
+		
+		for(ptr = bottom; ptr <= top; ptr += CELLS)
+			copy_handle((CELL*)ptr);
+		
+		stacks = stacks->next;
+	}
 
 	for(i = 0; i < USER_ENV; i++)
 		copy_handle(&userenv[i]);

native/memory.h

@@ -1,3 +1,13 @@
+typedef struct {
+    CELL start;
+    CELL size;
+} BOUNDED_BLOCK;
+
+/* set up guard pages to check for under/overflow.
+size must be a multiple of the page size */
+BOUNDED_BLOCK *alloc_bounded_block(CELL size);
+void dealloc_bounded_block(BOUNDED_BLOCK *block);
+
 /* macros for reading/writing memory, useful when working around
 C's type system */
 INLINE CELL get(CELL where)
@@ -151,7 +161,3 @@ void primitive_clone(void);
 void primitive_begin_scan(void);
 void primitive_next_object(void);
 void primitive_end_scan(void);
-
-/* set up guard pages to check for under/overflow.
-size must be a multiple of the page size */
-void* alloc_guarded(CELL size);

native/run.c

@@ -5,11 +5,11 @@ INLINE void execute(F_WORD* word)
 	((XT)(word->xt))(word);
 }
 
-void run(void)
+/* Called from platform_run() */
+void init_errors(void)
 {
-	CELL next;
+	thrown_error = F;
 	
-	/* Error handling. */
 	SETJMP(toplevel);
 	
 	if(throwing)
@@ -33,11 +33,19 @@ void run(void)
 		call(userenv[BREAK_ENV]);
 		throwing = false;
 	}
+}
+
+void run_once(void)
+{
+	CELL next;
 
 	for(;;)
 	{
 		if(callframe == F)
 		{
+			if(cs == cs_bot)
+				return;
+
 			callframe = cpop();
 			executing = cpop();
 			continue;
@@ -62,6 +70,33 @@ void run(void)
 	}
 }
 
+void run(void)
+{
+	init_errors();
+	run_once();
+}
+
+/* Called by compiled callbacks after nest_stacks() and boxing registers */
+void run_nullary_callback(CELL quot)
+{
+	call(quot);
+	run_once();
+	unnest_stacks();
+}
+
+/* Called by compiled callbacks after nest_stacks() and boxing registers */
+CELL run_unary_callback(CELL quot)
+{
+	CELL retval;
+	
+	nest_stacks();
+	call(quot);
+	run_once();
+	retval = dpeek();
+	unnest_stacks();
+	return retval;
+}
+
 /* XT of deferred words */
 void undefined(F_WORD* word)
 {

native/run.h

@@ -79,6 +79,8 @@ INLINE void call(CELL quot)
 }
 
 void run(void);
+void run_nullary_callback(CELL quot);
+CELL run_unary_callback(CELL quot);
 void platform_run(void);
 void undefined(F_WORD *word);
 void docol(F_WORD *word);

native/stack.c

@@ -12,24 +12,53 @@ void reset_callstack(void)
 
 void fix_stacks(void)
 {
-	if(STACK_UNDERFLOW(ds,ds_bot))
+	if(STACK_UNDERFLOW(ds,stack_chain->ds_region))
 		reset_datastack();
-	else if(STACK_OVERFLOW(ds,ds_bot,ds_size))
+	else if(STACK_OVERFLOW(ds,stack_chain->ds_region))
 		reset_datastack();
-	else if(STACK_UNDERFLOW(cs,cs_bot))
+	else if(STACK_UNDERFLOW(cs,stack_chain->cs_region))
 		reset_callstack();
-	else if(STACK_OVERFLOW(cs,cs_bot,cs_size))
+	else if(STACK_OVERFLOW(cs,stack_chain->cs_region))
 		reset_callstack();
 }
 
+/* called before entry into foreign C code */
+void save_stacks(void)
+{
+	stack_chain->ds = ds;
+	stack_chain->cs = cs;
+}
+
+/* called on entry into a compiled callback */
+void nest_stacks(void)
+{
+	STACKS *new_stacks = malloc(sizeof(STACKS));
+	new_stacks->ds_save = ds;
+	new_stacks->cs_save = cs;
+	new_stacks->ds_region = alloc_bounded_block(ds_size);
+	new_stacks->cs_region = alloc_bounded_block(cs_size);
+	new_stacks->next = stack_chain;
+	stack_chain = new_stacks;
+	reset_datastack();
+	reset_callstack();
+}
+
+/* called when leaving a compiled callback */
+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;
+	stack_chain = stack_chain->next;
+}
+
 void init_stacks(CELL ds_size_, CELL cs_size_)
 {
 	ds_size = ds_size_;
 	cs_size = cs_size_;
-	ds_bot = (CELL)alloc_guarded(ds_size);
+	stack_chain = NULL;
-	reset_datastack();
+	nest_stacks();
-	cs_bot = (CELL)alloc_guarded(cs_size);
-	reset_callstack();
 }
 
 void primitive_drop(void)

native/stack.h

@@ -1,11 +1,29 @@
+typedef struct _STACKS {
+    CELL ds;
+    CELL ds_save;
+    BOUNDED_BLOCK *ds_region;
+    CELL cs;
+    CELL cs_save;
+    BOUNDED_BLOCK *cs_region;
+    struct _STACKS *next;
+} STACKS;
+
+STACKS *stack_chain;
+
 CELL ds_size, cs_size;
 
-#define STACK_UNDERFLOW(stack,bot) ((stack) + CELLS < UNTAG(bot))
+#define ds_bot ((CELL)(stack_chain->ds_region->start))
-#define STACK_OVERFLOW(stack,bot,top) ((stack) + CELLS >= UNTAG(bot) + top)
+#define cs_bot ((CELL)(stack_chain->cs_region->start))
+
+#define STACK_UNDERFLOW(stack,region) ((stack) + CELLS < (region)->start)
+#define STACK_OVERFLOW(stack,region) ((stack) + CELLS >= (region)->start + (region)->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);
 void init_stacks(CELL ds_size, CELL cs_size);
 
 void primitive_drop(void);

native/unix/memory.c

@@ -1,6 +1,6 @@
 #include "../factor.h"
 
-void *alloc_guarded(CELL size)
+BOUNDED_BLOCK *alloc_bounded_block(CELL size)
 {
 	int pagesize = getpagesize();
 
@@ -8,12 +8,34 @@ void *alloc_guarded(CELL size)
 		PROT_READ | PROT_WRITE | PROT_EXEC,
 		MAP_ANON | MAP_PRIVATE,-1,0);
 
+	if(array == NULL)
+		fatal_error("Cannot allocate memory region",0);
+
 	if(mprotect(array,pagesize,PROT_NONE) == -1)
 		fatal_error("Cannot allocate low guard page",(CELL)array);
 
 	if(mprotect(array + pagesize + size,pagesize,PROT_NONE) == -1)
 		fatal_error("Cannot allocate high guard page",(CELL)array);
 
-	/* return bottom of actual array */
+	BOUNDED_BLOCK *retval = malloc(sizeof(BOUNDED_BLOCK));
-	return array + pagesize;
+	if(retval == NULL)
+		fatal_error("Cannot allocate BOUNDED_BLOCK struct",0);
+	
+	retval->start = (CELL)(array + pagesize);
+	retval->size = size;
+
+	return retval;
+}
+
+void dealloc_bounded_block(BOUNDED_BLOCK *block)
+{
+	int pagesize = getpagesize();
+
+	int retval = munmap((void*)(block->start - pagesize),
+		pagesize + block->size + pagesize);
+	
+	if(!retval)
+		fatal_error("Failed to unmap region",0);
+
+	free(block);
 }

native/win32/memory.c

@@ -1,19 +1,31 @@
 #include "../factor.h"
 
-void *alloc_guarded(CELL size)
+BOUNDED_BLOCK *alloc_bounded_block(CELL size)
 {
-       SYSTEM_INFO si;
+	SYSTEM_INFO si;
-       char *mem;
+	char *mem;
-       DWORD ignore;
+	DWORD ignore;
 	
-       GetSystemInfo(&si);
+	GetSystemInfo(&si);
-       mem = (char *)VirtualAlloc(NULL, si.dwPageSize*2 + size, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
+	mem = (char *)VirtualAlloc(NULL, si.dwPageSize*2 + size, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
 	
-       if (!VirtualProtect(mem, si.dwPageSize, PAGE_NOACCESS, &ignore))
+	if (!VirtualProtect(mem, si.dwPageSize, PAGE_NOACCESS, &ignore))
-	       fatal_error("Cannot allocate low guard page", (CELL)mem);
+		fatal_error("Cannot allocate low guard page", (CELL)mem);
 	
-       if (!VirtualProtect(mem+size+si.dwPageSize, si.dwPageSize, PAGE_NOACCESS, &ignore))
+	if (!VirtualProtect(mem+size+si.dwPageSize, si.dwPageSize, PAGE_NOACCESS, &ignore))
-	       fatal_error("Cannot allocate high guard page", (CELL)mem);
+		fatal_error("Cannot allocate high guard page", (CELL)mem);
 	
-       return mem + si.dwPageSize;
+	BOUNDED_BLOCK *retval = malloc(sizeof(BOUNDED_BLOCK));
+	if(retval == NULL)
+		fatal_error("Cannot allocate BOUNDED_BLOCK struct",0);
+	
+	retval->start = mem + si.dwPageSize;
+	retval->size = size;
+	
+	return retval;
+}
+
+void dealloc_bounded_block(BOUNDED_BLOCK *block)
+{
+	fatal_error("dealloc_bounded_block() not implemented on windows FIXME",0);
 }