memory management change, allocating primitives call gc directly

diff --git a/Makefile b/Makefile
index b5a00b37bdf1457a17e283ac298fca70feac0311..1d5baee765284434081e0592b0b2e4a0f903575e 100644 (file)
--- a/Makefile
+++ b/Makefile
@@ -1,5 +1,5 @@
 CC = gcc
-DEFAULT_CFLAGS = -Os -Wall -export-dynamic -fomit-frame-pointer
+DEFAULT_CFLAGS = -Os -Wall -export-dynamic -fomit-frame-pointer $(SITE_CFLAGS)
 DEFAULT_LIBS = -lm
 
 STRIP = strip
@@ -22,6 +22,7 @@ default:
        @echo "Run 'make' with one of the following parameters:"
        @echo ""
        @echo "bsd"
+       @echo "bsd-nopthread - on FreeBSD 4, if you want to use profiling"
        @echo "linux"
        @echo "solaris"
        @echo ""
@@ -36,6 +37,11 @@ bsd:
                CFLAGS="$(DEFAULT_CFLAGS) -DFFI -pthread" \
                LIBS="$(DEFAULT_LIBS)"
 
+bsd-nopthread:
+       $(MAKE) f \
+               CFLAGS="$(DEFAULT_CFLAGS) -DFFI" \
+               LIBS="$(DEFAULT_LIBS)"
+
 linux:
        $(MAKE) f \
                CFLAGS="$(DEFAULT_CFLAGS) -DFFI" \

diff --git a/library/cross-compiler.factor b/library/cross-compiler.factor
index dcf2e14d2be715da8ad49d1a371b4275a321d14f..1bd90ab0491a44b36e3c9c72b8206971ca1a1663 100644 (file)
--- a/library/cross-compiler.factor
+++ b/library/cross-compiler.factor
@@ -74,7 +74,6 @@ DEFER: os-env
 DEFER: type
 DEFER: size
 DEFER: address
-DEFER: dump
 DEFER: heap-stats
 
 IN: strings
@@ -357,7 +356,6 @@ IN: image
         (random-int)
         type
         size
-        dump
         cwd
         cd
         compiled-offset

diff --git a/library/platform/native/primitives.factor b/library/platform/native/primitives.factor
index a554da62554fda30b5152be97da4aa4d7b01409d..19f299b485d7af002e4c7bd224cf560a0409fd2e 100644 (file)
--- a/library/platform/native/primitives.factor
+++ b/library/platform/native/primitives.factor
@@ -209,7 +209,6 @@ USE: words
     [ allot-profiling        | " depth -- " ]
     [ allot-count            | " word -- n " ]
     [ set-allot-count        | " n word -- n " ]
-    [ dump                   | " obj -- " ]
     [ cwd                    | " -- dir " ]
     [ cd                     | " dir -- " ]
     [ compiled-offset        | " -- ptr " ]

diff --git a/library/platform/native/profiler.factor b/library/platform/native/profiler.factor
index 18d6300d8d87c58700f2237b1588957331440498..33c6a597658db28f6a8521f725d5ca1fa374c9cc 100644 (file)
--- a/library/platform/native/profiler.factor
+++ b/library/platform/native/profiler.factor
@@ -36,8 +36,9 @@ USE: stack
 USE: words
 USE: vectors
 
-! The variable "profile-top-only" toggles between
+! The variable "only-top" toggles between
 ! culminative counts, and top of call stack counts.
+SYMBOL: only-top
 
 : reset-counts ( -- )
     [ 0 over set-call-count 0 swap set-allot-count ] each-word ;
@@ -47,11 +48,7 @@ USE: vectors
 
 : call-count, ( word -- )
     #! Add to constructing list if call count is non-zero.
-    dup call-count dup 0 = [
-        2drop
-    ] [
-        cons ,
-    ] ifte ;
+    dup call-count dup 0 = [ 2drop ] [ cons , ] ifte ;
 
 : counts. ( alist -- )
     sort-counts [ . ] each ;
@@ -61,27 +58,21 @@ USE: vectors
     [, [ call-count, ] each-word ,] counts. ;
 
 : profile-depth ( -- n )
-    "profile-top-only" get [
-        -1
-    ] [
-        callstack vector-length
-    ] ifte ;
+    only-top get [ -1 ] [ callstack vector-length ] ifte ;
 
-: call-profile ( quot -- )
-    #! Execute a quotation with the CPU profiler enabled.
+: (call-profile) ( quot -- )
     reset-counts
     profile-depth call-profiling
     call
-    f call-profiling
-    call-counts. ;
+    f call-profiling ;
+
+: call-profile ( quot -- )
+    #! Execute a quotation with the CPU profiler enabled.
+    (call-profile) call-counts. ;
 
 : allot-count, ( word -- )
     #! Add to constructing list if allot count is non-zero.
-    dup allot-count dup 0 = [
-        2drop
-    ] [
-        cons ,
-    ] ifte ;
+    dup allot-count dup 0 = [ 2drop ] [ cons , ] ifte ;
 
 : allot-counts. ( -- alist )
     #! Print word/allot count pairs.

diff --git a/library/test/math/irrational.factor b/library/test/math/irrational.factor
index 2af5a62b50b552d0f3f553c6fecac21c99ed78cb..41963093ecec4182bf0da81be261b57220a45335 100644 (file)
--- a/library/test/math/irrational.factor
+++ b/library/test/math/irrational.factor
@@ -2,24 +2,29 @@ IN: scratchpad
 USE: kernel
 USE: math
 USE: test
+USE: real-math
 
-[ 4.0 ] [ 16 ] [ sqrt ] test-word
-[ #{ 0 4.0 } ] [ -16 ] [ sqrt ] test-word
+! Lets get the argument order correct, eh?
+[ 0.0 ] [ 0 1 fatan2 ] unit-test
+[ 0.25 ] [ 2 -2 fpow ] unit-test
 
-[ 4.0 ] [ 2 2 ] [ ^ ] test-word
-[ 0.25 ] [ 2 -2 ] [ ^ ] test-word
-[ t ] [ 2 0.5 ^ 2 ^ ] [ 2 2.00001 between? ] test-word
-[ t ] [ e pi i * ^ real ] [ -1.0 = ] test-word
-[ t ] [ e pi i * ^ imaginary ] [ -0.00001 0.00001 between? ] test-word
+[ 4.0 ] [ 16 sqrt ] unit-test
+[ #{ 0 4.0 } ] [ -16 sqrt ] unit-test
 
-[ 1.0 ] [ 0 ] [ cosh ] test-word
-[ 0.0 ] [ 1 ] [ acosh ] test-word
+[ 4.0 ] [ 2 2 ^ ] unit-test
+[ 0.25 ] [ 2 -2 ^ ] unit-test
+[ t ] [ 2 0.5 ^ 2 ^ 2 2.00001 between? ] unit-test
+[ t ] [ e pi i * ^ real -1.0 = ] unit-test
+[ t ] [ e pi i * ^ imaginary -0.00001 0.00001 between? ] unit-test
 
-[ 1.0 ] [ 0 ] [ cos ] test-word
-[ 0.0 ] [ 1 ] [ acos ] test-word
-
-[ 0.0 ] [ 0 ] [ sinh ] test-word
-[ 0.0 ] [ 0 ] [ asinh ] test-word
-
-[ 0.0 ] [ 0 ] [ sin ] test-word
-[ 0.0 ] [ 0 ] [ asin ] test-word
+[ 1.0 ] [ 0 cosh ] unit-test
+[ 0.0 ] [ 1 acosh ] unit-test
+            
+[ 1.0 ] [ 0 cos ] unit-test
+[ 0.0 ] [ 1 acos ] unit-test
+            
+[ 0.0 ] [ 0 sinh ] unit-test
+[ 0.0 ] [ 0 asinh ] unit-test
+            
+[ 0.0 ] [ 0 sin ] unit-test
+[ 0.0 ] [ 0 asin ] unit-test

diff --git a/native/bignum.c b/native/bignum.c
index b07aba451630c082af007d28deda61a8991b9669..dde761395d0425f6b96128683c6417e20d986b4d 100644 (file)
--- a/native/bignum.c
+++ b/native/bignum.c
@@ -55,6 +55,7 @@ ARRAY* to_bignum(CELL tagged)
 
 void primitive_to_bignum(void)
 {
+       maybe_garbage_collection();
        drepl(tag_object(to_bignum(dpeek())));
 }
 
@@ -65,38 +66,39 @@ void primitive_bignum_eq(void)
        dpush(tag_boolean(s48_bignum_equal_p(x,y)));
 }
 
+#define GC_AND_POP_BIGNUMS(x,y) \
+       ARRAY *x, *y; \
+       maybe_garbage_collection(); \
+       y = to_bignum(dpop()); \
+       x = to_bignum(dpop());
+
 void primitive_bignum_add(void)
 {
-       ARRAY* y = to_bignum(dpop());
-       ARRAY* x = to_bignum(dpop());
+       GC_AND_POP_BIGNUMS(x,y);
        dpush(tag_object(s48_bignum_add(x,y)));
 }
 
 void primitive_bignum_subtract(void)
 {
-       ARRAY* y = to_bignum(dpop());
-       ARRAY* x = to_bignum(dpop());
+       GC_AND_POP_BIGNUMS(x,y);
        dpush(tag_object(s48_bignum_subtract(x,y)));
 }
 
 void primitive_bignum_multiply(void)
 {
-       ARRAY* y = to_bignum(dpop());
-       ARRAY* x = to_bignum(dpop());
+       GC_AND_POP_BIGNUMS(x,y);
        dpush(tag_object(s48_bignum_multiply(x,y)));
 }
 
 void primitive_bignum_divint(void)
 {
-       ARRAY* y = to_bignum(dpop());
-       ARRAY* x = to_bignum(dpop());
+       GC_AND_POP_BIGNUMS(x,y);
        dpush(tag_object(s48_bignum_quotient(x,y)));
 }
 
 void primitive_bignum_divfloat(void)
 {
-       ARRAY* y = to_bignum(dpop());
-       ARRAY* x = to_bignum(dpop());
+       GC_AND_POP_BIGNUMS(x,y);
        dpush(tag_object(make_float(
                s48_bignum_to_double(x) /
                s48_bignum_to_double(y))));
@@ -104,9 +106,8 @@ void primitive_bignum_divfloat(void)
 
 void primitive_bignum_divmod(void)
 {
-       ARRAY* y = to_bignum(dpop());
-       ARRAY* x = to_bignum(dpop());
        ARRAY *q, *r;
+       GC_AND_POP_BIGNUMS(x,y);
        s48_bignum_divide(x,y,&q,&r);
        dpush(tag_object(q));
        dpush(tag_object(r));
@@ -114,36 +115,35 @@ void primitive_bignum_divmod(void)
 
 void primitive_bignum_mod(void)
 {
-       ARRAY* y = to_bignum(dpop());
-       ARRAY* x = to_bignum(dpop());
+       GC_AND_POP_BIGNUMS(x,y);
        dpush(tag_object(s48_bignum_remainder(x,y)));
 }
 
 void primitive_bignum_and(void)
 {
-       ARRAY* y = to_bignum(dpop());
-       ARRAY* x = to_bignum(dpop());
+       GC_AND_POP_BIGNUMS(x,y);
        dpush(tag_object(s48_bignum_bitwise_and(x,y)));
 }
 
 void primitive_bignum_or(void)
 {
-       ARRAY* y = to_bignum(dpop());
-       ARRAY* x = to_bignum(dpop());
+       GC_AND_POP_BIGNUMS(x,y);
        dpush(tag_object(s48_bignum_bitwise_ior(x,y)));
 }
 
 void primitive_bignum_xor(void)
 {
-       ARRAY* y = to_bignum(dpop());
-       ARRAY* x = to_bignum(dpop());
+       GC_AND_POP_BIGNUMS(x,y);
        dpush(tag_object(s48_bignum_bitwise_xor(x,y)));
 }
 
 void primitive_bignum_shift(void)
 {
-       FIXNUM y = to_fixnum(dpop());
-       ARRAY* x = to_bignum(dpop());
+       FIXNUM y;
+        ARRAY* x;
+       maybe_garbage_collection();
+       y = to_fixnum(dpop());
+       x = to_bignum(dpop());
        dpush(tag_object(s48_bignum_arithmetic_shift(x,y)));
 }
 
@@ -207,6 +207,7 @@ void primitive_bignum_greatereq(void)
 
 void primitive_bignum_not(void)
 {
+       maybe_garbage_collection();
        drepl(tag_object(s48_bignum_bitwise_not(
                untag_bignum(dpeek()))));
 }

diff --git a/native/complex.c b/native/complex.c
index c62f84ca5c36f0eebedc817b7b4392d05f350ed4..34ccbf7d31ca8159f77a8c9d63bce9747331c89f 100644 (file)
--- a/native/complex.c
+++ b/native/complex.c
@@ -62,8 +62,12 @@ void primitive_to_rect(void)
 
 void primitive_from_rect(void)
 {
-       CELL imaginary = dpop();
-       CELL real = dpop();
+       CELL imaginary, real;
+
+       maybe_garbage_collection();
+
+       imaginary = dpop();
+       real = dpop();
 
        if(!realp(imaginary))
                type_error(REAL_TYPE,imaginary);

diff --git a/native/cons.c b/native/cons.c
index 1f97aa396361025ab8c89024ecf850f803160214..01c45df7db039f56446add3169b0ddaefa9c11f5 100644 (file)
--- a/native/cons.c
+++ b/native/cons.c
@@ -10,8 +10,10 @@ CELL cons(CELL car, CELL cdr)
 
 void primitive_cons(void)
 {
-       CELL cdr = dpop();
-       CELL car = dpop();
+       CELL car, cdr;
+       maybe_garbage_collection();
+       cdr = dpop();
+       car = dpop();
        dpush(cons(car,cdr));
 }
 

diff --git a/native/error.c b/native/error.c
index 942e763ebca352bca86f884aa5e5ee9f8bcb7aa9..263b94475853aaa9eb24552343276aee1a1a7ffb 100644 (file)
--- a/native/error.c
+++ b/native/error.c
@@ -69,8 +69,8 @@ void type_error(CELL type, CELL tagged)
        general_error(ERROR_TYPE,c);
 }
 
-void range_error(CELL tagged, CELL index, CELL max)
+void range_error(CELL tagged, FIXNUM index, CELL max)
 {
-       CELL c = cons(tagged,cons(tag_fixnum(index),cons(tag_fixnum(max),F)));
+       CELL c = cons(tagged,cons(tag_integer(index),cons(tag_cell(max),F)));
        general_error(ERROR_RANGE,c);
 }

diff --git a/native/error.h b/native/error.h
index 24f1e56d1a8ee074c434f9e4ad8af40ec3225498..c6d0c3057b04b9c76b4f0c8d6dbb737560c222b0 100644 (file)
--- a/native/error.h
+++ b/native/error.h
@@ -21,4 +21,4 @@ void throw_error(CELL object);
 void general_error(CELL error, CELL tagged);
 void type_error(CELL type, CELL tagged);
 void primitive_throw(void);
-void range_error(CELL tagged, CELL index, CELL max);
+void range_error(CELL tagged, FIXNUM index, CELL max);

diff --git a/native/factor.h b/native/factor.h
index aa8525b5f9a25a0068c23791ffd189cea918b1b2..6957cb43ef213a1fd340c2388af31d9f9eee5dc0 100644 (file)
--- a/native/factor.h
+++ b/native/factor.h
@@ -33,6 +33,11 @@
 typedef unsigned long int CELL;
 #define CELLS ((signed)sizeof(CELL))
 
+#define FIXNUM_MAX (LONG_MAX >> TAG_BITS)
+#define FIXNUM_MIN (LONG_MIN >> TAG_BITS)
+
+#define FIXNUM long int /* unboxed */
+
 #define WORD_SIZE (CELLS*8)
 #define HALF_WORD_SIZE (CELLS*4)
 #define HALF_WORD_MASK (((unsigned long)1<<HALF_WORD_SIZE)-1)
@@ -46,7 +51,7 @@ typedef unsigned char BYTE;
 
 /* Memory heap size */
 #define DEFAULT_ARENA (64 * 1024 * 1024)
-#define COMPILE_ZONE_SIZE (5 * 1024 * 1024)
+#define COMPILE_ZONE_SIZE (4 * 1024 * 1024)
 
 #define STACK_SIZE 16384
 

diff --git a/native/ffi.c b/native/ffi.c
index bc2138323e776fa67ecee9d9ea9dac6074f1aa23..93fa0e3f974ccd27734161a71d7d4ff2f5776c02 100644 (file)
--- a/native/ffi.c
+++ b/native/ffi.c
@@ -12,9 +12,14 @@ DLL* untag_dll(CELL tagged)
 void primitive_dlopen(void)
 {
 #ifdef FFI
-       char* path = unbox_c_string();
-       void* dllptr = dlopen(path,RTLD_LAZY);
+       char* path;
+       void* dllptr;
        DLL* dll;
+       
+       maybe_garbage_collection();
+       
+       path = unbox_c_string();
+       dllptr = dlopen(path,RTLD_LAZY);
 
        if(dllptr == NULL)
        {
@@ -81,7 +86,9 @@ void primitive_alien(void)
 #ifdef FFI
        CELL length = unbox_integer();
        CELL ptr = unbox_integer();
-       ALIEN* alien = allot_object(ALIEN_TYPE,sizeof(ALIEN));
+       ALIEN* alien;
+       maybe_garbage_collection();
+       alien = allot_object(ALIEN_TYPE,sizeof(ALIEN));
        alien->ptr = ptr;
        alien->length = length;
        alien->local = false;
@@ -95,8 +102,11 @@ 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* alien;
+       STRING* local;
+       maybe_garbage_collection();
+       alien = allot_object(ALIEN_TYPE,sizeof(ALIEN));
+       local = string(length / CHARS,'\0');
        alien->ptr = (CELL)local + sizeof(STRING);
        alien->length = length;
        alien->local = true;

diff --git a/native/file.c b/native/file.c
index 6305393bb30f116c2e842613c6b9e9128afb4122..4dfbf086369050aa523150c7c0994e145f352ffd 100644 (file)
--- a/native/file.c
+++ b/native/file.c
@@ -4,9 +4,13 @@ void primitive_open_file(void)
 {
        bool write = untag_boolean(dpop());
        bool read = untag_boolean(dpop());
-       char* path = unbox_c_string();
-       int mode;
-       int fd;
+
+       char* path;
+       int mode, fd;
+
+       maybe_garbage_collection();
+
+       path = unbox_c_string();
 
        if(read && write)
                mode = O_RDWR | O_CREAT;
@@ -28,7 +32,11 @@ void primitive_open_file(void)
 void primitive_stat(void)
 {
        struct stat sb;
-       STRING* path = untag_string(dpop());
+       STRING* path;
+
+       maybe_garbage_collection();
+
+       path = untag_string(dpop());
        if(stat(to_c_string(path),&sb) < 0)
                dpush(F);
        else
@@ -50,14 +58,19 @@ void primitive_stat(void)
 
 void primitive_read_dir(void)
 {
-       STRING* path = untag_string(dpop());
-       DIR* dir = opendir(to_c_string(path));
+       STRING* path;
+       DIR* dir;
        CELL result = F;
+
+       maybe_garbage_collection();
+
+       path = untag_string(dpop());
+       dir = opendir(to_c_string(path));
        if(dir != NULL)
        {
                struct dirent* file;
 
-               while(file = readdir(dir))
+               while((file = readdir(dir)) != NULL)
                {
                        CELL name = tag_object(from_c_string(
                                file->d_name));
@@ -73,6 +86,7 @@ void primitive_read_dir(void)
 void primitive_cwd(void)
 {
        char wd[MAXPATHLEN];
+       maybe_garbage_collection();
        if(getcwd(wd,MAXPATHLEN) < 0)
                io_error(__FUNCTION__);
        box_c_string(wd);
@@ -80,5 +94,6 @@ void primitive_cwd(void)
 
 void primitive_cd(void)
 {
+       maybe_garbage_collection();
        chdir(unbox_c_string());
 }

diff --git a/native/fixnum.h b/native/fixnum.h
index a1bda42b04e3c0bb7a0e4ba3480e64c32371b7c6..933f3936b16e1c1296f42a8939aea88ed498b030 100644 (file)
--- a/native/fixnum.h
+++ b/native/fixnum.h
@@ -1,8 +1,3 @@
-#define FIXNUM_MAX (LONG_MAX >> TAG_BITS)
-#define FIXNUM_MIN (LONG_MIN >> TAG_BITS)
-
-#define FIXNUM long int /* unboxed */
-
 INLINE FIXNUM untag_fixnum_fast(CELL tagged)
 {
        return ((FIXNUM)tagged) >> TAG_BITS;

diff --git a/native/float.c b/native/float.c
index 940533dceb1128c9d06c5095d9344e55cdee848e..cc302c003ebb9c74600d52bd80b6748cde1a4ddd 100644 (file)
--- a/native/float.c
+++ b/native/float.c
@@ -27,15 +27,22 @@ double to_float(CELL tagged)
 
 void primitive_to_float(void)
 {
+       maybe_garbage_collection();
        drepl(tag_object(make_float(to_float(dpeek()))));
 }
 
 void primitive_str_to_float(void)
 {
-       STRING* str = untag_string(dpeek());
-       char* c_str = to_c_string(str);
-       char* end = c_str;
-       double f = strtod(c_str,&end);
+       STRING* str;
+       char *c_str, *end;
+       double f;
+
+       maybe_garbage_collection();
+
+       str = untag_string(dpeek());
+       c_str = to_c_string(str);
+       end = c_str;
+       f = strtod(c_str,&end);
        if(end != c_str + str->capacity)
                general_error(ERROR_FLOAT_FORMAT,tag_object(str));
        drepl(tag_object(make_float(f)));
@@ -44,6 +51,9 @@ void primitive_str_to_float(void)
 void primitive_float_to_str(void)
 {
        char tmp[33];
+
+       maybe_garbage_collection();
+
        snprintf(tmp,32,"%.16g",to_float(dpop()));
        tmp[32] = '\0';
        box_c_string(tmp);
@@ -51,43 +61,49 @@ void primitive_float_to_str(void)
 
 void primitive_float_to_bits(void)
 {
-       double f = untag_float(dpeek());
-       long long f_raw = *(long long*)&f;
+       double f;
+       long long f_raw;
+
+       maybe_garbage_collection();
+
+       f = untag_float(dpeek());
+       f_raw = *(long long*)&f;
        drepl(tag_object(s48_long_long_to_bignum(f_raw)));
 }
 
+#define GC_AND_POP_FLOATS(x,y) \
+       double x, y; \
+       maybe_garbage_collection(); \
+       y = to_float(dpop()); \
+       x = to_float(dpop());
+
 void primitive_float_eq(void)
 {
-       double y = to_float(dpop());
-       double x = to_float(dpop());
+       GC_AND_POP_FLOATS(x,y);
        dpush(tag_boolean(x == y));
 }
 
 void primitive_float_add(void)
 {
-       double y = to_float(dpop());
-       double x = to_float(dpop());
+       GC_AND_POP_FLOATS(x,y);
        dpush(tag_object(make_float(x + y)));
 }
 
 void primitive_float_subtract(void)
 {
-       double y = to_float(dpop());
-       double x = to_float(dpop());
+       GC_AND_POP_FLOATS(x,y);
        dpush(tag_object(make_float(x - y)));
 }
 
 void primitive_float_multiply(void)
 {
-       double y = to_float(dpop());
-       double x = to_float(dpop());
+       GC_AND_POP_FLOATS(x,y);
        dpush(tag_object(make_float(x * y)));
 }
 
 void primitive_float_divfloat(void)
 {
-       double y = to_float(dpop());
-       double x = to_float(dpop());
+       GC_AND_POP_FLOATS(x,y);
        dpush(tag_object(make_float(x / y)));
 }
 
@@ -121,64 +137,72 @@ void primitive_float_greatereq(void)
 
 void primitive_facos(void)
 {
+       maybe_garbage_collection();
        drepl(tag_object(make_float(acos(to_float(dpeek())))));
 }
 
 void primitive_fasin(void)
 {
+       maybe_garbage_collection();
        drepl(tag_object(make_float(asin(to_float(dpeek())))));
 }
 
 void primitive_fatan(void)
 {
+       maybe_garbage_collection();
        drepl(tag_object(make_float(atan(to_float(dpeek())))));
 }
 
 void primitive_fatan2(void)
 {
-       double x = to_float(dpop());
-       double y = to_float(dpop());
-       dpush(tag_object(make_float(atan2(y,x))));
+       GC_AND_POP_FLOATS(x,y);
+       dpush(tag_object(make_float(atan2(x,y))));
 }
 
 void primitive_fcos(void)
 {
+       maybe_garbage_collection();
        drepl(tag_object(make_float(cos(to_float(dpeek())))));
 }
 
 void primitive_fexp(void)
 {
+       maybe_garbage_collection();
        drepl(tag_object(make_float(exp(to_float(dpeek())))));
 }
 
 void primitive_fcosh(void)
 {
+       maybe_garbage_collection();
        drepl(tag_object(make_float(cosh(to_float(dpeek())))));
 }
 
 void primitive_flog(void)
 {
+       maybe_garbage_collection();
        drepl(tag_object(make_float(log(to_float(dpeek())))));
 }
 
 void primitive_fpow(void)
 {
-       double x = to_float(dpop());
-       double y = to_float(dpop());
-       dpush(tag_object(make_float(pow(y,x))));
+       GC_AND_POP_FLOATS(x,y);
+       dpush(tag_object(make_float(pow(x,y))));
 }
 
 void primitive_fsin(void)
 {
+       maybe_garbage_collection();
        drepl(tag_object(make_float(sin(to_float(dpeek())))));
 }
 
 void primitive_fsinh(void)
 {
+       maybe_garbage_collection();
        drepl(tag_object(make_float(sinh(to_float(dpeek())))));
 }
 
 void primitive_fsqrt(void)
 {
+       maybe_garbage_collection();
        drepl(tag_object(make_float(sqrt(to_float(dpeek())))));
 }

diff --git a/native/gc.c b/native/gc.c
index 0af8d727b2cda93922263900f8244a28fe0d1442..005c20b382b01abbf113bab87dde5727fcad57ec 100644 (file)
--- a/native/gc.c
+++ b/native/gc.c
@@ -132,6 +132,7 @@ void collect_roots(void)
 
 void primitive_gc(void)
 {
+       fprintf(stderr,"GC!\n");
        gc_in_progress = true;
 
        flip_zones();
@@ -149,3 +150,23 @@ void primitive_gc(void)
 
        gc_in_progress = false;
 }
+
+/* WARNING: only call this from a context where all local variables
+are also reachable via the GC roots. */
+void maybe_garbage_collection(void)
+{
+       if(active.here > active.alarm)
+       {
+               if(active.here > active.limit)
+               {
+                       fprintf(stderr,"Out of memory\n");
+                       fprintf(stderr,"active.base  = %ld\n",active.base);
+                       fprintf(stderr,"active.here  = %ld\n",active.here);
+                       fprintf(stderr,"active.limit = %ld\n",active.limit);
+                       fflush(stderr);
+                       exit(1);
+               }
+               else
+                       primitive_gc();
+       }
+}

diff --git a/native/gc.h b/native/gc.h
index f90f3fc147d2cf5d6048cd5c17363c7c96114133..c6e1b0f907230116999eca7b95f05c99c8760f42 100644 (file)
--- a/native/gc.h
+++ b/native/gc.h
@@ -7,3 +7,4 @@ void collect_object(void);
 void collect_next(void);
 void collect_roots(void);
 void primitive_gc(void);
+void maybe_garbage_collection(void);

diff --git a/native/memory.c b/native/memory.c
index 0fdfbf23001509314507853eb67e704cf650b11d..a134242d17a6aff6f1177edf1cacc2e61c325ff3 100644 (file)
--- a/native/memory.c
+++ b/native/memory.c
@@ -36,7 +36,6 @@ void init_arena(CELL size)
        init_zone(&prior,size);
        allot_profiling = false;
        gc_in_progress = false;
-       gc_protect = false;
 }
 
 void allot_profile_step(CELL a)
@@ -58,25 +57,6 @@ void allot_profile_step(CELL a)
        executing->allot_count += a;
 }
 
-void garbage_collection_later(void)
-{
-       if(gc_protect)
-               return;
-
-       if(active.here > active.limit)
-       {
-               fprintf(stderr,"Out of memory\n");
-               fprintf(stderr,"active.base  = %ld\n",active.base);
-               fprintf(stderr,"active.here  = %ld\n",active.here);
-               fprintf(stderr,"active.limit = %ld\n",active.limit);
-               fflush(stderr);
-               exit(1);
-       }
-
-       /* Execute the 'garbage-collection' word */
-       call(userenv[GC_ENV]);
-}
-
 void flip_zones()
 {
        ZONE z = active;

diff --git a/native/memory.h b/native/memory.h
index 440a5f84bf0e2f3bc6f6f42bd4ede42d95c774e8..2b0e89275ba28bb02c05a62507c7562bc7d67339 100644 (file)
--- a/native/memory.h
+++ b/native/memory.h
@@ -10,15 +10,11 @@ ZONE prior;
 
 bool allot_profiling;
 
-/* we can temporarily disable GC */
-bool gc_protect;
-
 void* alloc_guarded(CELL size);
 void init_zone(ZONE* zone, CELL size);
 void init_arena(CELL size);
 void flip_zones();
 
-void garbage_collection_later(void);
 void allot_profile_step(CELL a);
 
 INLINE CELL align8(CELL a)
@@ -32,8 +28,6 @@ INLINE void* allot(CELL a)
        active.here += align8(a);
        if(allot_profiling)
                allot_profile_step(align8(a));
-       if(active.here > active.alarm)
-               garbage_collection_later();
        return (void*)h;
 }
 

diff --git a/native/misc.c b/native/misc.c
index 8e6822f8a643e36d3a830a6b7feadc89a0a5268a..fc71056790329e1a9a13aa4d613cc4e5e7100a40 100644 (file)
--- a/native/misc.c
+++ b/native/misc.c
@@ -7,8 +7,12 @@ void primitive_exit(void)
 
 void primitive_os_env(void)
 {
-       char* name = unbox_c_string();
-       char* value = getenv(name);
+       char *name, *value;
+
+       maybe_garbage_collection();
+
+       name = unbox_c_string();
+       value = getenv(name);
        if(value == NULL)
                dpush(F);
        else
@@ -24,6 +28,7 @@ void primitive_millis(void)
 {
        struct timeval t;
        gettimeofday(&t,NULL);
+       maybe_garbage_collection();
        dpush(tag_object(s48_long_long_to_bignum(
                (long long)t.tv_sec * 1000 + t.tv_usec/1000)));
 }
@@ -41,15 +46,6 @@ void primitive_init_random(void)
 
 void primitive_random_int(void)
 {
+       maybe_garbage_collection();
        dpush(tag_object(s48_long_to_bignum(random())));
 }
-
-void primitive_dump(void)
-{
-       /* Take an object, and print its memory. Later, return a vector */
-       CELL obj = dpop();
-       CELL size = object_size(obj);
-       int i;
-       for(i = 0; i < size; i += CELLS)
-               fprintf(stderr,"%lx\n",get(UNTAG(obj) + i));
-}

diff --git a/native/misc.h b/native/misc.h
index 5c8e8e64ac65f6ade34fa629379b814a62095f4a..8118ef2959321d0f96033edb85842f7288b30e69 100644 (file)
--- a/native/misc.h
+++ b/native/misc.h
@@ -4,4 +4,3 @@ void primitive_eq(void);
 void primitive_millis(void);
 void primitive_init_random(void);
 void primitive_random_int(void);
-void primitive_dump(void);

diff --git a/native/primitives.c b/native/primitives.c
index 98a3147cedb0ba6ec8d2df2b589ff4457b1d7c2f..a3c05b0ca7c865497be43a5161aac8e78e40ae98 100644 (file)
--- a/native/primitives.c
+++ b/native/primitives.c
@@ -169,7 +169,6 @@ XT primitives[] = {
        primitive_random_int,
        primitive_type,
        primitive_size,
-       primitive_dump,
        primitive_cwd,
        primitive_cd,
        primitive_compiled_offset,

diff --git a/native/ratio.c b/native/ratio.c
index 005f7ca4f05c90f3828c475b450aacdbfa36d621..2df44e6f08c3004dcf95d9275d697b40378526cd 100644 (file)
--- a/native/ratio.c
+++ b/native/ratio.c
@@ -4,8 +4,12 @@
 library implementation, to avoid breaking invariants. */
 void primitive_from_fraction(void)
 {
-       CELL denominator = dpop();
-       CELL numerator = dpop();
+       CELL numerator, denominator;
+
+       maybe_garbage_collection();
+
+       denominator = dpop();
+       numerator = dpop();
        if(zerop(denominator))
                raise(SIGFPE);
        if(onep(denominator))

diff --git a/native/read.c b/native/read.c
index 35abaa101db46e3bf9f560b0e31db5ff58bd4ac9..0bf9d0f570b24f6629f52ff6a6677080bfb35739 100644 (file)
--- a/native/read.c
+++ b/native/read.c
@@ -107,8 +107,12 @@ void primitive_can_read_line(void)
 
 void primitive_add_read_line_io_task(void)
 {
-       CELL callback = dpop();
-       CELL port = dpop();
+       CELL callback, port;
+
+       maybe_garbage_collection();
+
+       callback = dpop();
+       port = dpop();
        add_io_task(IO_TASK_READ_LINE,port,F,callback,
                read_io_tasks,&read_fd_count);
 
@@ -140,7 +144,11 @@ bool perform_read_line_io_task(PORT* port)
 
 void primitive_read_line_8(void)
 {
-       PORT* port = untag_port(dpeek());
+       PORT* port;
+
+       maybe_garbage_collection();
+
+       port = untag_port(dpeek());
 
        pending_io_error(port);
 
@@ -199,16 +207,27 @@ bool can_read_count(PORT* port, FIXNUM count)
 
 void primitive_can_read_count(void)
 {
-       PORT* port = untag_port(dpop());
-       FIXNUM len = to_fixnum(dpop());
+       PORT* port;
+       FIXNUM len;
+
+       maybe_garbage_collection();
+
+       port = untag_port(dpop());
+       len = to_fixnum(dpop());
        dpush(tag_boolean(can_read_count(port,len)));
 }
 
 void primitive_add_read_count_io_task(void)
 {
-       CELL callback = dpop();
-       PORT* port = untag_port(dpop());
-       FIXNUM count = to_fixnum(dpop());
+       CELL callback;
+       PORT* port;
+       FIXNUM count;
+
+       maybe_garbage_collection();
+
+       callback = dpop();
+       port = untag_port(dpop());
+       count = to_fixnum(dpop());
        add_io_task(IO_TASK_READ_COUNT,
                tag_object(port),F,callback,
                read_io_tasks,&read_fd_count);
@@ -233,8 +252,13 @@ bool perform_read_count_io_task(PORT* port)
 
 void primitive_read_count_8(void)
 {
-       PORT* port = untag_port(dpop());
-       FIXNUM len = to_fixnum(dpop());
+       PORT* port;
+       FIXNUM len;
+
+       maybe_garbage_collection();
+
+       port = untag_port(dpop());
+       len = to_fixnum(dpop());
        if(port->count != len)
                critical_error("read# counts don't match",tag_object(port));
 

diff --git a/native/sbuf.c b/native/sbuf.c
index 9c1cefa9a81abe0fb9858a5085fce76ab5cc6a8a..125dc8eb197a1c15eb06f61338a4374a159e0103 100644 (file)
--- a/native/sbuf.c
+++ b/native/sbuf.c
@@ -10,6 +10,7 @@ SBUF* sbuf(FIXNUM capacity)
 
 void primitive_sbuf(void)
 {
+       maybe_garbage_collection();
        drepl(tag_object(sbuf(to_fixnum(dpeek()))));
 }
 
@@ -20,8 +21,13 @@ void primitive_sbuf_length(void)
 
 void primitive_set_sbuf_length(void)
 {
-       SBUF* sbuf = untag_sbuf(dpop());
-       FIXNUM length = to_fixnum(dpop());
+       SBUF* sbuf;
+       FIXNUM length;
+
+       maybe_garbage_collection();
+
+       sbuf = untag_sbuf(dpop());
+       length = to_fixnum(dpop());
        if(length < 0)
                range_error(tag_object(sbuf),length,sbuf->top);
        sbuf->top = length;
@@ -61,9 +67,15 @@ void set_sbuf_nth(SBUF* sbuf, CELL index, CHAR value)
 
 void primitive_set_sbuf_nth(void)
 {
-       SBUF* sbuf = untag_sbuf(dpop());
-       FIXNUM index = to_fixnum(dpop());
-       CELL value = dpop();
+       SBUF* sbuf;
+       FIXNUM index;
+       CELL value;
+
+       maybe_garbage_collection();
+
+       sbuf = untag_sbuf(dpop());
+       index = to_fixnum(dpop());
+       value = dpop();
 
        set_sbuf_nth(sbuf,index,value);
 }
@@ -79,8 +91,14 @@ void sbuf_append_string(SBUF* sbuf, STRING* string)
 
 void primitive_sbuf_append(void)
 {
-       SBUF* sbuf = untag_sbuf(dpop());
-       CELL object = dpop();
+       SBUF* sbuf;
+       CELL object;
+
+       maybe_garbage_collection();
+
+       sbuf = untag_sbuf(dpop());
+       object = dpop();
+
        switch(type_of(object))
        {
        case FIXNUM_TYPE:
@@ -98,8 +116,13 @@ void primitive_sbuf_append(void)
 
 void primitive_sbuf_to_string(void)
 {
-       SBUF* sbuf = untag_sbuf(dpeek());
-       STRING* s = string_clone(sbuf->string,sbuf->top);
+       SBUF* sbuf;
+       STRING* s;
+
+       maybe_garbage_collection();
+
+       sbuf = untag_sbuf(dpeek());
+       s = string_clone(sbuf->string,sbuf->top);
        rehash_string(s);
        drepl(tag_object(s));
 }
@@ -112,8 +135,14 @@ void primitive_sbuf_reverse(void)
 
 void primitive_sbuf_clone(void)
 {
-       SBUF* s = untag_sbuf(dpeek());
-       SBUF* new_s = sbuf(s->top);
+       SBUF* s;
+       SBUF* new_s;
+
+       maybe_garbage_collection();
+
+       s = untag_sbuf(dpeek());
+       new_s = sbuf(s->top);
+
        sbuf_append_string(new_s,s->string);
        drepl(tag_object(new_s));
 }

diff --git a/native/socket.c b/native/socket.c
index 3919fc8d1a5d66ed3c430c1261792db45b1054b8..5b5b59bd6c1124762e8e6b04c51620966177096c 100644 (file)
--- a/native/socket.c
+++ b/native/socket.c
@@ -45,8 +45,14 @@ int make_client_socket(const char* hostname, uint16_t port)
 void primitive_client_socket(void)
 {
        uint16_t p = (uint16_t)to_fixnum(dpop());
-       char* host = unbox_c_string();
-       int sock = make_client_socket(host,p);
+       char* host;
+       int sock;
+
+       maybe_garbage_collection();
+
+       host = unbox_c_string();
+       sock = make_client_socket(host,p);
+
        dpush(tag_object(port(PORT_RECV,sock)));
        dpush(tag_object(port(PORT_WRITE,sock)));
 }
@@ -91,13 +97,16 @@ int make_server_socket(uint16_t port)
 void primitive_server_socket(void)
 {
        uint16_t p = (uint16_t)to_fixnum(dpop());
+       maybe_garbage_collection();
        dpush(tag_object(port(PORT_SPECIAL,make_server_socket(p))));
 }
 
 void primitive_add_accept_io_task(void)
 {
-       CELL callback = dpop();
-       CELL port = dpop();
+       CELL callback, port;
+       maybe_garbage_collection();
+       callback = dpop();
+       port = dpop();
        add_io_task(IO_TASK_ACCEPT,port,F,callback,
                read_io_tasks,&read_fd_count);
 }
@@ -131,7 +140,9 @@ CELL accept_connection(PORT* p)
 
 void primitive_accept_fd(void)
 {
-       PORT* p = untag_port(dpop());
+       PORT* p;
+       maybe_garbage_collection();
+       p = untag_port(dpop());
        dpush(p->client_host);
        dpush(p->client_port);
        dpush(tag_object(port(PORT_RECV,p->client_socket)));

diff --git a/native/stack.c b/native/stack.c
index efb1acc4477682055d5d3478210970435ee2ee7d..5f00912d91c6d5d4845a775604ec43cd471bb213 100644 (file)
--- a/native/stack.c
+++ b/native/stack.c
@@ -94,15 +94,14 @@ VECTOR* stack_to_vector(CELL bottom, CELL top)
 
 void primitive_datastack(void)
 {
+       maybe_garbage_collection();
        dpush(tag_object(stack_to_vector(ds_bot,ds)));
 }
 
 void primitive_callstack(void)
 {
-       /* we don't want gc word to end up on callstack. */
-       gc_protect = true;
+       maybe_garbage_collection();
        dpush(tag_object(stack_to_vector(cs_bot,cs)));
-       gc_protect = false;
 }
 
 /* Returns top of stack */

diff --git a/native/string.c b/native/string.c
index 42a9fcd4c85a99ddd26270b2a540482cd25e6c00..66cbae3d6e433e877e9ea3b9479c73a4380f95b6 100644 (file)
--- a/native/string.c
+++ b/native/string.c
@@ -274,9 +274,14 @@ INLINE STRING* substring(CELL start, CELL end, STRING* string)
 /* start end string -- string */
 void primitive_substring(void)
 {
-       STRING* string = untag_string(dpop());
-       CELL end = to_fixnum(dpop());
-       CELL start = to_fixnum(dpop());
+       STRING* string;
+       CELL end, start;
+
+       maybe_garbage_collection();
+
+       string = untag_string(dpop());
+       end = to_fixnum(dpop());
+       start = to_fixnum(dpop());
        dpush(tag_object(substring(start,end,string)));
 }
 
@@ -305,7 +310,11 @@ STRING* string_clone(STRING* s, int len)
 
 void primitive_string_reverse(void)
 {
-       STRING* s = untag_string(dpeek());
+       STRING* s;
+
+       maybe_garbage_collection();
+
+       s = untag_string(dpeek());
        s = string_clone(s,s->capacity);
        string_reverse(s,s->capacity);
        rehash_string(s);

diff --git a/native/vector.c b/native/vector.c
index 761e2f79d0b750f742ddea2f677e27647833208c..3c704764e56eb741712e4e62ab4d5049d22c9be7 100644 (file)
--- a/native/vector.c
+++ b/native/vector.c
@@ -10,6 +10,7 @@ VECTOR* vector(FIXNUM capacity)
 
 void primitive_vector(void)
 {
+       maybe_garbage_collection();
        drepl(tag_object(vector(to_fixnum(dpeek()))));
 }
 
@@ -20,8 +21,13 @@ void primitive_vector_length(void)
 
 void primitive_set_vector_length(void)
 {
-       VECTOR* vector = untag_vector(dpop());
-       FIXNUM length = to_fixnum(dpop());
+       VECTOR* vector;
+       FIXNUM length;
+
+       maybe_garbage_collection();
+
+       vector = untag_vector(dpop());
+       length = to_fixnum(dpop());
        if(length < 0)
                range_error(tag_object(vector),length,vector->top);
        vector->top = length;
@@ -51,9 +57,15 @@ void vector_ensure_capacity(VECTOR* vector, CELL index)
 
 void primitive_set_vector_nth(void)
 {
-       VECTOR* vector = untag_vector(dpop());
-       FIXNUM index = to_fixnum(dpop());
-       CELL value = dpop();
+       VECTOR* vector;
+       FIXNUM index;
+       CELL value;
+
+       maybe_garbage_collection();
+
+       vector = untag_vector(dpop());
+       index = to_fixnum(dpop());
+       value = dpop();
 
        if(index < 0)
                range_error(tag_object(vector),index,vector->top);

diff --git a/native/word.c b/native/word.c
index 0b9f70a2a37137ae1789986fd724016d84b07c08..e611fd4d4568bf1cd1db3ccb616f33e52cfd4436 100644 (file)
--- a/native/word.c
+++ b/native/word.c
@@ -25,9 +25,13 @@ void update_xt(WORD* word)
 /* <word> ( primitive parameter plist -- word ) */
 void primitive_word(void)
 {
-       CELL plist = dpop();
+       CELL plist, parameter;
        FIXNUM primitive;
-       CELL parameter = dpop();
+
+       maybe_garbage_collection();
+
+       plist = dpop();
+       parameter = dpop();
        primitive = to_fixnum(dpop());
        dpush(tag_word(word(primitive,parameter,plist)));
 }

diff --git a/native/write.c b/native/write.c
index 84e6c7dd2840e3f6d2c2345dfff0b2d6afe3718b..363805b6bed2dbe0e1cbb026621b66e2b5aff7c9 100644 (file)
--- a/native/write.c
+++ b/native/write.c
@@ -38,16 +38,25 @@ bool can_write(PORT* port, FIXNUM len)
 
 void primitive_can_write(void)
 {
-       PORT* port = untag_port(dpop());
-       FIXNUM len = to_fixnum(dpop());
+       PORT* port;
+       FIXNUM len;
+
+       maybe_garbage_collection();
+       
+       port = untag_port(dpop());
+       len = to_fixnum(dpop());
        pending_io_error(port);
        dpush(tag_boolean(can_write(port,len)));
 }
 
 void primitive_add_write_io_task(void)
 {
-       CELL callback = dpop();
-       CELL port = dpop();
+       CELL callback, port;
+
+       maybe_garbage_collection();
+
+       callback = dpop();
+       port = dpop();
        add_io_task(IO_TASK_WRITE,port,F,callback,
                write_io_tasks,&write_fd_count);
 }
@@ -107,12 +116,17 @@ void write_string_8(PORT* port, STRING* str)
 
 void primitive_write_8(void)
 {
-       PORT* port = untag_port(dpop());
-
-       CELL text = dpop();
-       CELL type = type_of(text);
+       PORT* port;
+       CELL text, type;
        STRING* str;
 
+       maybe_garbage_collection();
+
+       port = untag_port(dpop());
+
+       text = dpop();
+       type = type_of(text);
+
        pending_io_error(port);
 
        switch(type)