Various VM cleanups, new approach for bignum GC root registration

Makefile

@@ -179,6 +179,9 @@ clean:
 	rm -f vm/*.o
 	rm -f factor*.dll libfactor.{a,so,dylib} libfactor-ffi-test.{a,so,dylib} Factor.app/Contents/Frameworks/libfactor.dylib
 
+tags:
+	etags vm/*.{cpp,hpp,mm,S,c}
+
 vm/resources.o:
 	$(WINDRES) vm/factor.rs vm/resources.o
 
@@ -197,6 +200,6 @@ vm/ffi_test.o: vm/ffi_test.c
 .mm.o:
 	$(CPP) -c $(CFLAGS) -o $@ $<
 
-.PHONY: factor
+.PHONY: factor tags clean
 
 .SUFFIXES: .mm

vm/bignum.cpp

@@ -505,6 +505,8 @@ bignum_compare_unsigned(F_BIGNUM * x, F_BIGNUM * y)
 F_BIGNUM *
 bignum_add_unsigned(F_BIGNUM * x, F_BIGNUM * y, int negative_p)
 {
+  GC_BIGNUM(x); GC_BIGNUM(y);
+
   if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x)))
     {
       F_BIGNUM * z = x;
@@ -514,11 +516,7 @@ bignum_add_unsigned(F_BIGNUM * x, F_BIGNUM * y, int negative_p)
   {
     bignum_length_type x_length = (BIGNUM_LENGTH (x));
     
-    REGISTER_BIGNUM(x);
-    REGISTER_BIGNUM(y);
     F_BIGNUM * r = (allot_bignum ((x_length + 1), negative_p));
-    UNREGISTER_BIGNUM(y);
-    UNREGISTER_BIGNUM(x);
 
     bignum_digit_type sum;
     bignum_digit_type carry = 0;
@@ -575,6 +573,8 @@ bignum_add_unsigned(F_BIGNUM * x, F_BIGNUM * y, int negative_p)
 F_BIGNUM *
 bignum_subtract_unsigned(F_BIGNUM * x, F_BIGNUM * y)
 {
+  GC_BIGNUM(x); GC_BIGNUM(y);
+  
   int negative_p = 0;
   switch (bignum_compare_unsigned (x, y))
     {
@@ -595,11 +595,7 @@ bignum_subtract_unsigned(F_BIGNUM * x, F_BIGNUM * y)
   {
     bignum_length_type x_length = (BIGNUM_LENGTH (x));
     
-    REGISTER_BIGNUM(x);
-    REGISTER_BIGNUM(y);
     F_BIGNUM * r = (allot_bignum (x_length, negative_p));
-    UNREGISTER_BIGNUM(y);
-    UNREGISTER_BIGNUM(x);
 
     bignum_digit_type difference;
     bignum_digit_type borrow = 0;
@@ -656,6 +652,8 @@ bignum_subtract_unsigned(F_BIGNUM * x, F_BIGNUM * y)
 F_BIGNUM *
 bignum_multiply_unsigned(F_BIGNUM * x, F_BIGNUM * y, int negative_p)
 {
+  GC_BIGNUM(x); GC_BIGNUM(y);
+
   if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x)))
     {
       F_BIGNUM * z = x;
@@ -674,12 +672,8 @@ bignum_multiply_unsigned(F_BIGNUM * x, F_BIGNUM * y, int negative_p)
     bignum_length_type x_length = (BIGNUM_LENGTH (x));
     bignum_length_type y_length = (BIGNUM_LENGTH (y));
 
-    REGISTER_BIGNUM(x);
-    REGISTER_BIGNUM(y);
     F_BIGNUM * r =
       (allot_bignum_zeroed ((x_length + y_length), negative_p));
-    UNREGISTER_BIGNUM(y);
-    UNREGISTER_BIGNUM(x);
 
     bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
     bignum_digit_type * end_x = (scan_x + x_length);
@@ -731,11 +725,11 @@ F_BIGNUM *
 bignum_multiply_unsigned_small_factor(F_BIGNUM * x, bignum_digit_type y,
                                       int negative_p)
 {
+  GC_BIGNUM(x);
+  
   bignum_length_type length_x = (BIGNUM_LENGTH (x));
 
-  REGISTER_BIGNUM(x);
   F_BIGNUM * p = (allot_bignum ((length_x + 1), negative_p));
-  UNREGISTER_BIGNUM(x);
 
   bignum_destructive_copy (x, p);
   (BIGNUM_REF (p, length_x)) = 0;
@@ -813,23 +807,19 @@ bignum_divide_unsigned_large_denominator(F_BIGNUM * numerator,
                                          int q_negative_p,
                                          int r_negative_p)
 {
+  GC_BIGNUM(numerator); GC_BIGNUM(denominator);
+  
   bignum_length_type length_n = ((BIGNUM_LENGTH (numerator)) + 1);
   bignum_length_type length_d = (BIGNUM_LENGTH (denominator));
 
-  REGISTER_BIGNUM(numerator);
-  REGISTER_BIGNUM(denominator);
-
   F_BIGNUM * q =
     ((quotient != ((F_BIGNUM * *) 0))
      ? (allot_bignum ((length_n - length_d), q_negative_p))
      : BIGNUM_OUT_OF_BAND);
+  GC_BIGNUM(q);
   
-  REGISTER_BIGNUM(q);
   F_BIGNUM * u = (allot_bignum (length_n, r_negative_p));
-  UNREGISTER_BIGNUM(q);
+  GC_BIGNUM(u);
-
-  UNREGISTER_BIGNUM(denominator);
-  UNREGISTER_BIGNUM(numerator);
   
   int shift = 0;
   BIGNUM_ASSERT (length_d > 1);
@@ -849,15 +839,7 @@ bignum_divide_unsigned_large_denominator(F_BIGNUM * numerator,
     }
   else
     {
-      REGISTER_BIGNUM(numerator);
-      REGISTER_BIGNUM(denominator);
-      REGISTER_BIGNUM(u);
-      REGISTER_BIGNUM(q);
       F_BIGNUM * v = (allot_bignum (length_d, 0));
-      UNREGISTER_BIGNUM(q);
-      UNREGISTER_BIGNUM(u);
-      UNREGISTER_BIGNUM(denominator);
-      UNREGISTER_BIGNUM(numerator);
 
       bignum_destructive_normalization (numerator, u, shift);
       bignum_destructive_normalization (denominator, v, shift);
@@ -866,14 +848,10 @@ bignum_divide_unsigned_large_denominator(F_BIGNUM * numerator,
         bignum_destructive_unnormalization (u, shift);
     }
 
-  REGISTER_BIGNUM(u);
   if(q)
     q = bignum_trim (q);
-  UNREGISTER_BIGNUM(u);
 
-  REGISTER_BIGNUM(q);
   u = bignum_trim (u);
-  UNREGISTER_BIGNUM(q);
 
   if (quotient != ((F_BIGNUM * *) 0))
     (*quotient) = q;
@@ -1047,9 +1025,13 @@ bignum_divide_unsigned_medium_denominator(F_BIGNUM * numerator,
                                           int q_negative_p,
                                           int r_negative_p)
 {
+  GC_BIGNUM(numerator);
+  
   bignum_length_type length_n = (BIGNUM_LENGTH (numerator));
   bignum_length_type length_q;
-  F_BIGNUM * q;
+  F_BIGNUM * q = NULL;
+  GC_BIGNUM(q);
+  
   int shift = 0;
   /* Because `bignum_digit_divide' requires a normalized denominator. */
   while (denominator < (BIGNUM_RADIX / 2))
@@ -1061,20 +1043,14 @@ bignum_divide_unsigned_medium_denominator(F_BIGNUM * numerator,
     {
       length_q = length_n;
 
-      REGISTER_BIGNUM(numerator);
       q = (allot_bignum (length_q, q_negative_p));
-      UNREGISTER_BIGNUM(numerator);
-
       bignum_destructive_copy (numerator, q);
     }
   else
     {
       length_q = (length_n + 1);
 
-      REGISTER_BIGNUM(numerator);
       q = (allot_bignum (length_q, q_negative_p));
-      UNREGISTER_BIGNUM(numerator);
-
       bignum_destructive_normalization (numerator, q, shift);
     }
   {
@@ -1096,9 +1072,7 @@ bignum_divide_unsigned_medium_denominator(F_BIGNUM * numerator,
         if (shift != 0)
           r >>= shift;
 
-        REGISTER_BIGNUM(q);
         (*remainder) = (bignum_digit_to_bignum (r, r_negative_p));
-        UNREGISTER_BIGNUM(q);
       }
 
     if (quotient != ((F_BIGNUM * *) 0))
@@ -1295,20 +1269,17 @@ bignum_divide_unsigned_small_denominator(F_BIGNUM * numerator,
                                          int q_negative_p,
                                          int r_negative_p)
 {
-  REGISTER_BIGNUM(numerator);
+  GC_BIGNUM(numerator);
+  
   F_BIGNUM * q = (bignum_new_sign (numerator, q_negative_p));
-  UNREGISTER_BIGNUM(numerator);
+  GC_BIGNUM(q);
 
   bignum_digit_type r = (bignum_destructive_scale_down (q, denominator));
 
   q = (bignum_trim (q));
 
   if (remainder != ((F_BIGNUM * *) 0))
-  {
-    REGISTER_BIGNUM(q);
     (*remainder) = (bignum_digit_to_bignum (r, r_negative_p));
-    UNREGISTER_BIGNUM(q);
-  }
 
   (*quotient) = q;
 
@@ -1381,6 +1352,7 @@ bignum_digit_to_bignum(bignum_digit_type digit, int negative_p)
 F_BIGNUM *
 allot_bignum(bignum_length_type length, int negative_p)
 {
+	gc();
   BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX));
   F_BIGNUM * result = allot_array_internal<F_BIGNUM>(length + 1);
   BIGNUM_SET_NEGATIVE_P (result, negative_p);
@@ -1441,10 +1413,8 @@ bignum_trim(F_BIGNUM * bignum)
 F_BIGNUM *
 bignum_new_sign(F_BIGNUM * bignum, int negative_p)
 {
-  REGISTER_BIGNUM(bignum);
+  GC_BIGNUM(bignum);
-  F_BIGNUM * result =
+  F_BIGNUM * result = (allot_bignum ((BIGNUM_LENGTH (bignum)), negative_p));
-    (allot_bignum ((BIGNUM_LENGTH (bignum)), negative_p));
-  UNREGISTER_BIGNUM(bignum);
 
   bignum_destructive_copy (bignum, result);
   return (result);
@@ -1553,6 +1523,8 @@ bignum_bitwise_xor(F_BIGNUM * arg1, F_BIGNUM * arg2)
 F_BIGNUM *
 bignum_magnitude_ash(F_BIGNUM * arg1, F_FIXNUM n)
 {
+  GC_BIGNUM(arg1);
+  
   F_BIGNUM * result = NULL;
   bignum_digit_type *scan1;
   bignum_digit_type *scanr;
@@ -1566,10 +1538,8 @@ bignum_magnitude_ash(F_BIGNUM * arg1, F_FIXNUM n)
     digit_offset = n / BIGNUM_DIGIT_LENGTH;
     bit_offset =   n % BIGNUM_DIGIT_LENGTH;
 
-    REGISTER_BIGNUM(arg1);
     result = allot_bignum_zeroed (BIGNUM_LENGTH (arg1) + digit_offset + 1,
-                                     BIGNUM_NEGATIVE_P(arg1));
+                                  BIGNUM_NEGATIVE_P(arg1));
-    UNREGISTER_BIGNUM(arg1);
 
     scanr = BIGNUM_START_PTR (result) + digit_offset;
     scan1 = BIGNUM_START_PTR (arg1);
@@ -1591,10 +1561,8 @@ bignum_magnitude_ash(F_BIGNUM * arg1, F_FIXNUM n)
     digit_offset = -n / BIGNUM_DIGIT_LENGTH;
     bit_offset =   -n % BIGNUM_DIGIT_LENGTH;
     
-    REGISTER_BIGNUM(arg1);
     result = allot_bignum_zeroed (BIGNUM_LENGTH (arg1) - digit_offset,
-                                     BIGNUM_NEGATIVE_P(arg1));
+                                  BIGNUM_NEGATIVE_P(arg1));
-    UNREGISTER_BIGNUM(arg1);
     
     scanr = BIGNUM_START_PTR (result);
     scan1 = BIGNUM_START_PTR (arg1) + digit_offset;
@@ -1617,6 +1585,8 @@ bignum_magnitude_ash(F_BIGNUM * arg1, F_FIXNUM n)
 F_BIGNUM *
 bignum_pospos_bitwise_op(int op, F_BIGNUM * arg1, F_BIGNUM * arg2)
 {
+  GC_BIGNUM(arg1); GC_BIGNUM(arg2);
+  
   F_BIGNUM * result;
   bignum_length_type max_length;
 
@@ -1627,11 +1597,7 @@ bignum_pospos_bitwise_op(int op, F_BIGNUM * arg1, F_BIGNUM * arg2)
   max_length =  (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2))
                ? BIGNUM_LENGTH(arg1) : BIGNUM_LENGTH(arg2);
 
-  REGISTER_BIGNUM(arg1);
-  REGISTER_BIGNUM(arg2);
   result = allot_bignum(max_length, 0);
-  UNREGISTER_BIGNUM(arg2);
-  UNREGISTER_BIGNUM(arg1);
 
   scanr = BIGNUM_START_PTR(result);
   scan1 = BIGNUM_START_PTR(arg1);
@@ -1654,6 +1620,8 @@ bignum_pospos_bitwise_op(int op, F_BIGNUM * arg1, F_BIGNUM * arg2)
 F_BIGNUM *
 bignum_posneg_bitwise_op(int op, F_BIGNUM * arg1, F_BIGNUM * arg2)
 {
+  GC_BIGNUM(arg1); GC_BIGNUM(arg2);
+  
   F_BIGNUM * result;
   bignum_length_type max_length;
 
@@ -1666,11 +1634,7 @@ bignum_posneg_bitwise_op(int op, F_BIGNUM * arg1, F_BIGNUM * arg2)
   max_length =  (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2) + 1)
                ? BIGNUM_LENGTH(arg1) : BIGNUM_LENGTH(arg2) + 1;
 
-  REGISTER_BIGNUM(arg1);
-  REGISTER_BIGNUM(arg2);
   result = allot_bignum(max_length, neg_p);
-  UNREGISTER_BIGNUM(arg2);
-  UNREGISTER_BIGNUM(arg1);
 
   scanr = BIGNUM_START_PTR(result);
   scan1 = BIGNUM_START_PTR(arg1);
@@ -1709,6 +1673,8 @@ bignum_posneg_bitwise_op(int op, F_BIGNUM * arg1, F_BIGNUM * arg2)
 F_BIGNUM *
 bignum_negneg_bitwise_op(int op, F_BIGNUM * arg1, F_BIGNUM * arg2)
 {
+  GC_BIGNUM(arg1); GC_BIGNUM(arg2);
+  
   F_BIGNUM * result;
   bignum_length_type max_length;
 
@@ -1721,11 +1687,7 @@ bignum_negneg_bitwise_op(int op, F_BIGNUM * arg1, F_BIGNUM * arg2)
   max_length =  (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2))
                ? BIGNUM_LENGTH(arg1) + 1 : BIGNUM_LENGTH(arg2) + 1;
 
-  REGISTER_BIGNUM(arg1);
-  REGISTER_BIGNUM(arg2);
   result = allot_bignum(max_length, neg_p);
-  UNREGISTER_BIGNUM(arg2);
-  UNREGISTER_BIGNUM(arg1);
 
   scanr = BIGNUM_START_PTR(result);
   scan1 = BIGNUM_START_PTR(arg1);
@@ -1800,12 +1762,12 @@ bignum_negate_magnitude(F_BIGNUM * arg)
 F_BIGNUM *
 bignum_integer_length(F_BIGNUM * bignum)
 {
+  GC_BIGNUM(bignum);
+  
   bignum_length_type index = ((BIGNUM_LENGTH (bignum)) - 1);
   bignum_digit_type digit = (BIGNUM_REF (bignum, index));
   
-  REGISTER_BIGNUM(bignum);
   F_BIGNUM * result = (allot_bignum (2, 0));
-  UNREGISTER_BIGNUM(bignum);
   
   (BIGNUM_REF (result, 0)) = index;
   (BIGNUM_REF (result, 1)) = 0;

vm/callstack.cpp

@@ -3,7 +3,7 @@
 static void check_frame(F_STACK_FRAME *frame)
 {
 #ifdef FACTOR_DEBUG
-	check_code_pointer(frame->xt);
+	check_code_pointer((CELL)frame->xt);
 	assert(frame->size != 0);
 #endif
 }
@@ -20,9 +20,8 @@ void iterate_callstack(CELL top, CELL bottom, CALLSTACK_ITER iterator)
 
 	while((CELL)frame >= top)
 	{
-		F_STACK_FRAME *next = frame_successor(frame);
 		iterator(frame);
-		frame = next;
+		frame = frame_successor(frame);
 	}
 }
 

vm/data_gc.cpp

@@ -37,8 +37,109 @@ void init_data_gc(void)
 	collecting_aging_again = false;
 }
 
+/* Given a pointer to oldspace, copy it to newspace */
+static void *copy_untagged_object(void *pointer, CELL size)
+{
+	if(newspace->here + size >= newspace->end)
+		longjmp(gc_jmp,1);
+	allot_barrier(newspace->here);
+	void *newpointer = allot_zone(newspace,size);
+
+	F_GC_STATS *s = &gc_stats[collecting_gen];
+	s->object_count++;
+	s->bytes_copied += size;
+
+	memcpy(newpointer,pointer,size);
+	return newpointer;
+}
+
+static void forward_object(CELL untagged, CELL newpointer)
+{
+	put(untagged,RETAG(newpointer,GC_COLLECTED));
+}
+
+static CELL copy_object_impl(CELL untagged)
+{
+	CELL newpointer = (CELL)copy_untagged_object(
+		(void*)untagged,
+		untagged_object_size(untagged));
+	forward_object(untagged,newpointer);
+	return newpointer;
+}
+
+static bool should_copy_p(CELL untagged)
+{
+	if(in_zone(newspace,untagged))
+		return false;
+	if(collecting_gen == TENURED)
+		return true;
+	else if(HAVE_AGING_P && collecting_gen == AGING)
+		return !in_zone(&data_heap->generations[TENURED],untagged);
+	else if(collecting_gen == NURSERY)
+		return in_zone(&nursery,untagged);
+	else
+	{
+		critical_error("Bug in should_copy_p",untagged);
+		return false;
+	}
+}
+
+/* Follow a chain of forwarding pointers */
+static CELL resolve_forwarding(CELL untagged, CELL tag)
+{
+	check_data_pointer(untagged);
+
+	CELL header = get(untagged);
+	/* another forwarding pointer */
+	if(TAG(header) == GC_COLLECTED)
+		return resolve_forwarding(UNTAG(header),tag);
+	/* we've found the destination */
+	else
+	{
+		check_header(header);
+		CELL pointer = RETAG(untagged,tag);
+		if(should_copy_p(untagged))
+			pointer = RETAG(copy_object_impl(untagged),tag);
+		return pointer;
+	}
+}
+
+/* Given a pointer to a tagged pointer to oldspace, copy it to newspace.
+If the object has already been copied, return the forwarding
+pointer address without copying anything; otherwise, install
+a new forwarding pointer. While this preserves the tag, it does
+not dispatch on it in any way. */
+static CELL copy_object(CELL pointer)
+{
+	check_data_pointer(pointer);
+
+	CELL tag = TAG(pointer);
+	CELL untagged = UNTAG(pointer);
+	CELL header = get(untagged);
+
+	if(TAG(header) == GC_COLLECTED)
+		return resolve_forwarding(UNTAG(header),tag);
+	else
+	{
+		check_header(header);
+		return RETAG(copy_object_impl(untagged),tag);
+	}
+}
+
+void copy_handle(CELL *handle)
+{
+	CELL pointer = *handle;
+
+	if(!immediate_p(pointer))
+	{
+		check_data_pointer(pointer);
+		if(should_copy_p(pointer))
+			*handle = copy_object(pointer);
+	}
+}
+
 /* Scan all the objects in the card */
-void copy_card(F_CARD *ptr, CELL gen, CELL here)
+static void copy_card(F_CARD *ptr, CELL gen, CELL here)
 {
 	CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + CARD_OFFSET(ptr);
 	CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1);
@@ -51,7 +152,7 @@ void copy_card(F_CARD *ptr, CELL gen, CELL here)
 	cards_scanned++;
 }
 
-void copy_card_deck(F_DECK *deck, CELL gen, F_CARD mask, F_CARD unmask)
+static void copy_card_deck(F_DECK *deck, CELL gen, F_CARD mask, F_CARD unmask)
 {
 	F_CARD *first_card = DECK_TO_CARD(deck);
 	F_CARD *last_card = DECK_TO_CARD(deck + 1);
@@ -83,7 +184,7 @@ void copy_card_deck(F_DECK *deck, CELL gen, F_CARD mask, F_CARD unmask)
 }
 
 /* Copy all newspace objects referenced from marked cards to the destination */
-void copy_gen_cards(CELL gen)
+static void copy_gen_cards(CELL gen)
 {
 	F_DECK *first_deck = ADDR_TO_DECK(data_heap->generations[gen].start);
 	F_DECK *last_deck = ADDR_TO_DECK(data_heap->generations[gen].end);
@@ -150,7 +251,7 @@ void copy_gen_cards(CELL gen)
 
 /* Scan cards in all generations older than the one being collected, copying
 old->new references */
-void copy_cards(void)
+static void copy_cards(void)
 {
 	u64 start = current_micros();
 
@@ -162,7 +263,7 @@ void copy_cards(void)
 }
 
 /* Copy all tagged pointers in a range of memory */
-void copy_stack_elements(F_SEGMENT *region, CELL top)
+static void copy_stack_elements(F_SEGMENT *region, CELL top)
 {
 	CELL ptr = region->start;
 
@@ -170,17 +271,38 @@ void copy_stack_elements(F_SEGMENT *region, CELL top)
 		copy_handle((CELL*)ptr);
 }
 
-void copy_registered_locals(void)
+static void copy_registered_locals(void)
 {
-	CELL ptr = gc_locals_region->start;
+	CELL scan = gc_locals_region->start;
 
-	for(; ptr <= gc_locals; ptr += CELLS)
+	for(; scan <= gc_locals; scan += CELLS)
-		copy_handle(*(CELL **)ptr);
+		copy_handle(*(CELL **)scan);
+}
+
+static void copy_registered_bignums(void)
+{
+	CELL scan = gc_bignums_region->start;
+
+	for(; scan <= gc_bignums; scan += CELLS)
+	{
+		CELL *handle = *(CELL **)scan;
+		CELL pointer = *handle;
+
+		if(pointer)
+		{
+			check_data_pointer(pointer);
+			if(should_copy_p(pointer))
+				*handle = copy_object(pointer);
+#ifdef FACTOR_DEBUG
+			assert(hi_tag(*handle) == BIGNUM_TYPE);
+#endif
+		}
+	}
 }
 
 /* Copy roots over at the start of GC, namely various constants, stacks,
 the user environment and extra roots registered by local_roots.hpp */
-void copy_roots(void)
+static void copy_roots(void)
 {
 	copy_handle(&T);
 	copy_handle(&bignum_zero);
@@ -188,7 +310,7 @@ void copy_roots(void)
 	copy_handle(&bignum_neg_one);
 
 	copy_registered_locals();
-	copy_stack_elements(extra_roots_region,extra_roots);
+	copy_registered_bignums();
 
 	if(!performing_compaction)
 	{
@@ -214,107 +336,7 @@ void copy_roots(void)
 		copy_handle(&userenv[i]);
 }
 
-/* Given a pointer to oldspace, copy it to newspace */
+static CELL copy_next_from_nursery(CELL scan)
-INLINE void *copy_untagged_object(void *pointer, CELL size)
-{
-	if(newspace->here + size >= newspace->end)
-		longjmp(gc_jmp,1);
-	allot_barrier(newspace->here);
-	void *newpointer = allot_zone(newspace,size);
-
-	F_GC_STATS *s = &gc_stats[collecting_gen];
-	s->object_count++;
-	s->bytes_copied += size;
-
-	memcpy(newpointer,pointer,size);
-	return newpointer;
-}
-
-INLINE void forward_object(CELL pointer, CELL newpointer)
-{
-	if(pointer != newpointer)
-		put(UNTAG(pointer),RETAG(newpointer,GC_COLLECTED));
-}
-
-INLINE CELL copy_object_impl(CELL pointer)
-{
-	CELL newpointer = (CELL)copy_untagged_object(
-		(void*)UNTAG(pointer),
-		object_size(pointer));
-	forward_object(pointer,newpointer);
-	return newpointer;
-}
-
-bool should_copy_p(CELL untagged)
-{
-	if(in_zone(newspace,untagged))
-		return false;
-	if(collecting_gen == TENURED)
-		return true;
-	else if(HAVE_AGING_P && collecting_gen == AGING)
-		return !in_zone(&data_heap->generations[TENURED],untagged);
-	else if(collecting_gen == NURSERY)
-		return in_zone(&nursery,untagged);
-	else
-	{
-		critical_error("Bug in should_copy_p",untagged);
-		return false;
-	}
-}
-
-/* Follow a chain of forwarding pointers */
-CELL resolve_forwarding(CELL untagged, CELL tag)
-{
-	check_data_pointer(untagged);
-
-	CELL header = get(untagged);
-	/* another forwarding pointer */
-	if(TAG(header) == GC_COLLECTED)
-		return resolve_forwarding(UNTAG(header),tag);
-	/* we've found the destination */
-	else
-	{
-		check_header(header);
-		CELL pointer = RETAG(untagged,tag);
-		if(should_copy_p(untagged))
-			pointer = RETAG(copy_object_impl(pointer),tag);
-		return pointer;
-	}
-}
-
-/* Given a pointer to a tagged pointer to oldspace, copy it to newspace.
-If the object has already been copied, return the forwarding
-pointer address without copying anything; otherwise, install
-a new forwarding pointer. */
-INLINE CELL copy_object(CELL pointer)
-{
-	check_data_pointer(pointer);
-
-	CELL tag = TAG(pointer);
-	CELL header = get(UNTAG(pointer));
-
-	if(TAG(header) == GC_COLLECTED)
-		return resolve_forwarding(UNTAG(header),tag);
-	else
-	{
-		check_header(header);
-		return RETAG(copy_object_impl(pointer),tag);
-	}
-}
-
-void copy_handle(CELL *handle)
-{
-	CELL pointer = *handle;
-
-	if(!immediate_p(pointer))
-	{
-		check_data_pointer(pointer);
-		if(should_copy_p(pointer))
-			*handle = copy_object(pointer);
-	}
-}
-
-CELL copy_next_from_nursery(CELL scan)
 {
 	CELL *obj = (CELL *)scan;
 	CELL *end = (CELL *)(scan + binary_payload_start(scan));
@@ -342,7 +364,7 @@ CELL copy_next_from_nursery(CELL scan)
 	return scan + untagged_object_size(scan);
 }
 
-CELL copy_next_from_aging(CELL scan)
+static CELL copy_next_from_aging(CELL scan)
 {
 	CELL *obj = (CELL *)scan;
 	CELL *end = (CELL *)(scan + binary_payload_start(scan));
@@ -374,7 +396,7 @@ CELL copy_next_from_aging(CELL scan)
 	return scan + untagged_object_size(scan);
 }
 
-CELL copy_next_from_tenured(CELL scan)
+static CELL copy_next_from_tenured(CELL scan)
 {
 	CELL *obj = (CELL *)scan;
 	CELL *end = (CELL *)(scan + binary_payload_start(scan));
@@ -424,7 +446,7 @@ void copy_reachable_objects(CELL scan, CELL *end)
 }
 
 /* Prepare to start copying reachable objects into an unused zone */
-void begin_gc(CELL requested_bytes)
+static void begin_gc(CELL requested_bytes)
 {
 	if(growing_data_heap)
 	{
@@ -457,7 +479,7 @@ void begin_gc(CELL requested_bytes)
 	}
 }
 
-void end_gc(CELL gc_elapsed)
+static void end_gc(CELL gc_elapsed)
 {
 	F_GC_STATS *s = &gc_stats[collecting_gen];
 
@@ -604,19 +626,19 @@ void primitive_gc_stats(void)
 	{
 		F_GC_STATS *s = &gc_stats[i];
 		stats.add(allot_cell(s->collections));
-		stats.add(tag_bignum(long_long_to_bignum(s->gc_time)));
+		stats.add(tag<F_BIGNUM>(long_long_to_bignum(s->gc_time)));
-		stats.add(tag_bignum(long_long_to_bignum(s->max_gc_time)));
+		stats.add(tag<F_BIGNUM>(long_long_to_bignum(s->max_gc_time)));
 		stats.add(allot_cell(s->collections == 0 ? 0 : s->gc_time / s->collections));
 		stats.add(allot_cell(s->object_count));
-		stats.add(tag_bignum(long_long_to_bignum(s->bytes_copied)));
+		stats.add(tag<F_BIGNUM>(long_long_to_bignum(s->bytes_copied)));
 
 		total_gc_time += s->gc_time;
 	}
 
-	stats.add(tag_bignum(ulong_long_to_bignum(total_gc_time)));
+	stats.add(tag<F_BIGNUM>(ulong_long_to_bignum(total_gc_time)));
-	stats.add(tag_bignum(ulong_long_to_bignum(cards_scanned)));
+	stats.add(tag<F_BIGNUM>(ulong_long_to_bignum(cards_scanned)));
-	stats.add(tag_bignum(ulong_long_to_bignum(decks_scanned)));
+	stats.add(tag<F_BIGNUM>(ulong_long_to_bignum(decks_scanned)));
-	stats.add(tag_bignum(ulong_long_to_bignum(card_scan_time)));
+	stats.add(tag<F_BIGNUM>(ulong_long_to_bignum(card_scan_time)));
 	stats.add(allot_cell(code_heap_scans));
 
 	stats.trim();
@@ -644,8 +666,8 @@ void primitive_clear_gc_stats(void)
    to coalesce equal but distinct quotations and wrappers. */
 void primitive_become(void)
 {
-	F_ARRAY *new_objects = untag_array(dpop());
+	F_ARRAY *new_objects = untag_check<F_ARRAY>(dpop());
-	F_ARRAY *old_objects = untag_array(dpop());
+	F_ARRAY *old_objects = untag_check<F_ARRAY>(dpop());
 
 	CELL capacity = array_capacity(new_objects);
 	if(capacity != array_capacity(old_objects))
@@ -658,7 +680,8 @@ void primitive_become(void)
 		CELL old_obj = array_nth(old_objects,i);
 		CELL new_obj = array_nth(new_objects,i);
 
-		forward_object(old_obj,new_obj);
+		if(old_obj != new_obj)
+			forward_object(UNTAG(old_obj),new_obj);
 	}
 
 	gc();

vm/data_gc.h

@@ -1,159 +0,0 @@
-void gc(void);
-DLLEXPORT void minor_gc(void);
-
-/* used during garbage collection only */
-
-F_ZONE *newspace;
-bool performing_gc;
-bool performing_compaction;
-CELL collecting_gen;
-
-/* if true, we collecting AGING space for the second time, so if it is still
-full, we go on to collect TENURED */
-bool collecting_aging_again;
-
-/* in case a generation fills up in the middle of a gc, we jump back
-up to try collecting the next generation. */
-jmp_buf gc_jmp;
-
-/* statistics */
-typedef struct {
-	CELL collections;
-	u64 gc_time;
-	u64 max_gc_time;
-	CELL object_count;
-	u64 bytes_copied;
-} F_GC_STATS;
-
-F_GC_STATS gc_stats[MAX_GEN_COUNT];
-u64 cards_scanned;
-u64 decks_scanned;
-u64 card_scan_time;
-CELL code_heap_scans;
-
-/* What generation was being collected when copy_code_heap_roots() was last
-called? Until the next call to add_code_block(), future
-collections of younger generations don't have to touch the code
-heap. */
-CELL last_code_heap_scan;
-
-/* sometimes we grow the heap */
-bool growing_data_heap;
-F_DATA_HEAP *old_data_heap;
-
-INLINE bool collecting_accumulation_gen_p(void)
-{
-	return ((HAVE_AGING_P
-		&& collecting_gen == AGING
-		&& !collecting_aging_again)
-		|| collecting_gen == TENURED);
-}
-
-/* test if the pointer is in generation being collected, or a younger one. */
-INLINE bool should_copy(CELL untagged)
-{
-	if(in_zone(newspace,untagged))
-		return false;
-	if(collecting_gen == TENURED)
-		return true;
-	else if(HAVE_AGING_P && collecting_gen == AGING)
-		return !in_zone(&data_heap->generations[TENURED],untagged);
-	else if(collecting_gen == NURSERY)
-		return in_zone(&nursery,untagged);
-	else
-	{
-		critical_error("Bug in should_copy",untagged);
-		return false;
-	}
-}
-
-void copy_handle(CELL *handle);
-
-void garbage_collection(volatile CELL gen,
-	bool growing_data_heap_,
-	CELL requested_bytes);
-
-/* We leave this many bytes free at the top of the nursery so that inline
-allocation (which does not call GC because of possible roots in volatile
-registers) does not run out of memory */
-#define ALLOT_BUFFER_ZONE 1024
-
-/* If this is defined, we GC every allocation. This catches missing local roots */
-
-/*
- * It is up to the caller to fill in the object's fields in a meaningful
- * fashion!
- */
-
-INLINE void *allot_object(CELL type, CELL a)
-{
-#ifdef GC_DEBUG
-	if(!gc_off)
-		gc();
-#endif
-
-	CELL *object;
-
-	if(nursery.size - ALLOT_BUFFER_ZONE > a)
-	{
-		/* If there is insufficient room, collect the nursery */
-		if(nursery.here + ALLOT_BUFFER_ZONE + a > nursery.end)
-			garbage_collection(NURSERY,false,0);
-
-		CELL h = nursery.here;
-		nursery.here = h + align8(a);
-		object = (CELL*)h;
-	}
-	/* If the object is bigger than the nursery, allocate it in
-	tenured space */
-	else
-	{
-		F_ZONE *tenured = &data_heap->generations[TENURED];
-
-		/* If tenured space does not have enough room, collect */
-		if(tenured->here + a > tenured->end)
-		{
-			gc();
-			tenured = &data_heap->generations[TENURED];
-		}
-
-		/* If it still won't fit, grow the heap */
-		if(tenured->here + a > tenured->end)
-		{
-			garbage_collection(TENURED,true,a);
-			tenured = &data_heap->generations[TENURED];
-		}
-
-		object = (CELL *)allot_zone(tenured,a);
-
-		/* We have to do this */
-		allot_barrier((CELL)object);
-
-		/* Allows initialization code to store old->new pointers
-		without hitting the write barrier in the common case of
-		a nursery allocation */
-		write_barrier((CELL)object);
-	}
-
-	*object = tag_header(type);
-	return object;
-}
-
-void copy_reachable_objects(CELL scan, CELL *end);
-
-void primitive_gc(void);
-void primitive_gc_stats(void);
-void clear_gc_stats(void);
-void primitive_clear_gc_stats(void);
-void primitive_become(void);
-
-INLINE void check_data_pointer(CELL pointer)
-{
-#ifdef FACTOR_DEBUG
-	if(!growing_data_heap)
-	{
-		assert(pointer >= data_heap->segment->start
-		       && pointer < data_heap->segment->end);
-	}
-#endif
-}

vm/data_gc.hpp

@@ -28,9 +28,6 @@ INLINE bool collecting_accumulation_gen_p(void)
 
 extern CELL last_code_heap_scan;
 
-/* test if the pointer is in generation being collected, or a younger one. */
-bool should_copy_p(CELL untagged);
-
 void copy_handle(CELL *handle);
 
 void garbage_collection(volatile CELL gen,

vm/data_heap.cpp

@@ -224,7 +224,7 @@ CELL unaligned_object_size(CELL pointer)
 	case STRING_TYPE:
 		return string_size(string_capacity((F_STRING*)pointer));
 	case TUPLE_TYPE:
-		tuple = untag<F_TUPLE>(pointer);
+		tuple = (F_TUPLE *)pointer;
 		layout = untag<F_TUPLE_LAYOUT>(tuple->layout);
 		return tuple_size(layout);
 	case QUOTATION_TYPE:
@@ -284,7 +284,7 @@ CELL binary_payload_start(CELL pointer)
 	case ARRAY_TYPE:
 		return array_size<F_ARRAY>(array_capacity((F_ARRAY*)pointer));
 	case TUPLE_TYPE:
-		tuple = untag<F_TUPLE>(pointer);
+		tuple = (F_TUPLE *)pointer;
 		layout = untag<F_TUPLE_LAYOUT>(tuple->layout);
 		return tuple_size(layout);
 	case WRAPPER_TYPE:

vm/errors.cpp

@@ -113,7 +113,6 @@ void memory_protection_error(CELL addr, F_STACK_FRAME *native_stack)
 		general_error(ERROR_RS_OVERFLOW,F,F,native_stack);
 	else if(in_page(addr, nursery.end, 0, 0))
 		critical_error("allot_object() missed GC check",0);
-	else if(in_page(addr, gc_locals_region->start, 0, -1))
 	else
 		general_error(ERROR_MEMORY,allot_cell(addr),F,native_stack);
 }

vm/local_roots.cpp

@@ -3,5 +3,5 @@
 F_SEGMENT *gc_locals_region;
 CELL gc_locals;
 
-F_SEGMENT *extra_roots_region;
+F_SEGMENT *gc_bignums_region;
-CELL extra_roots;
+CELL gc_bignums;

vm/local_roots.hpp

@@ -20,12 +20,18 @@ struct gc_root : public tagged<T>
 	~gc_root() { CELL old = gc_local_pop(); assert(old == (CELL)this); }
 };
 
-/* Extra roots: stores pointers to objects in the heap. Requires extra work
+/* A similar hack for the bignum implementation */
-(you have to unregister before accessing the object) but more flexible. */
+extern F_SEGMENT *gc_bignums_region;
-extern F_SEGMENT *extra_roots_region;
+extern CELL gc_bignums;
-extern CELL extra_roots;
 
-DEFPUSHPOP(root_,extra_roots)
+DEFPUSHPOP(gc_bignum_,gc_bignums)
 
-#define REGISTER_BIGNUM(obj) if(obj) root_push(tag_bignum(obj))
+struct gc_bignum
-#define UNREGISTER_BIGNUM(obj) if(obj) obj = (untag_bignum_fast(root_pop()))
+{
+	F_BIGNUM **addr;
+
+	gc_bignum(F_BIGNUM **addr_) : addr(addr_) { if(*addr_) check_data_pointer((CELL)*addr_); gc_bignum_push((CELL)addr); }
+	~gc_bignum() { assert((CELL)addr == gc_bignum_pop()); }
+};
+
+#define GC_BIGNUM(x) gc_bignum x##__gc_root(&x)

vm/math.cpp

@@ -51,9 +51,9 @@ F_FASTCALL void overflow_fixnum_subtract(F_FIXNUM x, F_FIXNUM y)
 F_FASTCALL void overflow_fixnum_multiply(F_FIXNUM x, F_FIXNUM y)
 {
 	F_BIGNUM *bx = fixnum_to_bignum(x);
-	REGISTER_BIGNUM(bx);
+	GC_BIGNUM(bx);
 	F_BIGNUM *by = fixnum_to_bignum(y);
-	UNREGISTER_BIGNUM(bx);
+	GC_BIGNUM(by);
 	drepl(tag<F_BIGNUM>(bignum_multiply(bx,by)));
 }