local aliens

diff --git a/library/compiler/alien-types.factor b/library/compiler/alien-types.factor
index 9dbb76a348334cbc1363ca61f403beee91e567b9..bc411301bb71c1552082cf98c1c27b7dcb588daf 100644 (file)
--- a/library/compiler/alien-types.factor
+++ b/library/compiler/alien-types.factor
@@ -83,7 +83,14 @@ USE: words
 
 : define-constructor ( len -- )
     [ <alien> ] cons
-    <% "<" % "struct-name" get % ">" % %> "in" get create swap
+    <% "<" % "struct-name" get % ">" % %>
+    "in" get create swap
+    define-compound ;
+
+: define-local-constructor ( len -- )
+    [ <local-alien> ] cons
+    <% "<local-" % "struct-name" get % ">" % %>
+    "in" get create swap
     define-compound ;
 
 : define-struct-type ( len -- )
@@ -103,6 +110,7 @@ USE: words
         "struct-name" set
         0 swap [ define-field ] each
         dup define-constructor
+        dup define-local-constructor
         define-struct-type
     ] with-scope ;
 

diff --git a/library/cross-compiler.factor b/library/cross-compiler.factor
index 54f5485758fff53d33d49f819d80c8a263a488ed..470db22e39f55d2522e5c657d356cd3496cfdb6a 100644 (file)
--- a/library/cross-compiler.factor
+++ b/library/cross-compiler.factor
@@ -46,6 +46,7 @@ DEFER: dlsym
 DEFER: dlsym-self
 DEFER: dlclose
 DEFER: <alien>
+DEFER: <local-alien>
 DEFER: alien-cell
 DEFER: set-alien-cell
 DEFER: alien-4
@@ -369,6 +370,7 @@ IN: image
         dlsym-self
         dlclose
         <alien>
+        <local-alien>
         alien-cell
         set-alien-cell
         alien-4

diff --git a/library/math/math.factor b/library/math/math.factor
index 3c122868888f7f24d9d38b81af9c62cd2bae3720..59e9298bb66675ef1def0ed36e2fe92823be679b 100644 (file)
--- a/library/math/math.factor
+++ b/library/math/math.factor
@@ -45,12 +45,6 @@ USE: stack
     ! This is the naive implementation, for benchmarking purposes.
     1 swap [ succ * ] times* ;
 
-: 2^ ( x -- 2^x )
-    1 swap [ 2 * ] times ;
-
-: harmonic ( n -- 1 + 1/2 + 1/3 + ... + 1/n )
-    0 swap [ succ recip + ] times* ;
-
 : mag2 ( x y -- mag )
     #! Returns the magnitude of the vector (x,y).
     swap sq swap sq + fsqrt ;

diff --git a/library/platform/native/boot-stage2.factor b/library/platform/native/boot-stage2.factor
index 8202e04ede2f0278a5a9a509dfc2fc6881f004fa..8bcb05785d9de4a6fd0be310e107815975c500e5 100644 (file)
--- a/library/platform/native/boot-stage2.factor
+++ b/library/platform/native/boot-stage2.factor
@@ -37,6 +37,7 @@ USE: stdio
 [
     "/library/platform/native/kernel.factor"
     "/library/platform/native/stack.factor"
+    "/library/platform/native/types.factor"
     "/library/cons.factor"
     "/library/combinators.factor"
     "/library/logic.factor"

diff --git a/library/platform/native/boot.factor b/library/platform/native/boot.factor
index 4ccc587a4dc30574a61f9704bf07d30609cad083..b96d10d2e5fe5451231a5c22997e1baea0cb16b9 100644 (file)
--- a/library/platform/native/boot.factor
+++ b/library/platform/native/boot.factor
@@ -33,6 +33,7 @@ primitives,
     "/library/platform/native/kernel.factor"
     "/library/platform/native/stack.factor"
     "/library/platform/native/types.factor"
+    "/library/math/math.factor"
     "/library/platform/native/math.factor"
     "/library/cons.factor"
     "/library/combinators.factor"

diff --git a/library/platform/native/debugger.factor b/library/platform/native/debugger.factor
index 683586f1c5e91283f2ddff1a49164fcf8b2f26f0..8a827707cbd05733133f3489bd74f96b72aef551 100644 (file)
--- a/library/platform/native/debugger.factor
+++ b/library/platform/native/debugger.factor
@@ -41,8 +41,8 @@ USE: unparser
 USE: vectors
 USE: words
 
-: expired-port-error ( obj -- )
-    "Expired port: " write . ;
+: expired-error ( obj -- )
+    "Object did not survive image save/load: " write . ;
 
 : io-task-twice-error ( obj -- )
     "Attempting to perform two simultaneous I/O operations on "
@@ -79,9 +79,6 @@ USE: words
 : signal-error ( obj -- )
     "Operating system signal " write . ;
 
-: profiling-disabled-error ( obj -- )
-    drop "Recompile with #define FACTOR_PROFILER." print ;
-
 : negative-array-size-error ( obj -- )
     "Cannot allocate array with negative size " write . ;
 
@@ -99,7 +96,7 @@ USE: words
 
 : kernel-error. ( obj n -- str )
     {
-        expired-port-error
+        expired-error
         io-task-twice-error
         no-io-tasks-error
         incompatible-port-error
@@ -109,7 +106,6 @@ USE: words
         array-range-error
         float-format-error
         signal-error
-        profiling-disabled-error
         negative-array-size-error
         bad-primitive-error
         c-string-error

diff --git a/library/platform/native/math.factor b/library/platform/native/math.factor
index 8053ce3aaf80922d8f6ce7e548174f644f3b1cf7..ddb4a0fa23dafb6bca62da1d943cf057c2ce5797 100644 (file)
--- a/library/platform/native/math.factor
+++ b/library/platform/native/math.factor
@@ -33,11 +33,6 @@ USE: stack
 USE: vectors
 USE: words
 
-: abs ( z -- abs )
-    #! This definition is replaced when the remainder of the
-    #! math library is read in at stage2.
-    dup 0 < [ neg ] when ;
-
 : (gcd) ( x y -- z ) dup 0 = [ drop ] [ tuck mod (gcd) ] ifte ;
 : gcd ( x y -- z ) abs swap abs 2dup < [ swap ] when (gcd) ;
 

diff --git a/library/platform/native/parse-syntax.factor b/library/platform/native/parse-syntax.factor
index 56391db54f117ce82f6c47a759ba6a9e4b1a880d..b16659cba8e2e7f58c93ee5d95667cfa86734cf0 100644 (file)
--- a/library/platform/native/parse-syntax.factor
+++ b/library/platform/native/parse-syntax.factor
@@ -66,7 +66,7 @@ USE: unparser
 : POSTPONE: ( -- ) scan-word parsed ; parsing
 
 ! Colon defs
-: CREATE
+: CREATE ( -- word )
     scan "in" get create dup set-word
     f "documentation" pick set-word-property ;
 

diff --git a/library/platform/native/primitives.factor b/library/platform/native/primitives.factor
index 590ec98703c4bbc80fa3756651966a3398c82cc2..7ca4ea564d69589cee5faf499c32781bce4000eb 100644 (file)
--- a/library/platform/native/primitives.factor
+++ b/library/platform/native/primitives.factor
@@ -224,6 +224,7 @@ USE: words
     [ dlsym-self             | " name -- ptr " ]
     [ dlclose                | " dll -- " ]
     [ <alien>                | " ptr len -- alien " ]
+    [ <local-alien>          | " len -- alien " ]
     [ alien-cell             | " alien off -- n " ]
     [ set-alien-cell         | " n alien off -- " ]
     [ alien-4                | " alien off -- n " ]

diff --git a/library/test/math/complex.factor b/library/test/math/complex.factor
index 0565bff62d73a5bd73382f3ed36c4403eade7684..f2d3ac82d19209df7e6310c34facb846016aa5df 100644 (file)
--- a/library/test/math/complex.factor
+++ b/library/test/math/complex.factor
@@ -43,3 +43,6 @@ USE: test
 [ t ] [ #{ 12 13 } #{ 13 14 } / #{ 13 14 } * #{ 12 13 } ] [ = ] test-word
 
 [ #{ -3 4 } ] [ #{ 3 -4 } ] [ neg ] test-word
+
+[ 5 ] [ #{ 3 4 } abs ] unit-test
+[ 5 ] [ -5.0 abs ] unit-test

diff --git a/native/error.h b/native/error.h
index a66f63f89ef5599adc90b8e67458acc6429aa44c..95113e9d4e3d05f04ded3c61ba415b122741109a 100644 (file)
--- a/native/error.h
+++ b/native/error.h
@@ -1,4 +1,4 @@
-#define ERROR_PORT_EXPIRED (0<<3)
+#define ERROR_EXPIRED (0<<3)
 #define ERROR_IO_TASK_TWICE (1<<3)
 #define ERROR_IO_TASK_NONE (2<<3)
 #define ERROR_INCOMPATIBLE_PORT (3<<3)
@@ -8,12 +8,11 @@
 #define ERROR_RANGE (7<<3)
 #define ERROR_FLOAT_FORMAT (8<<3)
 #define ERROR_SIGNAL (9<<3)
-#define ERROR_PROFILING_DISABLED (10<<3)
-#define ERROR_NEGATIVE_ARRAY_SIZE (11<<3)
-#define ERROR_BAD_PRIMITIVE (12<<3)
-#define ERROR_C_STRING (13<<3)
-#define ERROR_FFI_DISABLED (14<<3)
-#define ERROR_FFI (15<<3)
+#define ERROR_NEGATIVE_ARRAY_SIZE (10<<3)
+#define ERROR_BAD_PRIMITIVE (11<<3)
+#define ERROR_C_STRING (12<<3)
+#define ERROR_FFI_DISABLED (13<<3)
+#define ERROR_FFI (14<<3)
 
 void fatal_error(char* msg, CELL tagged);
 void critical_error(char* msg, CELL tagged);

diff --git a/native/ffi.c b/native/ffi.c
index e2d737ff95669205bf9120d91ee7815ed18deaae..ad43ec17b92858c4c996c7282c808ccfe9185805 100644 (file)
--- a/native/ffi.c
+++ b/native/ffi.c
@@ -1,5 +1,14 @@
 #include "factor.h"
 
+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 primitive_dlopen(void)
 {
 #ifdef FFI
@@ -75,13 +84,30 @@ void primitive_alien(void)
        ALIEN* alien = allot_object(ALIEN_TYPE,sizeof(ALIEN));
        alien->ptr = ptr;
        alien->length = length;
+       alien->local = false;
        dpush(tag_object(alien));
 #else
        general_error(ERROR_FFI_DISABLED,F);
 #endif
 }
 
-ALIEN* unbox_alien(void)
+void primitive_local_alien(void)
+{
+#ifdef FFI
+       CELL length = unbox_integer();
+       ALIEN* alien = allot_object(ALIEN_TYPE,sizeof(ALIEN));
+       STRING* local = string(length / CHARS,'\0');
+       alien->ptr = (CELL)local + sizeof(STRING);
+       alien->length = length;
+       alien->local = true;
+       dpush(tag_object(alien));
+#else
+       general_error(ERROR_FFI_DISABLED,F);
+#endif
+}
+
+#ifdef FFI
+CELL unbox_alien(void)
 {
        return untag_alien(dpop())->ptr;
 }
@@ -90,14 +116,20 @@ INLINE CELL alien_pointer(void)
 {
        FIXNUM offset = unbox_integer();
        ALIEN* alien = untag_alien(dpop());
+       CELL ptr = alien->ptr;
+
+       if(ptr == NULL)
+               general_error(ERROR_EXPIRED,tag_object(alien));
+
        if(offset < 0 || offset >= alien->length)
        {
                range_error(tag_object(alien),offset,alien->length);
                return 0; /* can't happen */
        }
        else
-               return alien->ptr + offset;
+               return ptr + offset;
 }
+#endif
 
 void primitive_alien_cell(void)
 {
@@ -180,3 +212,23 @@ void primitive_set_alien_1(void)
        general_error(ERROR_FFI_DISABLED,F);
 #endif
 }
+
+void fixup_dll(DLL* dll)
+{
+       dll->dll = NULL;
+}
+
+void fixup_alien(ALIEN* alien)
+{
+       alien->ptr = NULL;
+}
+
+void collect_alien(ALIEN* alien)
+{
+       if(alien->local && alien->ptr != NULL)
+       {
+               STRING* ptr = alien->ptr - sizeof(STRING);
+               ptr = copy_untagged_object(ptr,SSIZE(ptr));
+               alien->ptr = (CELL)ptr + sizeof(STRING);
+       }
+}

diff --git a/native/ffi.h b/native/ffi.h
index f5cf6c2d540f9ec8cb263ae58c2a76f5c7608469..bfda3ad72321af78b0d97de8b1c4aac5ec716dbe 100644 (file)
--- a/native/ffi.h
+++ b/native/ffi.h
@@ -3,16 +3,14 @@ typedef struct {
        void* dll;
 } DLL;
 
-INLINE DLL* untag_dll(CELL tagged)
-{
-       type_check(DLL_TYPE,tagged);
-       return (DLL*)UNTAG(tagged);
-}
+DLL* untag_dll(CELL tagged);
 
 typedef struct {
        CELL header;
        CELL ptr;
        CELL length;
+       /* local aliens are heap-allocated as strings and must be collected. */
+       bool local;
 } ALIEN;
 
 INLINE ALIEN* untag_alien(CELL tagged)
@@ -26,7 +24,8 @@ void primitive_dlsym(void);
 void primitive_dlsym_self(void);
 void primitive_dlclose(void);
 void primitive_alien(void);
-ALIEN* unbox_alien(void);
+void primitive_local_alien(void);
+CELL unbox_alien(void);
 void primitive_alien_cell(void);
 void primitive_set_alien_cell(void);
 void primitive_alien_4(void);
@@ -35,3 +34,6 @@ void primitive_alien_2(void);
 void primitive_set_alien_2(void);
 void primitive_alien_1(void);
 void primitive_set_alien_1(void);
+void fixup_dll(DLL* dll);
+void fixup_alien(ALIEN* alien);
+void collect_alien(ALIEN* alien);

diff --git a/native/memory.c b/native/memory.c
index 43cb88652e56e0945a02aa5c5201f4f210dbe3e2..d44b2b33f669e8df727c7259ca38dcae6b462dbf 100644 (file)
--- a/native/memory.c
+++ b/native/memory.c
@@ -38,7 +38,6 @@ void init_arena(CELL size)
        gc_in_progress = false;
 }
 
-#ifdef FACTOR_PROFILER
 void allot_profile_step(CELL a)
 {
        CELL depth = (cs - cs_bot) / CELLS;
@@ -57,7 +56,6 @@ void allot_profile_step(CELL a)
 
        executing->allot_count += a;
 }
-#endif
 
 void check_memory(void)
 {
@@ -99,9 +97,6 @@ void primitive_room(void)
 
 void primitive_allot_profiling(void)
 {
-#ifndef FACTOR_PROFILER
-       general_error(ERROR_PROFILING_DISABLED,F);
-#else
        CELL d = dpop();
        if(d == F)
                allot_profiling = false;
@@ -110,7 +105,6 @@ void primitive_allot_profiling(void)
                allot_profiling = true;
                profile_depth = to_fixnum(d);
        }
-#endif
 }
 
 void primitive_address(void)

diff --git a/native/memory.h b/native/memory.h
index ebdad4e939e5e5b4d4ae4dc7a2af174a04e486dd..27af3e8059d7a18a8667beea7ddcecb14eed5f67 100644 (file)
--- a/native/memory.h
+++ b/native/memory.h
@@ -27,10 +27,8 @@ INLINE void* allot(CELL a)
 {
        CELL h = active.here;
        active.here += align8(a);
-#ifdef FACTOR_PROFILER
        if(allot_profiling)
                allot_profile_step(align8(a));
-#endif
        check_memory();
        return (void*)h;
 }

diff --git a/native/port.c b/native/port.c
index 38e463ea8ff810125e8cef9a52340ea06f7a79f4..5d4eb18916f29a16f02ac5c53398dfef050dd3c6 100644 (file)
--- a/native/port.c
+++ b/native/port.c
@@ -7,7 +7,7 @@ PORT* untag_port(CELL tagged)
        p = (PORT*)UNTAG(tagged);
        /* after image load & save, ports are no longer valid */
        if(p->fd == -1)
-               general_error(ERROR_PORT_EXPIRED,tagged);
+               general_error(ERROR_EXPIRED,tagged);
        return p;
 }
 

diff --git a/native/primitives.c b/native/primitives.c
index e6d542a280f82edfe878a3f303712136152566f8..3489be5e714f4beb9c495c9f999b3ad1b7b59f9b 100644 (file)
--- a/native/primitives.c
+++ b/native/primitives.c
@@ -183,6 +183,7 @@ XT primitives[] = {
        primitive_dlsym_self,
        primitive_dlclose,
        primitive_alien,
+       primitive_local_alien,
        primitive_alien_cell,
        primitive_set_alien_cell,
        primitive_alien_4,

diff --git a/native/primitives.h b/native/primitives.h
index c41f8b479683b3598b4042b856963ede5a3bc84d..1aa49ac28140a009df69e8ae1f2e8e2ec6c3c589 100644 (file)
--- a/native/primitives.h
+++ b/native/primitives.h
@@ -1,4 +1,4 @@
 extern XT primitives[];
-#define PRIMITIVE_COUNT 191
+#define PRIMITIVE_COUNT 192
 
 CELL primitive_to_xt(CELL primitive);

diff --git a/native/relocate.c b/native/relocate.c
index ff5a8ede792a6ee4b34733d630d216b77f707db2..9adcd5f89079a127da1e674c8c382250805928a9 100644 (file)
--- a/native/relocate.c
+++ b/native/relocate.c
@@ -28,6 +28,12 @@ void relocate_object()
        case PORT_TYPE:
                fixup_port((PORT*)relocating);
                break;
+       case DLL_TYPE:
+               fixup_dll((DLL*)relocating);
+               break;
+       case ALIEN_TYPE:
+               fixup_alien((ALIEN*)relocating);
+               break;
        }
 
 }

diff --git a/native/run.c b/native/run.c
index f78d3f9f1978b490520ed99031e86e562c854afb..92f2a3979d2ae363cf2608d470fe20a02b863d01 100644 (file)
--- a/native/run.c
+++ b/native/run.c
@@ -61,9 +61,7 @@ void run(void)
                if(callframe == F)
                {
                        callframe = cpop();
-#ifdef FACTOR_PROFILER
                        cpop();
-#endif
                        continue;
                }
 
@@ -131,9 +129,6 @@ void primitive_setenv(void)
 
 void primitive_call_profiling(void)
 {
-#ifndef FACTOR_PROFILER
-       general_error(ERROR_PROFILING_DISABLED,F);
-#else
        CELL d = dpop();
        if(d == F)
        {
@@ -154,5 +149,4 @@ void primitive_call_profiling(void)
 
        if(setitimer(ITIMER_PROF,&prof_timer,NULL) < 0)
                io_error(__FUNCTION__);
-#endif
 }

diff --git a/native/run.h b/native/run.h
index 766eb2943d62a83eb1830a89f382f69994aae4b2..f2d883fe099e63c75453f9405a4fc24309f246d7 100644 (file)
--- a/native/run.h
+++ b/native/run.h
@@ -89,9 +89,7 @@ INLINE void call(CELL quot)
        /* tail call optimization */
        if(callframe != F)
        {
-#ifdef FACTOR_PROFILER
                cpush(tag_word(executing));
-#endif
                cpush(callframe);
        }
        callframe = quot;