Merge branch 'master' of git://factorcode.org/git/factor

Makefile

@@ -44,6 +44,7 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
 	vm/compaction.o \
 	vm/contexts.o \
 	vm/data_heap.o \
+	vm/data_heap_checker.o \
 	vm/debug.o \
 	vm/dispatch.o \
 	vm/errors.o \

basis/cpu/ppc/ppc.factor

@@ -256,35 +256,22 @@ M: ppc %double>single-float FRSP ;
 M: ppc %unbox-alien ( dst src -- )
     alien-offset LWZ ;
 
-M:: ppc %unbox-any-c-ptr ( dst src temp -- )
+M:: ppc %unbox-any-c-ptr ( dst src -- )
     [
-        { "is-byte-array" "end" "start" } [ define-label ] each
+        "end" define-label
-        ! Address is computed in dst
         0 dst LI
-        ! Load object into scratch-reg
-        scratch-reg src MR
-        ! We come back here with displaced aliens
-        "start" resolve-label
         ! Is the object f?
-        0 scratch-reg \ f type-number CMPI
+        0 src \ f type-number CMPI
-        ! If so, done
         "end" get BEQ
+        ! Compute tag in dst register
+        dst src tag-mask get ANDI
         ! Is the object an alien?
-        0 scratch-reg header-offset LWZ
+        0 dst alien type-number CMPI
-        0 0 alien type-number tag-fixnum CMPI
+        ! Add an offset to start of byte array's data
-        "is-byte-array" get BNE
+        dst src byte-array-offset ADDI
-        ! If so, load the offset
+        "end" get BNE
-        0 scratch-reg alien-offset LWZ
+        ! If so, load the offset and add it to the address
-        ! Add it to address being computed
+        dst src alien-offset LWZ
-        dst dst 0 ADD
-        ! Now recurse on the underlying alien
-        scratch-reg scratch-reg underlying-alien-offset LWZ
-        "start" get B
-        "is-byte-array" resolve-label
-        ! Add byte array address to address being computed
-        dst dst scratch-reg ADD
-        ! Add an offset to start of byte array's data area
-        dst dst byte-array-offset ADDI
         "end" resolve-label
     ] with-scope ;
 
@@ -293,53 +280,84 @@ M:: ppc %unbox-any-c-ptr ( dst src temp -- )
 M:: ppc %box-alien ( dst src temp -- )
     [
         "f" define-label
-        dst  %load-immediate
+        dst \ f type-number %load-immediate
         0 src 0 CMPI
         "f" get BEQ
         dst 5 cells alien temp %allot
         temp \ f type-number %load-immediate
         temp dst 1 alien@ STW
         temp dst 2 alien@ STW
-        displacement dst 3 alien@ STW
+        src dst 3 alien@ STW
-        displacement dst 4 alien@ STW
+        src dst 4 alien@ STW
         "f" resolve-label
     ] with-scope ;
 
-M:: ppc %box-displaced-alien ( dst displacement base displacement' base' base-class -- )
+M:: ppc %box-displaced-alien ( dst displacement base temp base-class -- )
+    ! This is ridiculous
     [
         "end" define-label
-        "alloc" define-label
+        "not-f" define-label
-        "simple-case" define-label
+        "not-alien" define-label
+
         ! If displacement is zero, return the base
         dst base MR
         0 displacement 0 CMPI
         "end" get BEQ
-        ! Quickly use displacement' before its needed for real, as allot temporary
+
-        displacement' :> temp
+        ! Displacement is non-zero, we're going to be allocating a new
-        dst 4 cells alien temp %allot
+        ! object
-        ! If base is already a displaced alien, unpack it
+        dst 5 cells alien temp %allot
-        0 base \ f type-number CMPI
+
-        "simple-case" get BEQ
+        ! Set expired to f
-        temp base header-offset LWZ
-        0 temp alien type-number tag-fixnum CMPI
-        "simple-case" get BNE
-        ! displacement += base.displacement
-        temp base 3 alien@ LWZ
-        displacement' displacement temp ADD
-        ! base = base.base
-        base' base 1 alien@ LWZ
-        "alloc" get B
-        "simple-case" resolve-label
-        displacement' displacement MR
-        base' base MR
-        "alloc" resolve-label
-        ! Store underlying-alien slot
-        base' dst 1 alien@ STW
-        ! Store offset
-        displacement' dst 3 alien@ STW
-        ! Store expired slot (its ok to clobber displacement')
         temp \ f type-number %load-immediate
         temp dst 2 alien@ STW
+
+        ! Is base f?
+        0 base \ f type-number CMPI
+        "not-f" get BNE
+
+        ! Yes, it is f. Fill in new object
+        base dst 1 alien@ STW
+        displacement dst 3 alien@ STW
+        displacement dst 4 alien@ STW
+
+        "end" get B
+
+        "not-f" resolve-label
+
+        ! Check base type
+        temp base tag-mask get ANDI
+
+        ! Is base an alien?
+        0 temp alien type-number CMPI
+        "not-alien" get BNE
+
+        ! Yes, it is an alien. Set new alien's base to base.base
+        temp base 1 alien@ LWZ
+        temp dst 1 alien@ STW
+
+        ! Compute displacement
+        temp base 3 alien@ LWZ
+        temp temp displacement ADD
+        temp dst 3 alien@ STW
+
+        ! Compute address
+        temp base 4 alien@ LWZ
+        temp temp displacement ADD
+        temp dst 4 alien@ STW
+
+        ! We are done
+        "end" get B
+
+        ! Is base a byte array? It has to be, by now...
+        "not-alien" resolve-label
+
+        base dst 1 alien@ STW
+        displacement dst 3 alien@ STW
+        temp base byte-array-offset ADDI
+        temp temp displacement ADD
+        temp dst 4 alien@ STW
+
         "end" resolve-label
     ] with-scope ;
 

basis/tools/memory/memory.factor

@@ -4,8 +4,7 @@ USING: accessors arrays assocs classes classes.struct
 combinators combinators.smart continuations fry generalizations
 generic grouping io io.styles kernel make math math.parser
 math.statistics memory namespaces parser prettyprint sequences
-sorting specialized-arrays splitting strings system vm words ;
+sorting splitting strings system vm words ;
-SPECIALIZED-ARRAY: gc-event
 IN: tools.memory
 
 <PRIVATE
@@ -101,7 +100,7 @@ SYMBOL: gc-events
 : collect-gc-events ( quot -- )
     enable-gc-events
     [ ] [ disable-gc-events drop ] cleanup
-    disable-gc-events byte-array>gc-event-array gc-events set ; inline
+    disable-gc-events [ gc-event memory>struct ] map gc-events set ; inline
 
 <PRIVATE
 

vm/arrays.cpp

@@ -3,7 +3,6 @@
 namespace factor
 {
 
-/* make a new array with an initial element */
 array *factor_vm::allot_array(cell capacity, cell fill_)
 {
 	data_root<object> fill(fill_,this);
@@ -12,12 +11,13 @@ array *factor_vm::allot_array(cell capacity, cell fill_)
 	return new_array;
 }
 
-/* push a new array on the stack */
 void factor_vm::primitive_array()
 {
-	cell initial = dpop();
+	data_root<object> fill(dpop(),this);
-	cell size = unbox_array_size();
+	cell capacity = unbox_array_size();
-	dpush(tag<array>(allot_array(size,initial)));
+	array *new_array = allot_uninitialized_array<array>(capacity);
+	memset_cell(new_array->data(),fill.value(),capacity * sizeof(cell));
+	dpush(tag<array>(new_array));
 }
 
 cell factor_vm::allot_array_1(cell obj_)
@@ -54,9 +54,10 @@ cell factor_vm::allot_array_4(cell v1_, cell v2_, cell v3_, cell v4_)
 
 void factor_vm::primitive_resize_array()
 {
-	array *a = untag_check<array>(dpop());
+	data_root<array> a(dpop(),this);
+	a.untag_check(this);
 	cell capacity = unbox_array_size();
-	dpush(tag<array>(reallot_array(a,capacity)));
+	dpush(tag<array>(reallot_array(a.untagged(),capacity)));
 }
 
 void growable_array::add(cell elt_)

vm/byte_arrays.cpp

@@ -24,9 +24,10 @@ void factor_vm::primitive_uninitialized_byte_array()
 
 void factor_vm::primitive_resize_byte_array()
 {
-	byte_array *array = untag_check<byte_array>(dpop());
+	data_root<byte_array> array(dpop(),this);
+	array.untag_check(this);
 	cell capacity = unbox_array_size();
-	dpush(tag<byte_array>(reallot_array(array,capacity)));
+	dpush(tag<byte_array>(reallot_array(array.untagged(),capacity)));
 }
 
 void growable_byte_array::append_bytes(void *elts, cell len)

vm/byte_arrays.hpp

@@ -15,14 +15,8 @@ struct growable_byte_array {
 
 template<typename Type> byte_array *factor_vm::byte_array_from_value(Type *value)
 {
-	return byte_array_from_values(value,1);
+	byte_array *data = allot_uninitialized_array<byte_array>(sizeof(Type));
-}
+	memcpy(data->data<char>(),value,sizeof(Type));
-
-template<typename Type> byte_array *factor_vm::byte_array_from_values(Type *values, cell len)
-{
-	cell size = sizeof(Type) * len;
-	byte_array *data = allot_uninitialized_array<byte_array>(size);
-	memcpy(data->data<char>(),values,size);
 	return data;
 }
 

vm/data_heap_checker.cpp

@@ -0,0 +1,101 @@
+#include "master.hpp"
+
+/* A tool to debug write barriers. Call check_data_heap() to ensure that all
+cards that should be marked are actually marked. */
+
+namespace factor
+{
+
+enum generation {
+	nursery_generation,
+	aging_generation,
+	tenured_generation
+};
+
+inline generation generation_of(factor_vm *parent, object *obj)
+{
+	if(parent->data->nursery->contains_p(obj))
+		return nursery_generation;
+	else if(parent->data->aging->contains_p(obj))
+		return aging_generation;
+	else if(parent->data->tenured->contains_p(obj))
+		return tenured_generation;
+	else
+	{
+		critical_error("Bad object",(cell)obj);
+		return (generation)-1;
+	}
+}
+
+struct slot_checker {
+	factor_vm *parent;
+	object *obj;
+	generation gen;
+
+	explicit slot_checker(factor_vm *parent_, object *obj_, generation gen_) :
+		parent(parent_), obj(obj_), gen(gen_) {}
+
+	void check_write_barrier(cell *slot_ptr, generation target, char mask)
+	{
+		cell object_card_pointer = parent->cards_offset + ((cell)obj >> card_bits);
+		cell slot_card_pointer = parent->cards_offset + ((cell)slot_ptr >> card_bits);
+		char slot_card_value = *(char *)slot_card_pointer;
+		if((slot_card_value & mask) != mask)
+		{
+			printf("card not marked\n");
+			printf("source generation: %d\n",gen);
+			printf("target generation: %d\n",target);
+			printf("object: 0x%lx\n",(cell)obj);
+			printf("object type: %ld\n",obj->type());
+			printf("slot pointer: 0x%lx\n",(cell)slot_ptr);
+			printf("slot value: 0x%lx\n",*slot_ptr);
+			printf("card of object: 0x%lx\n",object_card_pointer);
+			printf("card of slot: 0x%lx\n",slot_card_pointer);
+			printf("\n");
+			parent->factorbug();
+		}
+	}
+
+	void operator()(cell *slot_ptr)
+	{
+		if(!immediate_p(*slot_ptr))
+		{
+			generation target = generation_of(parent,untag<object>(*slot_ptr));
+			switch(gen)
+			{
+			case nursery_generation:
+				break;
+			case aging_generation:
+				if(target == nursery_generation)
+					check_write_barrier(slot_ptr,target,card_points_to_nursery);
+				break;
+			case tenured_generation:
+				if(target == nursery_generation)
+					check_write_barrier(slot_ptr,target,card_points_to_nursery);
+				else if(target == aging_generation)
+					check_write_barrier(slot_ptr,target,card_points_to_aging);
+				break;
+			}
+		}
+	}
+};
+
+struct object_checker {
+	factor_vm *parent;
+
+	explicit object_checker(factor_vm *parent_) : parent(parent_) {}
+
+	void operator()(object *obj)
+	{
+		slot_checker checker(parent,obj,generation_of(parent,obj));
+		obj->each_slot(checker);
+	}
+};
+
+void factor_vm::check_data_heap()
+{
+	object_checker checker(this);
+	each_object(checker);
+}
+
+}

vm/debug.cpp

@@ -288,7 +288,7 @@ struct data_reference_object_visitor {
 	void operator()(object *obj)
 	{
 		data_reference_slot_visitor visitor(look_for,obj,parent);
-		parent->do_slots(obj,visitor);
+		obj->each_slot(visitor);
 	}
 };
 

vm/gc.cpp

@@ -270,11 +270,25 @@ void factor_vm::primitive_disable_gc_events()
 {
 	if(gc_events)
 	{
-		byte_array *data = byte_array_from_values(&gc_events->front(),gc_events->size());
+		growable_array result(this);
-		dpush(tag<byte_array>(data));
 
-		delete gc_events;
+		std::vector<gc_event> *gc_events = this->gc_events;
-		gc_events = NULL;
+		this->gc_events = NULL;
+
+		std::vector<gc_event>::const_iterator iter = gc_events->begin();
+		std::vector<gc_event>::const_iterator end = gc_events->end();
+
+		for(; iter != end; iter++)
+		{
+			gc_event event = *iter;
+			byte_array *obj = byte_array_from_value(&event);
+			result.add(tag<byte_array>(obj));
+		}
+
+		result.trim();
+		dpush(result.elements.value());
+
+		delete this->gc_events;
 	}
 	else
 		dpush(false_object);

vm/image.cpp

@@ -138,7 +138,7 @@ void factor_vm::relocate_object(object *object,
 	cell type = object->type();
 	
 	/* Tuple relocation is a bit trickier; we have to fix up the
-	layout object before we can get the tuple size, so do_slots is
+	layout object before we can get the tuple size, so each_slot is
 	out of the question */
 	if(type == TUPLE_TYPE)
 	{
@@ -154,7 +154,7 @@ void factor_vm::relocate_object(object *object,
 	else
 	{
 		object_fixupper fixupper(this,data_relocation_base);
-		do_slots(object,fixupper);
+		object->each_slot(fixupper);
 
 		switch(type)
 		{

vm/layouts.hpp

@@ -102,7 +102,9 @@ struct object {
 	cell size() const;
 	cell binary_payload_start() const;
 
-	cell *slots()  const { return (cell *)this; }
+	cell *slots() const { return (cell *)this; }
+
+	template<typename Iterator> void each_slot(Iterator &iter);
 
 	/* Only valid for objects in tenured space; must cast to free_heap_block
 	to do anything with it if its free */

vm/objects.hpp

@@ -98,4 +98,19 @@ inline static bool save_env_p(cell i)
 	return (i >= OBJ_FIRST_SAVE && i <= OBJ_LAST_SAVE);
 }
 
+template<typename Iterator> void object::each_slot(Iterator &iter)
+{
+	cell scan = (cell)this;
+	cell payload_start = binary_payload_start();
+	cell end = scan + payload_start;
+
+	scan += sizeof(cell);
+
+	while(scan < end)
+	{
+		iter((cell *)scan);
+		scan += sizeof(cell);
+	}
+}
+
 }

vm/strings.cpp

@@ -157,9 +157,10 @@ string* factor_vm::reallot_string(string *str_, cell capacity)
 
 void factor_vm::primitive_resize_string()
 {
-	string* str = untag_check<string>(dpop());
+	data_root<string> str(dpop(),this);
+	str.untag_check(this);
 	cell capacity = unbox_array_size();
-	dpush(tag<string>(reallot_string(str,capacity)));
+	dpush(tag<string>(reallot_string(str.untagged(),capacity)));
 }
 
 void factor_vm::primitive_string_nth()

vm/vm.hpp

@@ -262,11 +262,16 @@ struct factor_vm
 
 	inline void write_barrier(object *obj, cell size)
 	{
-		char *start = (char *)obj;
+		cell start = (cell)obj & -card_size;
-		for(cell offset = 0; offset < size; offset += card_size)
+		cell end = ((cell)obj + size + card_size - 1) & -card_size;
-			write_barrier((cell *)(start + offset));
+
+		for(cell offset = start; offset < end; offset += card_size)
+			write_barrier((cell *)offset);
 	}
 
+	// data heap checker
+	void check_data_heap();
+
 	// gc
 	void end_gc();
 	void start_gc_again();
@@ -374,7 +379,6 @@ struct factor_vm
 	void primitive_resize_byte_array();
 
 	template<typename Type> byte_array *byte_array_from_value(Type *value);
-	template<typename Type> byte_array *byte_array_from_values(Type *values, cell len);
 
 	//tuples
 	void primitive_tuple();
@@ -586,24 +590,6 @@ struct factor_vm
 	void save_callstack_bottom(stack_frame *callstack_bottom);
 	template<typename Iterator> void iterate_callstack(context *ctx, Iterator &iterator);
 
-	/* Every object has a regular representation in the runtime, which makes GC
-	much simpler. Every slot of the object until binary_payload_start is a pointer
-	to some other object. */
-	template<typename Iterator> void do_slots(object *obj, Iterator &iter)
-	{
-		cell scan = (cell)obj;
-		cell payload_start = obj->binary_payload_start();
-		cell end = scan + payload_start;
-
-		scan += sizeof(cell);
-
-		while(scan < end)
-		{
-			iter((cell *)scan);
-			scan += sizeof(cell);
-		}
-	}
-
 	//alien
 	char *pinned_alien_offset(cell obj);
 	cell allot_alien(cell delegate_, cell displacement);