huge alien cleanup

Makefile

@@ -20,7 +20,8 @@ OBJS = $(UNIX_OBJS) native/arithmetic.o native/array.o native/bignum.o \
 	native/sbuf.o native/stack.o \
 	native/string.o native/types.o native/vector.o \
 	native/word.o native/compiler.o \
-	native/ffi.o native/boolean.o \
+	native/alien.o native/dll.o \
+	native/boolean.o \
 	native/debug.o \
 	native/hashtable.o \
 	native/icache.o

Makefile.win32

@@ -1,5 +1,7 @@
+# :mode=makefile:
+
 CC = gcc
-DEFAULT_CFLAGS = -Wall -Os -fomit-frame-pointer $(SITE_CFLAGS)
+DEFAULT_CFLAGS = -Wall -O3 -fomit-frame-pointer $(SITE_CFLAGS)
 DEFAULT_LIBS = -lm
 
 STRIP = strip
@@ -8,21 +10,23 @@ WIN32_OBJS = native\win32\ffi.o native\win32\file.o native\win32\io.o \
 	native\win32\misc.o native\win32\read.o native\win32\write.o \
 	native\win32\run.o
 
-OBJS = $(WIN32_OBJS) native\arithmetic.o native\array.o native\bignum.o \
+OBJS = $(WIN32_OBJS) native/arithmetic.o native/array.o native/bignum.o \
-	native\s48_bignum.o \
+	native/s48_bignum.o \
-	native\complex.o native\cons.o native\error.o \
+	native/complex.o native/cons.o native/error.o \
-	native\factor.o native\fixnum.o \
+	native/factor.o native/fixnum.o \
-	native\float.o native\gc.o \
+	native/float.o native/gc.o \
-	native\image.o native\memory.o \
+	native/image.o native/memory.o \
-	native\misc.o native\port.o native\primitives.o \
+	native/misc.o native/port.o native/primitives.o \
-	native\ratio.o native\relocate.o \
+	native/ratio.o native/relocate.o \
-	native\run.o \
+	native/run.o \
-	native\sbuf.o native\stack.o \
+	native/sbuf.o native/stack.o \
-	native\string.o native\types.o native\vector.o \
+	native/string.o native/types.o native/vector.o \
-	native\word.o native\compiler.o \
+	native/word.o native/compiler.o \
-	native\ffi.o native\boolean.o \
+	native/alien.o native/dll.o \
-	native\debug.o \
+	native/boolean.o \
-	native\hashtable.o
+	native/debug.o \
+	native/hashtable.o \
+	native/icache.o
 
 default:
 	@echo "Run 'make' with one of the following parameters:"

library/alien/aliens.factor

@@ -0,0 +1,63 @@
+! Copyright (C) 2004, 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: alien
+USING: hashtables kernel lists math namespaces parser
+prettyprint stdio unparser ;
+
+BUILTIN: dll   15 [ 1 "dll-path" f ] ;
+BUILTIN: alien 16 ;
+BUILTIN: byte-array 19 ;
+BUILTIN: displaced-alien 20 ;
+
+: NULL ( -- null )
+    #! C null value.
+    0 <alien> ;
+
+: null? ( alien -- ? ) dup [ alien-address 0 = ] when ;
+
+: null>f ( alien -- alien/f )
+    dup alien-address 0 = [ drop f ] when ;
+
+M: alien hashcode ( obj -- n )
+    alien-address >fixnum ;
+
+M: alien = ( obj obj -- ? )
+    over alien? [
+        alien-address swap alien-address =
+    ] [
+        2drop f
+    ] ifte ;
+
+: ALIEN: scan <alien> swons ; parsing
+
+M: alien prettyprint* ( alien -- str )
+    \ ALIEN: word-bl alien-address unparse write ;
+
+M: dll unparse ( obj -- str )
+    [ "DLL\" " , dll-path unparse-string CHAR: " , ] make-string ;
+
+: DLL" skip-blank parse-string dlopen swons ; parsing
+
+: library ( name -- object )
+    dup [ "libraries" get hash ] when ;
+
+: load-dll ( name -- dll )
+    #! Higher level wrapper around dlopen primitive.
+    library dup [
+        [
+            "dll" get dup [
+                drop "name" get dlopen dup "dll" set
+            ] unless
+        ] bind
+    ] when ;
+
+: add-library ( library name abi -- )
+    "libraries" get [
+        <namespace> [
+          "abi" set
+          "name" set
+        ] extend put
+    ] bind ;
+
+: library-abi ( library -- abi )
+    library [ [ "abi" get ] bind ] [ "cdecl" ] ifte* ;

library/alien/c-types.factor

@@ -1,29 +1,8 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: alien
-USING: assembler compiler errors hashtables kernel lists math
+USING: assembler errors hashtables kernel namespaces parser
-namespaces parser strings words ;
+strings ;
-
-! Some code for interfacing with C structures.
-
-: BEGIN-ENUM:
-    #! C-style enumerations. Their use is not encouraged unless
-    #! it is for C library interfaces. Used like this:
-    #!
-    #! BEGIN-ENUM 0
-    #!     ENUM: x
-    #!     ENUM: y
-    #!     ENUM: z
-    #! END-ENUM
-    #!
-    #! This is the same as : x 0 ; : y 1 ; : z 2 ;.
-    scan str>number ; parsing
-
-: ENUM:
-    dup CREATE swap unit define-compound 1 + ; parsing
-
-: END-ENUM
-    drop ; parsing
 
 : <c-type> ( -- type )
     <namespace> [
@@ -47,66 +26,6 @@ SYMBOL: c-types
 : define-c-type ( quot name -- )
     c-types get [ >r <c-type> swap extend r> set ] bind ; inline
     
-: define-getter ( offset type name -- )
-    #! Define a word with stack effect ( alien -- obj ) in the
-    #! current 'in' vocabulary.
-    create-in >r
-    [ "getter" get ] bind cons r> swap define-compound ;
-
-: define-setter ( offset type name -- )
-    #! Define a word with stack effect ( obj alien -- ) in the
-    #! current 'in' vocabulary.
-    "set-" swap cat2 create-in >r
-    [ "setter" get ] bind cons r> swap define-compound ;
-
-: define-field ( offset type name -- offset )
-    >r c-type dup >r [ "align" get ] bind align r> r>
-    "struct-name" get swap "-" swap cat3
-    ( offset type name -- )
-    3dup define-getter 3dup define-setter
-    drop [ "width" get ] bind + ;
-
-: define-member ( max type -- max )
-    c-type [ "width" get ] bind max ;
-
-: define-constructor ( width -- )
-    #! Make a word <foo> where foo is the structure name that
-    #! allocates a Factor heap-local instance of this structure.
-    #! Used for C functions that expect you to pass in a struct.
-    [ <local-alien> ] cons
-    [ "<" , "struct-name" get , ">" , ] make-string
-    create-in swap
-    define-compound ;
-
-: define-struct-type ( width -- )
-    #! Define inline and pointer type for the struct. Pointer
-    #! type is exactly like void*.
-    [ "width" set ] "struct-name" get define-c-type
-    "void*" c-type "struct-name" get "*" cat2
-    c-types get set-hash ;
-
-: BEGIN-STRUCT: ( -- offset )
-    scan "struct-name" set  0 ; parsing
-
-: FIELD: ( offset -- offset )
-    scan scan define-field ; parsing
-
-: END-STRUCT ( length -- )
-    dup define-constructor define-struct-type ; parsing
-
-: BEGIN-UNION: ( -- max )
-    scan "struct-name" set  0 ; parsing
-
-: MEMBER: ( max -- max )
-    scan define-member ; parsing
-
-: END-UNION ( max -- )
-    dup define-constructor define-struct-type ; parsing
-
-: NULL ( -- null )
-    #! C null value.
-    0 <alien> ;
-
 global [ <namespace> c-types set ] bind
 
 [

library/alien/compiler.factor

@@ -1,9 +1,8 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: alien
-USING: assembler compiler errors generic hashtables
+USING: assembler errors generic inference kernel lists math
-inference interpreter kernel lists math namespaces parser
+namespaces sequences stdio strings words ;
-prettyprint sequences stdio strings unparser words ;
 
 ! ! ! WARNING ! ! !
 ! Reloading this file into a running Factor instance on Win32
@@ -24,70 +23,11 @@ prettyprint sequences stdio strings unparser words ;
 ! parameter, or a missing abi parameter indicates the cdecl ABI
 ! should be used, which is common on Unix.
 
-: null? ( alien -- ? ) dup [ alien-address 0 = ] when ;
-
-: null>f ( alien -- alien/f )
-    dup alien-address 0 = [ drop f ] when ;
-
-M: alien hashcode ( obj -- n )
-    alien-address >fixnum ;
-
-M: alien = ( obj obj -- ? )
-    over alien? [
-        over local-alien? over local-alien? or [
-            eq?
-        ] [
-            alien-address swap alien-address =
-        ] ifte
-    ] [
-        2drop f
-    ] ifte ;
-
-: ALIEN: scan <alien> swons ; parsing
-
-: LOCAL-ALIEN: "Local aliens are not readable" throw ; parsing
-
-M: alien prettyprint* ( alien -- str )
-    dup local-alien? [
-        \ LOCAL-ALIEN:
-    ] [
-        \ ALIEN:
-    ] ifte word-bl alien-address unparse write ;
-
-M: dll unparse ( obj -- str )
-    [ "DLL\" " , dll-path unparse-string CHAR: " , ] make-string ;
-
-: DLL" skip-blank parse-string dlopen swons ; parsing
-
-: library ( name -- object )
-    dup [ "libraries" get hash ] when ;
-
-: load-dll ( name -- dll )
-    #! Higher level wrapper around dlopen primitive.
-    library dup [
-        [
-            "dll" get dup [
-                drop "name" get dlopen dup "dll" set
-            ] unless
-        ] bind
-    ] when ;
-
-: add-library ( library name abi -- )
-    "libraries" get [
-        <namespace> [
-          "abi" set
-          "name" set
-        ] extend put
-    ] bind ;
-    
 SYMBOL: #cleanup ( unwind stack by parameter )
 
 SYMBOL: #unbox ( move top of datastack to C stack )
 SYMBOL: #box ( move EAX to datastack )
 
-: library-abi ( library -- abi )
-    library [ [ "abi" get ] bind ] [ "cdecl" ] ifte* ;
-
 SYMBOL: #alien-invoke
 SYMBOL: #alien-global
 

library/alien/enums.factor

@@ -0,0 +1,23 @@
+! Copyright (C) 2004, 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: alien
+USING: kernel lists math parser words ;
+
+: BEGIN-ENUM:
+    #! C-style enumerations. Their use is not encouraged unless
+    #! it is for C library interfaces. Used like this:
+    #!
+    #! BEGIN-ENUM 0
+    #!     ENUM: x
+    #!     ENUM: y
+    #!     ENUM: z
+    #! END-ENUM
+    #!
+    #! This is the same as : x 0 ; : y 1 ; : z 2 ;.
+    scan str>number ; parsing
+
+: ENUM:
+    dup CREATE swap unit define-compound 1 + ; parsing
+
+: END-ENUM
+    drop ; parsing

library/alien/structs.factor

@@ -0,0 +1,63 @@
+! Copyright (C) 2004, 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: alien
+USING: assembler compiler errors hashtables kernel lists math
+namespaces parser strings words ;
+
+! Some code for interfacing with C structures.
+
+: define-getter ( offset type name -- )
+    #! Define a word with stack effect ( alien -- obj ) in the
+    #! current 'in' vocabulary.
+    create-in >r
+    [ "getter" get ] bind cons r> swap define-compound ;
+
+: define-setter ( offset type name -- )
+    #! Define a word with stack effect ( obj alien -- ) in the
+    #! current 'in' vocabulary.
+    "set-" swap cat2 create-in >r
+    [ "setter" get ] bind cons r> swap define-compound ;
+
+: define-field ( offset type name -- offset )
+    >r c-type dup >r [ "align" get ] bind align r> r>
+    "struct-name" get swap "-" swap cat3
+    ( offset type name -- )
+    3dup define-getter 3dup define-setter
+    drop [ "width" get ] bind + ;
+
+: define-member ( max type -- max )
+    c-type [ "width" get ] bind max ;
+
+: define-constructor ( width -- )
+    #! Make a word <foo> where foo is the structure name that
+    #! allocates a Factor heap-local instance of this structure.
+    #! Used for C functions that expect you to pass in a struct.
+    [ <byte-array> ] cons
+    [ "<" , "struct-name" get , ">" , ] make-string
+    create-in swap
+    define-compound ;
+
+: define-struct-type ( width -- )
+    #! Define inline and pointer type for the struct. Pointer
+    #! type is exactly like void*.
+    [ "width" set ] "struct-name" get define-c-type
+    "void*" c-type "struct-name" get "*" cat2
+    c-types get set-hash ;
+
+: BEGIN-STRUCT: ( -- offset )
+    scan "struct-name" set  0 ; parsing
+
+: FIELD: ( offset -- offset )
+    scan scan define-field ; parsing
+
+: END-STRUCT ( length -- )
+    dup define-constructor define-struct-type ; parsing
+
+: BEGIN-UNION: ( -- max )
+    scan "struct-name" set  0 ; parsing
+
+: MEMBER: ( max -- max )
+    scan define-member ; parsing
+
+: END-UNION ( max -- )
+    dup define-constructor define-struct-type ; parsing

library/bootstrap/boot-stage1.factor

@@ -54,6 +54,7 @@ hashtables ;
         "/library/syntax/prettyprint.factor"
         "/library/io/files.factor"
         "/library/cli.factor"
+        "/library/alien/aliens.factor"
     ] pull-in
 
     "delegate" [ "generic" ] search

library/bootstrap/boot-stage2.factor

@@ -38,8 +38,9 @@ t [
     "/library/compiler/simplifier.factor"
     "/library/compiler/generator.factor"
     "/library/compiler/compiler.factor"
-    "/library/compiler/alien-types.factor"
+
-    "/library/compiler/alien.factor"
+    "/library/alien/c-types.factor"
+    "/library/alien/compiler.factor"
 ] pull-in
 
 cpu "x86" = [

library/bootstrap/boot-stage3.factor

@@ -14,6 +14,9 @@ unparser ;
 ] when
 
 t [
+    "/library/alien/enums.factor"
+    "/library/alien/structs.factor"
+
     "/library/math/constants.factor"
     "/library/math/pow.factor"
     "/library/math/trig-hyp.factor"

library/bootstrap/primitives.factor

@@ -181,7 +181,8 @@ vocabularies get [
     [ "dlsym" "alien"                         [ [ string object ] [ integer ] ] ]
     [ "dlclose" "alien"                       [ [ dll ] [ ] ] ]
     [ "<alien>" "alien"                       [ [ integer ] [ alien ] ] ]
-    [ "<local-alien>" "alien"                 [ [ integer ] [ alien ] ] ]
+    [ "<byte-array>" "alien"                  [ [ integer ] [ byte-array ] ] ]
+    [ "<displaced-alien>" "alien"             [ [ integer object ] [ displaced-alien ] ] ]
     [ "alien-signed-cell" "alien"             [ [ alien integer ] [ integer ] ] ]
     [ "set-alien-signed-cell" "alien"         [ [ integer alien integer ] [ ] ] ]
     [ "alien-unsigned-cell" "alien"           [ [ alien integer ] [ integer ] ] ]
@@ -206,7 +207,6 @@ vocabularies get [
     [ "throw" "errors"                        [ [ object ] [ ] ] ]
     [ "string>memory" "kernel-internals"      [ [ string integer ] [ ] ] ]
     [ "memory>string" "kernel-internals"      [ [ integer integer ] [ string ] ] ]
-    [ "local-alien?" "alien"                  [ [ alien ] [ object ] ] ]
     [ "alien-address" "alien"                 [ [ alien ] [ integer ] ] ]
     [ "slot" "kernel-internals"               [ [ object fixnum ] [ object ] ] ]
     [ "set-slot" "kernel-internals"           [ [ object object fixnum ] [ ] ] ]

library/kernel.factor

@@ -29,7 +29,7 @@ M: object clone ;
 
 : num-types ( -- n )
     #! One more than the maximum value from type primitive.
-    19 ;
+    21 ;
 
 : ? ( cond t f -- t/f )
     #! Push t if cond is true, otherwise push f.
@@ -41,10 +41,3 @@ M: object clone ;
 : not ( a -- ~a ) f t ? ; inline
 : or ( a b -- a|b ) t swap ? ; inline
 : xor ( a b -- a^b ) dup not swap ? ; inline
-
-IN: alien
-
-! See compiler/alien.factor for the rest; this needs to be here
-! since primitive stack effects involve alien inputs/outputs.
-BUILTIN: dll   15 [ 1 "dll-path" f ] ;
-BUILTIN: alien 16 ;

library/sequences-epilogue.factor

@@ -58,6 +58,15 @@ M: sequence = ( obj seq -- ? )
 
 : >pop> ( stack -- stack ) dup pop drop ;
 
+GENERIC: (tree-each) ( quot obj -- ) inline
+M: object (tree-each) swap call ;
+M: cons (tree-each) [ car (tree-each) ] 2keep cdr (tree-each) ;
+M: f (tree-each) swap call ;
+M: sequence (tree-each) [ swap call ] seq-each-with ;
+: tree-each swap (tree-each) ; inline
+: tree-each-with ( obj vector quot -- )
+    swap [ with ] tree-each 2drop ; inline
+
 IN: kernel
 
 : depth ( -- n )

library/test/alien.factor

@@ -6,10 +6,8 @@ USE: inference
 
 [ t ] [ 0 <alien> 0 <alien> = ] unit-test
 [ f ] [ 0 <alien> local-alien? ] unit-test
-[ f ] [ 0 <alien> 1024 <local-alien> = ] unit-test
 [ f ] [ 0 <alien> 1024 <alien> = ] unit-test
 [ f ] [ "hello" 1024 <alien> = ] unit-test
-[ t ] [ 1024 <local-alien> local-alien? ] unit-test
 
 ! : alien-inference-1
 !     "void" "foobar" "boo" [ "short" "short" ] alien-invoke ;

library/ui/paint.factor

@@ -9,7 +9,7 @@ stdio strings ;
 SYMBOL: clip
 
 : intersect* ( gadget rect quot -- t1 t2 )
-    call >r >r max r> r> min 2dup > [ drop dup ] when ;
+    call >r >r max r> r> min 2dup > [ drop dup ] when ; inline
 
 : intersect-x ( gadget rect -- x1 x2 )
     [

library/win32/winsock.factor

@@ -29,7 +29,7 @@ IN: win32-api
 USE: alien
 USE: kernel
 
-: <wsadata> HEX: 190 <local-alien> ;
+: <wsadata> HEX: 190 <byte-array> ;
 
 : AF_INET 2 ;
 : SOCK_STREAM 1 ;

library/words.factor

@@ -4,16 +4,6 @@ IN: words
 USING: generic hashtables kernel kernel-internals lists math
 namespaces sequences strings vectors ;
 
-! Utility
-GENERIC: (tree-each) ( quot obj -- ) inline
-M: object (tree-each) swap call ;
-M: cons (tree-each) [ car (tree-each) ] 2keep cdr (tree-each) ;
-M: f (tree-each) swap call ;
-M: sequence (tree-each) [ swap call ] seq-each-with ;
-: tree-each swap (tree-each) ; inline
-: tree-each-with ( obj vector quot -- )
-    swap [ with ] tree-each 2drop ; inline
-
 ! The basic word type. Words can be named and compared using
 ! identity. They hold a property map.
 BUILTIN: word 17

native/alien.c

@@ -0,0 +1,114 @@
+#include "factor.h"
+
+INLINE void* alien_offset(CELL object)
+{
+	ALIEN *alien;
+	F_ARRAY *array;
+	DISPLACED_ALIEN *d;
+
+	switch(type_of(object))
+	{
+	case ALIEN_TYPE:
+		alien = untag_alien_fast(object);
+		if(alien->expired)
+			general_error(ERROR_EXPIRED,object);
+		return alien->ptr;
+	case BYTE_ARRAY_TYPE:
+		array = untag_byte_array_fast(object);
+		return array + sizeof(F_ARRAY);
+	case DISPLACED_ALIEN_TYPE:
+		d = untag_displaced_alien_fast(object);
+		return alien_offset(d->alien) + d->displacement;
+	default:
+		type_error(ALIEN_TYPE,object);
+		return (void*)-1; /* can't happen */
+	}
+}
+
+INLINE void* alien_pointer(void)
+{
+	F_FIXNUM offset = unbox_signed_cell();
+	return alien_offset(dpop()) + offset;
+}
+
+void* unbox_alien(void)
+{
+	return alien_offset(dpop());
+}
+
+void box_alien(void* ptr)
+{
+	ALIEN* alien = allot_object(ALIEN_TYPE,sizeof(ALIEN));
+	alien->ptr = ptr;
+	alien->expired = false;
+	dpush(tag_object(alien));
+}
+
+void primitive_alien(void)
+{
+	void* ptr = (void*)unbox_signed_cell();
+	maybe_garbage_collection();
+	box_alien(ptr);
+}
+
+void primitive_displaced_alien(void)
+{
+	CELL alien;
+	CELL displacement;
+	DISPLACED_ALIEN* d;
+	maybe_garbage_collection();
+	alien = dpop();
+	displacement = unbox_unsigned_cell();
+	d = allot_object(DISPLACED_ALIEN_TYPE,sizeof(DISPLACED_ALIEN));
+	d->alien = alien;
+	d->displacement = displacement;
+	dpush(tag_object(d));
+}
+
+void primitive_alien_address(void)
+{
+	box_unsigned_cell((CELL)alien_offset(dpop()));
+}
+
+void fixup_alien(ALIEN* alien)
+{
+	alien->expired = true;
+}
+
+void fixup_displaced_alien(DISPLACED_ALIEN* d)
+{
+	data_fixup(&d->alien);
+}
+
+void collect_displaced_alien(DISPLACED_ALIEN* d)
+{
+	COPY_OBJECT(d->alien);
+}
+
+#define DEF_ALIEN_SLOT(name,type,boxer) \
+void primitive_alien_##name (void) \
+{ \
+	box_##boxer (*(type*)alien_pointer()); \
+} \
+void primitive_set_alien_##name (void) \
+{ \
+	type* ptr = alien_pointer(); \
+	type value = unbox_##boxer (); \
+	*ptr = value; \
+}
+
+DEF_ALIEN_SLOT(signed_cell,int,signed_cell)
+DEF_ALIEN_SLOT(unsigned_cell,CELL,unsigned_cell)
+DEF_ALIEN_SLOT(signed_8,s64,signed_8)
+DEF_ALIEN_SLOT(unsigned_8,u64,unsigned_8)
+DEF_ALIEN_SLOT(signed_4,s32,signed_4)
+DEF_ALIEN_SLOT(unsigned_4,u32,unsigned_4)
+DEF_ALIEN_SLOT(signed_2,s16,signed_2)
+DEF_ALIEN_SLOT(unsigned_2,u16,unsigned_2)
+DEF_ALIEN_SLOT(signed_1,BYTE,signed_1)
+DEF_ALIEN_SLOT(unsigned_1,BYTE,unsigned_1)
+
+void primitive_alien_value_string(void)
+{
+	box_c_string(alien_pointer());
+}

native/alien.h

@@ -1,43 +1,36 @@
-typedef struct {
-	CELL header;
-	/* tagged string */
-	CELL path;
-	/* OS-specific handle */
-	void* dll;
-} DLL;
-
-DLL* untag_dll(CELL tagged);
-
 typedef struct {
 	CELL header;
 	void* ptr;
-	/* local aliens are heap-allocated as strings and must be collected. */
+	bool expired;
-	bool local;
 } ALIEN;
 
-INLINE ALIEN* untag_alien(CELL tagged)
+INLINE ALIEN* untag_alien_fast(CELL tagged)
 {
-	type_check(ALIEN_TYPE,tagged);
 	return (ALIEN*)UNTAG(tagged);
 }
 
-void ffi_dlopen(DLL *dll);
+typedef struct {
-void *ffi_dlsym(DLL *dll, F_STRING *symbol);
+	CELL header;
-void ffi_dlclose(DLL *dll);
+	CELL alien;
+	CELL displacement;
+} DISPLACED_ALIEN;
+
+INLINE DISPLACED_ALIEN* untag_displaced_alien_fast(CELL tagged)
+{
+	return (DISPLACED_ALIEN*)UNTAG(tagged);
+}
 
-void primitive_dlopen(void);
-void primitive_dlsym(void);
-void primitive_dlclose(void);
 void primitive_alien(void);
-void primitive_local_alien(void);
+void primitive_displaced_alien(void);
-void fixup_dll(DLL* dll);
+void primitive_alien_address(void);
-void collect_dll(DLL* dll);
+
 void fixup_alien(ALIEN* alien);
-void collect_alien(ALIEN* alien);
+void fixup_displaced_alien(DISPLACED_ALIEN* d);
+void collect_displaced_alien(DISPLACED_ALIEN* d);
+
 DLLEXPORT void* unbox_alien(void);
 DLLEXPORT void box_alien(void* ptr);
-void primitive_local_alienp(void);
+
-void primitive_alien_address(void);
 void primitive_alien_signed_cell(void);
 void primitive_set_alien_signed_cell(void);
 void primitive_alien_unsigned_cell(void);

native/array.c

@@ -32,6 +32,12 @@ void primitive_tuple(void)
 	dpush(tag_object(array(TUPLE_TYPE,to_fixnum(dpop()),F)));
 }
 
+void primitive_byte_array(void)
+{
+	maybe_garbage_collection();
+	dpush(tag_object(array(BYTE_ARRAY_TYPE,to_fixnum(dpop()),0)));
+}
+
 F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill)
 {
 	/* later on, do an optimization: if end of array is here, just grow */
@@ -50,7 +56,7 @@ void primitive_grow_array(void)
 {
 	F_ARRAY* array; CELL capacity;
 	maybe_garbage_collection();
-	array = untag_array(dpop());
+	array = untag_array_fast(dpop());
 	capacity = to_fixnum(dpop());
 	dpush(tag_object(grow_array(array,capacity,F)));
 }

native/array.h

@@ -4,16 +4,23 @@ typedef struct {
 	CELL capacity;
 } F_ARRAY;
 
-INLINE F_ARRAY* untag_array(CELL tagged)
+INLINE F_ARRAY* untag_array_fast(CELL tagged)
+{
+	return (F_ARRAY*)UNTAG(tagged);
+}
+
+INLINE F_ARRAY* untag_byte_array_fast(CELL tagged)
 {
-	type_check(ARRAY_TYPE,tagged);
 	return (F_ARRAY*)UNTAG(tagged);
 }
 
 F_ARRAY* allot_array(CELL type, CELL capacity);
 F_ARRAY* array(CELL type, CELL capacity, CELL fill);
+
 void primitive_array(void);
 void primitive_tuple(void);
+void primitive_byte_array(void);
+
 F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill);
 void primitive_grow_array(void);
 F_ARRAY* shrink_array(F_ARRAY* array, CELL capacity);

native/debug.c

@@ -60,7 +60,7 @@ CELL hash(CELL hash, CELL key)
 			return F;
 		}
 
-		a = untag_array(array);
+		a = untag_array_fast(array);
 
 		for(i = 0; i < array_capacity(a); i++)
 		{

native/dll.c

@@ -0,0 +1,57 @@
+#include "factor.h"
+
+void primitive_dlopen(void)
+{
+	DLL* dll;
+	F_STRING* path;
+
+	maybe_garbage_collection();
+
+	path = untag_string(dpop());
+	dll = allot_object(DLL_TYPE,sizeof(DLL));
+	dll->path = tag_object(path);
+	ffi_dlopen(dll);
+
+	dpush(tag_object(dll));
+}
+
+void primitive_dlsym(void)
+{
+	CELL dll;
+	F_STRING* sym;
+
+	maybe_garbage_collection();
+
+	dll = dpop();
+	sym = untag_string(dpop());
+
+	dpush(tag_cell((CELL)ffi_dlsym(
+		dll == F ? NULL : untag_dll(dll),
+		sym)));
+}
+
+void primitive_dlclose(void)
+{
+	maybe_garbage_collection();
+	ffi_dlclose(untag_dll(dpop()));
+}
+
+DLL* untag_dll(CELL tagged)
+{
+	DLL* dll = (DLL*)UNTAG(tagged);
+	type_check(DLL_TYPE,tagged);
+	if(dll->dll == NULL)
+		general_error(ERROR_EXPIRED,tagged);
+	return (DLL*)UNTAG(tagged);
+}
+
+void fixup_dll(DLL* dll)
+{
+	data_fixup(&dll->path);
+	ffi_dlopen(dll);
+}
+
+void collect_dll(DLL* dll)
+{
+	COPY_OBJECT(dll->path);
+}

native/dll.h

@@ -0,0 +1,20 @@
+typedef struct {
+	CELL header;
+	/* tagged string */
+	CELL path;
+	/* OS-specific handle */
+	void* dll;
+} DLL;
+
+DLL* untag_dll(CELL tagged);
+
+void ffi_dlopen(DLL *dll);
+void *ffi_dlsym(DLL *dll, F_STRING *symbol);
+void ffi_dlclose(DLL *dll);
+
+void primitive_dlopen(void);
+void primitive_dlsym(void);
+void primitive_dlclose(void);
+
+void fixup_dll(DLL* dll);
+void collect_dll(DLL* dll);

native/factor.h

@@ -144,7 +144,8 @@ typedef unsigned char BYTE;
 #include "stack.h"
 #include "compiler.h"
 #include "relocate.h"
-#include "ffi.h"
+#include "alien.h"
+#include "dll.h"
 #include "debug.h"
 
 #endif /* __FACTOR_H__ */

native/ffi.c

@@ -1,159 +0,0 @@
-#include "factor.h"
-
-void foo(int fd) { close(fd); }
-
-void primitive_dlopen(void)
-{
-	DLL* dll;
-	F_STRING* path;
-
-	maybe_garbage_collection();
-
-	path = untag_string(dpop());
-	dll = allot_object(DLL_TYPE,sizeof(DLL));
-	dll->path = tag_object(path);
-	ffi_dlopen(dll);
-
-	dpush(tag_object(dll));
-}
-
-void primitive_dlsym(void)
-{
-	CELL dll;
-	F_STRING* sym;
-
-	maybe_garbage_collection();
-
-	dll = dpop();
-	sym = untag_string(dpop());
-
-	dpush(tag_cell((CELL)ffi_dlsym(
-		dll == F ? NULL : untag_dll(dll),
-		sym)));
-}
-
-void primitive_dlclose(void)
-{
-	maybe_garbage_collection();
-	ffi_dlclose(untag_dll(dpop()));
-}
-
-DLL* untag_dll(CELL tagged)
-{
-	DLL* dll = (DLL*)UNTAG(tagged);
-	type_check(DLL_TYPE,tagged);
-	if(dll->dll == NULL)
-		general_error(ERROR_EXPIRED,tagged);
-	return (DLL*)UNTAG(tagged);
-}
-
-void* unbox_alien(void)
-{
-	return untag_alien(dpop())->ptr;
-}
-
-void box_alien(void* ptr)
-{
-	ALIEN* alien = allot_object(ALIEN_TYPE,sizeof(ALIEN));
-	alien->ptr = ptr;
-	alien->local = false;
-	dpush(tag_object(alien));
-}
-
-INLINE void* alien_pointer(void)
-{
-	F_FIXNUM offset = unbox_signed_cell();
-	ALIEN* alien = untag_alien(dpop());
-	void* ptr = alien->ptr;
-
-	if(ptr == NULL)
-		general_error(ERROR_EXPIRED,tag_object(alien));
-
-	return ptr + offset;
-}
-
-void primitive_alien(void)
-{
-	void* ptr = (void*)unbox_signed_cell();
-	maybe_garbage_collection();
-	box_alien(ptr);
-}
-
-void primitive_local_alien(void)
-{
-	F_FIXNUM length = unbox_signed_cell();
-	ALIEN* alien;
-	F_STRING* local;
-	if(length < 0)
-		general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_fixnum(length));
-	maybe_garbage_collection();
-	alien = allot_object(ALIEN_TYPE,sizeof(ALIEN));
-	local = string(length / CHARS,'\0');
-	alien->ptr = (void*)(local + 1);
-	alien->local = true;
-	dpush(tag_object(alien));
-}
-
-void primitive_local_alienp(void)
-{
-	box_boolean(untag_alien(dpop())->local);
-}
-
-void primitive_alien_address(void)
-{
-	box_unsigned_cell((CELL)untag_alien(dpop())->ptr);
-}
-
-void fixup_dll(DLL* dll)
-{
-	data_fixup(&dll->path);
-	ffi_dlopen(dll);
-}
-
-void collect_dll(DLL* dll)
-{
-	COPY_OBJECT(dll->path);
-}
-
-void fixup_alien(ALIEN* alien)
-{
-	alien->ptr = NULL;
-}
-
-void collect_alien(ALIEN* alien)
-{
-	if(alien->local && alien->ptr != NULL)
-	{
-		F_STRING* ptr = (F_STRING*)(alien->ptr - sizeof(F_STRING));
-		ptr = copy_untagged_object(ptr,SSIZE(ptr));
-		alien->ptr = (void*)(ptr + 1);
-	}
-}
-
-#define DEF_ALIEN_SLOT(name,type,boxer) \
-void primitive_alien_##name (void) \
-{ \
-	box_##boxer (*(type*)alien_pointer()); \
-} \
-void primitive_set_alien_##name (void) \
-{ \
-	type* ptr = alien_pointer(); \
-	type value = unbox_##boxer (); \
-	*ptr = value; \
-}
-
-DEF_ALIEN_SLOT(signed_cell,int,signed_cell)
-DEF_ALIEN_SLOT(unsigned_cell,CELL,unsigned_cell)
-DEF_ALIEN_SLOT(signed_8,s64,signed_8)
-DEF_ALIEN_SLOT(unsigned_8,u64,unsigned_8)
-DEF_ALIEN_SLOT(signed_4,s32,signed_4)
-DEF_ALIEN_SLOT(unsigned_4,u32,unsigned_4)
-DEF_ALIEN_SLOT(signed_2,s16,signed_2)
-DEF_ALIEN_SLOT(unsigned_2,u16,unsigned_2)
-DEF_ALIEN_SLOT(signed_1,BYTE,signed_1)
-DEF_ALIEN_SLOT(unsigned_1,BYTE,unsigned_1)
-
-void primitive_alien_value_string(void)
-{
-	box_c_string(alien_pointer());
-}

native/gc.c

@@ -79,12 +79,12 @@ INLINE void collect_object(CELL scan)
 	case PORT_TYPE:
 		collect_port((F_PORT*)scan);
 		break;
-	case ALIEN_TYPE:
-		collect_alien((ALIEN*)scan);
-		break;
 	case DLL_TYPE:
 		collect_dll((DLL*)scan);
 		break;
+	case DISPLACED_ALIEN_TYPE:
+		collect_displaced_alien((DISPLACED_ALIEN*)scan);
+		break;
 	}
 }
 

native/primitives.c

@@ -145,7 +145,8 @@ void* primitives[] = {
 	primitive_dlsym,
 	primitive_dlclose,
 	primitive_alien,
-	primitive_local_alien,
+	primitive_byte_array,
+	primitive_displaced_alien,
 	primitive_alien_signed_cell,
 	primitive_set_alien_signed_cell,
 	primitive_alien_unsigned_cell,
@@ -170,7 +171,6 @@ void* primitives[] = {
 	primitive_throw,
 	primitive_string_to_memory,
 	primitive_memory_to_string,
-	primitive_local_alienp,
 	primitive_alien_address,
 	primitive_slot,
 	primitive_set_slot,

native/relocate.c

@@ -32,6 +32,9 @@ void relocate_object(CELL relocating)
 	case ALIEN_TYPE:
 		fixup_alien((ALIEN*)relocating);
 		break;
+	case DISPLACED_ALIEN_TYPE:
+		fixup_displaced_alien((DISPLACED_ALIEN*)relocating);
+		break;
 	}
 }
 

native/stack.c

@@ -75,7 +75,7 @@ F_VECTOR* stack_to_vector(CELL bottom, CELL top)
 {
 	CELL depth = (top - bottom + CELLS) / CELLS;
 	F_VECTOR* v = vector(depth);
-	F_ARRAY* a = untag_array(v->array);
+	F_ARRAY* a = untag_array_fast(v->array);
 	memcpy(a + 1,(void*)bottom,depth * CELLS);
 	v->top = tag_fixnum(depth);
 	return v;
@@ -98,7 +98,7 @@ CELL vector_to_stack(F_VECTOR* vector, CELL bottom)
 {
 	CELL start = bottom;
 	CELL len = untag_fixnum_fast(vector->top) * CELLS;
-	memcpy((void*)start,untag_array(vector->array) + 1,len);
+	memcpy((void*)start,untag_array_fast(vector->array) + 1,len);
 	return start + len - CELLS;
 }
 

native/types.c

@@ -52,8 +52,9 @@ CELL untagged_object_size(CELL pointer)
 		size = CELLS * 2;
 		break;
 	case ARRAY_TYPE:
-	case BIGNUM_TYPE:
 	case TUPLE_TYPE:
+	case BIGNUM_TYPE:
+	case BYTE_ARRAY_TYPE:
 		size = align8(sizeof(F_ARRAY) +
 			array_capacity((F_ARRAY*)(pointer)) * CELLS);
 		break;
@@ -81,6 +82,9 @@ CELL untagged_object_size(CELL pointer)
 	case ALIEN_TYPE:
 		size = sizeof(ALIEN);
 		break;
+	case DISPLACED_ALIEN_TYPE:
+		size = sizeof(DISPLACED_ALIEN);
+		break;
 	default:
 		critical_error("Cannot determine size",pointer);
 		size = -1;/* can't happen */

native/types.h

@@ -36,8 +36,10 @@ CELL T;
 #define ALIEN_TYPE 16
 #define WORD_TYPE 17
 #define TUPLE_TYPE 18
+#define BYTE_ARRAY_TYPE 19
+#define DISPLACED_ALIEN_TYPE 20
 
-#define TYPE_COUNT 19
+#define TYPE_COUNT 21
 
 INLINE bool headerp(CELL cell)
 {