Merge alien and displaced-alien types, assorted cleanups

TODO.FACTOR.txt

@@ -7,8 +7,6 @@
 + io:
 
 - if select() returns an error, fep
-- FILE* leaked in process.factor
-- runtime primitives like fopen: check for null input
 - 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
@@ -44,7 +42,6 @@
 
 + compiler/ffi:
 
-- stack effect comment for FUNCTION: doesn't show return value
 - float intrinsics
 - complex float type
 - complex float intrinsics
@@ -72,8 +69,6 @@
 
 + 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

contrib/process.factor

@@ -5,9 +5,7 @@ FUNCTION: int system ( char* command ) ; compiled
 
 FUNCTION: void* popen ( char* command, char* type ) ; compiled
 
-FUNCTION: int fileno ( void* file ) ; compiled
-
 : <process-stream> ( command mode -- stream )
-    popen fileno dup <fd-stream> ;
+    popen dup <c-stream> ;
 
 : !" parse-string system drop ; parsing

library/alien/alien-invoke.factor

@@ -76,9 +76,9 @@ M: alien-invoke linearize* ( node -- )
     dup box-return
     linearize-next ;
 
-: parse-arglist ( lst -- types stack effect )
+: parse-arglist ( return seq -- types stack-effect )
     unpair [
-        " " % [ "," ?tail drop % " " % ] each "-- " %
+        " " % [ "," ?tail drop ] map " " join % " -- " % swap %
     ] "" make ;
 
 : (define-c-word) ( type lib func types stack-effect -- )
@@ -87,7 +87,8 @@ M: alien-invoke linearize* ( node -- )
     word r> "stack-effect" set-word-prop ;
 
 : define-c-word ( type lib func function-args -- )
-    [ "()" subseq? not ] subset parse-arglist (define-c-word) ;
+    [ "()" subseq? not ] subset >r pick r> parse-arglist
+    (define-c-word) ;
 
 M: compound (uncrossref)
     dup word-def \ alien-invoke swap member?

library/alien/aliens.factor

@@ -17,9 +17,9 @@ sequences ;
 ! 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 ;
+: <alien> ( address -- alien ) f <displaced-alien> ; inline
 
-M: alien hashcode ( obj -- n ) alien-address >fixnum ;
+UNION: c-ptr byte-array alien ;
 
 M: alien = ( obj obj -- ? )
     over alien? [ [ alien-address ] 2apply = ] [ 2drop f ] if ;

library/alien/c-types.factor

@@ -50,7 +50,7 @@ SYMBOL: c-types
     >r c-size [ rot * ] cons r> append define-compound ;
 
 : define-nth ( name vocab -- )
-    #! Make a word foo-nth ( n alien -- displaced-alien ).
+    #! Make a word foo-nth ( n alien -- alien ).
     >r dup "-nth" append r> create
     swap dup c-getter (define-nth) ;
 

library/bootstrap/primitives.factor

@@ -160,7 +160,6 @@ call
     { "dlopen" "alien"                      }
     { "dlsym" "alien"                       }
     { "dlclose" "alien"                     }
-    { "<alien>" "alien"                     }
     { "<byte-array>" "arrays"               }
     { "<displaced-alien>" "alien"           }
     { "alien-signed-cell" "alien"           }
@@ -283,7 +282,8 @@ num-types f <array> builtins set
 { { 0 { "real" "math" } f } { 1 { "imaginary" "math" } f } } define-builtin
 "complex" "math" create 4 "math-priority" set-word-prop
 
-"displaced-alien" "alien" create 7 "displaced-alien?" "alien" create { } define-builtin
+"alien" "alien" create 7 "alien?" "alien" create
+{ { 1 { "underlying-alien" "alien" } f } } define-builtin
 
 "array?" "arrays" create t "inline" set-word-prop
 "array" "arrays" create 8 "array?" "arrays" create
@@ -329,9 +329,6 @@ num-types f <array> builtins set
 "dll" "alien" create 15 "dll?" "alien" create
 { { 1 { "dll-path" "alien" } f } } define-builtin
 
-"alien?" "alien" create t "inline" set-word-prop
-"alien" "alien" create 16 "alien?" "alien" create { } define-builtin
-
 "word?" "words" create t "inline" set-word-prop
 "word" "words" create 17 "word?" "words" create
 {

library/inference/known-words.factor

@@ -387,7 +387,7 @@ sequences strings vectors words prettyprint ;
 \ <byte-array> [ [ integer ] [ byte-array ] ] "infer-effect" set-word-prop
 \ <byte-array> t "flushable" set-word-prop
 
-\ <displaced-alien> [ [ integer c-ptr ] [ displaced-alien ] ] "infer-effect" set-word-prop
+\ <displaced-alien> [ [ integer c-ptr ] [ alien ] ] "infer-effect" set-word-prop
 \ <displaced-alien> t "flushable" set-word-prop
 
 \ alien-signed-cell [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop

native/alien.c

@@ -21,21 +21,17 @@ void *alien_offset(CELL object)
 {
 	ALIEN *alien;
 	F_ARRAY *array;
-	DISPLACED_ALIEN *d;
 
 	switch(type_of(object))
 	{
+	case BYTE_ARRAY_TYPE:
+		array = untag_byte_array_fast(object);
+		return array + 1;
 	case ALIEN_TYPE:
 		alien = untag_alien_fast(object);
 		if(alien->expired)
 			general_error(ERROR_EXPIRED,object,true);
-		return alien->ptr;
+		return alien_offset(alien->alien) + alien->displacement;
-	case BYTE_ARRAY_TYPE:
-		array = untag_byte_array_fast(object);
-		return array + 1;
-	case DISPLACED_ALIEN_TYPE:
-		d = untag_displaced_alien_fast(object);
-		return alien_offset(d->alien) + d->displacement;
 	case F_TYPE:
 		return NULL;
 	default:
@@ -58,29 +54,22 @@ INLINE void *alien_pointer(void)
 }
 
 /* make an alien */
-ALIEN *alien(void *ptr)
+ALIEN *make_alien(CELL delegate, CELL displacement)
 {
 	ALIEN *alien = allot_object(ALIEN_TYPE,sizeof(ALIEN));
-	alien->ptr = ptr;
+	alien->alien = delegate;
+	alien->displacement = displacement;
 	alien->expired = false;
 	return alien;
 }
 
 /* make an alien and push */
-void box_alien(void *ptr)
+void box_alien(CELL ptr)
 {
-	if(ptr == NULL)
+	if(ptr == 0)
 		dpush(F);
 	else
-		dpush(tag_object(alien(ptr)));
+		dpush(tag_object(make_alien(F,ptr)));
-}
-
-/* make an alien form an address on the stack */
-void primitive_alien(void)
-{
-	void* ptr = (void*)unbox_signed_cell();
-	maybe_gc(sizeof(ALIEN));
-	box_alien(ptr);
 }
 
 /* make an alien pointing at an offset of another alien */
@@ -88,14 +77,10 @@ void primitive_displaced_alien(void)
 {
 	CELL alien;
 	CELL displacement;
-	DISPLACED_ALIEN* d;
+	maybe_gc(sizeof(ALIEN));
-	maybe_gc(sizeof(DISPLACED_ALIEN));
 	alien = dpop();
 	displacement = unbox_unsigned_cell();
-	d = allot_object(DISPLACED_ALIEN_TYPE,sizeof(DISPLACED_ALIEN));
+	dpush(tag_object(make_alien(alien,displacement)));
-	d->alien = alien;
-	d->displacement = displacement;
-	dpush(tag_object(d));
 }
 
 /* address of an object representing a C pointer */
@@ -118,20 +103,15 @@ void primitive_string_to_alien(void)
 	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)
+void fixup_alien(ALIEN *d)
 {
 	data_fixup(&d->alien);
+	d->expired = true;
 }
 
 /* GC */
-void collect_displaced_alien(DISPLACED_ALIEN *d)
+void collect_alien(ALIEN *d)
 {
 	copy_handle(&d->alien);
 }

native/alien.h

@@ -1,6 +1,7 @@
 typedef struct {
 	CELL header;
-	void* ptr;
+	CELL alien;
+	CELL displacement;
 	bool expired;
 } ALIEN;
 
@@ -9,19 +10,9 @@ INLINE ALIEN* untag_alien_fast(CELL tagged)
 	return (ALIEN*)UNTAG(tagged);
 }
 
-typedef struct {
+ALIEN *make_alien(CELL delegate, CELL displacement);
-	CELL header;
-	CELL alien;
-	CELL displacement;
-} DISPLACED_ALIEN;
-
-INLINE DISPLACED_ALIEN* untag_displaced_alien_fast(CELL tagged)
-{
-	return (DISPLACED_ALIEN*)UNTAG(tagged);
-}
 
 void primitive_expired(void);
-void primitive_alien(void);
 void primitive_displaced_alien(void);
 void primitive_alien_address(void);
 
@@ -30,13 +21,11 @@ void* alien_offset(CELL object);
 void primitive_alien_to_string(void);
 void primitive_string_to_alien(void);
 
-void fixup_alien(ALIEN* alien);
+void fixup_alien(ALIEN* d);
-void fixup_displaced_alien(DISPLACED_ALIEN* d);
+void collect_alien(ALIEN* d);
-void collect_displaced_alien(DISPLACED_ALIEN* d);
 
 DLLEXPORT void *unbox_alien(void);
-ALIEN* alien(void* ptr);
+DLLEXPORT void box_alien(CELL ptr);
-DLLEXPORT void box_alien(void* ptr);
 
 void primitive_alien_signed_cell(void);
 void primitive_set_alien_signed_cell(void);

native/gc.c

@@ -185,8 +185,8 @@ INLINE void collect_object(CELL scan)
 	case DLL_TYPE:
 		collect_dll((DLL*)scan);
 		break;
-	case DISPLACED_ALIEN_TYPE:
+	case ALIEN_TYPE:
-		collect_displaced_alien((DISPLACED_ALIEN*)scan);
+		collect_alien((ALIEN*)scan);
 		break;
 	case WRAPPER_TYPE:
 		collect_wrapper((F_WRAPPER*)scan);

native/io.c

@@ -20,8 +20,8 @@ The native FFI streams in the library don't have this limitation. */
 
 void init_c_io(void)
 {
-	userenv[IN_ENV] = tag_object(alien(stdin));
+	userenv[IN_ENV] = tag_object(make_alien(F,(CELL)stdin));
-	userenv[OUT_ENV] = tag_object(alien(stdout));
+	userenv[OUT_ENV] = tag_object(make_alien(F,(CELL)stdout));
 }
 
 void io_error(void)
@@ -35,12 +35,12 @@ void primitive_fopen(void)
 	char *path, *mode;
 	FILE* file;
 	maybe_gc(0);
-	mode = unbox_c_string();
+	mode = pop_c_string();
-	path = unbox_c_string();
+	path = pop_c_string();
 	file = fopen(path,mode);
 	if(file == NULL)
 		io_error();
-	box_alien(file);
+	box_alien((CELL)file);
 }
 
 void primitive_fgetc(void)

native/memory.c

@@ -75,9 +75,6 @@ CELL untagged_object_size(CELL pointer)
 	case ALIEN_TYPE:
 		size = sizeof(ALIEN);
 		break;
-	case DISPLACED_ALIEN_TYPE:
-		size = sizeof(DISPLACED_ALIEN);
-		break;
 	case WRAPPER_TYPE:
 		size = sizeof(F_WRAPPER);
 		break;

native/memory.h

@@ -64,8 +64,7 @@ INLINE CELL align8(CELL a)
 
 /*** Header types ***/
 
-#define DISPLACED_ALIEN_TYPE 7
+#define ALIEN_TYPE 7
-
 #define ARRAY_TYPE 8
 
 /* Canonical F object */
@@ -78,7 +77,6 @@ INLINE CELL align8(CELL a)
 #define SBUF_TYPE 13
 #define WRAPPER_TYPE 14
 #define DLL_TYPE 15
-#define ALIEN_TYPE 16
 #define WORD_TYPE 17
 #define TUPLE_TYPE 18
 #define BYTE_ARRAY_TYPE 19

native/misc.c

@@ -19,7 +19,7 @@ void primitive_os_env(void)
 
 	maybe_gc(0);
 
-	name = unbox_c_string();
+	name = pop_c_string();
 	value = getenv(name);
 	if(value == NULL)
 		dpush(F);

native/primitives.c

@@ -126,7 +126,6 @@ void* primitives[] = {
 	primitive_dlopen,
 	primitive_dlsym,
 	primitive_dlclose,
-	primitive_alien,
 	primitive_byte_array,
 	primitive_displaced_alien,
 	primitive_alien_signed_cell,

native/relocate.c

@@ -29,9 +29,6 @@ void relocate_object(CELL relocating)
 	case ALIEN_TYPE:
 		fixup_alien((ALIEN*)relocating);
 		break;
-	case DISPLACED_ALIEN_TYPE:
-		fixup_displaced_alien((DISPLACED_ALIEN*)relocating);
-		break;
 	case WRAPPER_TYPE:
 		fixup_wrapper((F_WRAPPER*)relocating);
 		break;

native/string.c

@@ -175,6 +175,14 @@ char* unbox_c_string(void)
 		return (char*)alien_offset(str);
 }
 
+/* this function is used when we really want only Factor strings as input, not
+aliens. In particular, certian primitives crash if given a null pointer (f), so
+we protect against this by using this function instead of unbox_c_string() */
+char *pop_c_string(void)
+{
+	return to_c_string(untag_string(dpop()),true);
+}
+
 /* FFI calls this */
 u16* unbox_utf16_string(void)
 {

native/string.h

@@ -45,6 +45,7 @@ F_STRING* from_c_string(const char* c_string);
 F_STRING* memory_to_string(const BYTE* string, CELL length);
 void primitive_memory_to_string(void);
 DLLEXPORT char* unbox_c_string(void);
+char *pop_c_string(void);
 DLLEXPORT u16* unbox_utf16_string(void);
 
 /* untagged & unchecked */

native/unix/file.c

@@ -66,6 +66,6 @@ void primitive_cwd(void)
 void primitive_cd(void)
 {
 	maybe_gc(0);
-	chdir(unbox_c_string());
+	chdir(pop_c_string());
 }
 

native/win32/file.c

@@ -65,5 +65,5 @@ void primitive_cwd(void)
 void primitive_cd(void)
 {
 	maybe_gc(0);
-	SetCurrentDirectory(unbox_c_string());
+	SetCurrentDirectory(pop_c_string());
 }