Merge optimizations from master branch

core/sequences/sequences.factor

@@ -271,10 +271,10 @@ ERROR: integer-length-expected obj ;
     dup integer? [ integer-length-expected ] unless ; inline
 
 TUPLE: copy-state
-    { src-i integer read-only }
-    { src sequence read-only }
-    { dst-i integer read-only }
-    { dst sequence read-only } ;
+    { src-i read-only }
+    { src read-only }
+    { dst-i read-only }
+    { dst read-only } ;
 
 C: <copy> copy-state
 

vm/allot.hpp

@@ -0,0 +1,29 @@
+namespace factor
+{
+
+/*
+ * It is up to the caller to fill in the object's fields in a meaningful
+ * fashion!
+ */
+inline object *factor_vm::allot_object(header header, cell size)
+{
+	/* If the object is smaller than the nursery, allocate it in the nursery,
+	after a GC if needed */
+	if(nursery.size > size)
+	{
+		/* If there is insufficient room, collect the nursery */
+		if(nursery.here + size > nursery.end)
+			primitive_minor_gc();
+
+		object *obj = nursery.allot(size);
+
+		obj->h = header;
+		return obj;
+	}
+	/* If the object is bigger than the nursery, allocate it in
+	tenured space */
+	else
+		return allot_large_object(header,size);
+}
+
+}

vm/arrays.cpp

@@ -8,17 +8,7 @@ array *factor_vm::allot_array(cell capacity, cell fill_)
 {
 	gc_root<object> fill(fill_,this);
 	gc_root<array> new_array(allot_uninitialized_array<array>(capacity),this);
-
-	if(fill.value() == tag_fixnum(0))
-		memset(new_array->data(),'\0',capacity * sizeof(cell));
-	else
-	{
-		/* No need for write barrier here. Either the object is in
-		the nursery, or it was allocated directly in tenured space
-		and the write barrier is already hit for us in that case. */
-		for(cell i = 0; i < capacity; i++)
-			new_array->data()[i] = fill.value();
-	}
+	memset_cell(new_array->data(),fill.value(),capacity * sizeof(cell));
 	return new_array.untagged();
 }
 

vm/dispatch.cpp

@@ -22,10 +22,10 @@ cell factor_vm::search_lookup_hash(cell table, cell klass, cell hashcode)
 {
 	array *buckets = untag<array>(table);
 	cell bucket = array_nth(buckets,hashcode & (array_capacity(buckets) - 1));
-	if(tagged<object>(bucket).type_p(WORD_TYPE) || !to_boolean(bucket))
-		return bucket;
-	else
+	if(TAG(bucket) == ARRAY_TYPE)
 		return search_lookup_alist(bucket,klass);
+	else
+		return bucket;
 }
 
 cell factor_vm::nth_superclass(tuple_layout *layout, fixnum echelon)
@@ -46,9 +46,7 @@ cell factor_vm::lookup_tuple_method(cell obj, cell methods)
 
 	array *echelons = untag<array>(methods);
 
-	fixnum echelon = untag_fixnum(layout->echelon);
-	fixnum max_echelon = array_capacity(echelons) - 1;
-	if(echelon > max_echelon) echelon = max_echelon;
+	fixnum echelon = std::min(untag_fixnum(layout->echelon),(fixnum)array_capacity(echelons) - 1);
 
 	while(echelon >= 0)
 	{
@@ -82,35 +80,27 @@ cell factor_vm::lookup_hi_tag_method(cell obj, cell methods)
 	return array_nth(hi_tag_methods,tag);
 }
 
-cell factor_vm::lookup_hairy_method(cell obj, cell methods)
-{
-	cell method = array_nth(untag<array>(methods),TAG(obj));
-	if(tagged<object>(method).type_p(WORD_TYPE))
-		return method;
-	else
-	{
-		switch(TAG(obj))
-		{
-		case TUPLE_TYPE:
-			return lookup_tuple_method(obj,method);
-			break;
-		case OBJECT_TYPE:
-			return lookup_hi_tag_method(obj,method);
-			break;
-		default:
-			critical_error("Bad methods array",methods);
-			return 0;
-		}
-	}
-}
-
 cell factor_vm::lookup_method(cell obj, cell methods)
 {
 	cell tag = TAG(obj);
-	if(tag == TUPLE_TYPE || tag == OBJECT_TYPE)
-		return lookup_hairy_method(obj,methods);
+	cell method = array_nth(untag<array>(methods),tag);
+
+	if(tag == TUPLE_TYPE)
+	{
+		if(TAG(method) == ARRAY_TYPE)
+			return lookup_tuple_method(obj,method);
 		else
-		return array_nth(untag<array>(methods),TAG(obj));
+			return method;
+	}
+	else if(tag == OBJECT_TYPE)
+	{
+		if(TAG(method) == ARRAY_TYPE)
+			return lookup_hi_tag_method(obj,method);
+		else
+			return method;
+	}
+	else
+		return method;
 }
 
 void factor_vm::primitive_lookup_method()

vm/gc.cpp

@@ -271,27 +271,8 @@ VM_C_API void inline_gc(cell *gc_roots_base, cell gc_roots_size, factor_vm *pare
  * It is up to the caller to fill in the object's fields in a meaningful
  * fashion!
  */
-object *factor_vm::allot_object(header header, cell size)
+object *factor_vm::allot_large_object(header header, cell size)
 {
-#ifdef GC_DEBUG
-	if(!gc_off)
-		primitive_full_gc();
-#endif
-
-	object *obj;
-
-	/* If the object is smaller than the nursery, allocate it in the nursery,
-	after a GC if needed */
-	if(size < nursery.size)
-	{
-		/* If there is insufficient room, collect the nursery */
-		if(nursery.here + size > nursery.end)
-			primitive_minor_gc();
-
-		obj = nursery.allot(size);
-	}
-	else
-	{
 	/* If tenured space does not have enough room, collect and compact */
 	if(!data->tenured->can_allot_p(size))
 	{
@@ -306,7 +287,7 @@ object *factor_vm::allot_object(header header, cell size)
 		}
 	}
 
-		obj = data->tenured->allot(size);
+	object *obj = data->tenured->allot(size);
 
 	/* Allows initialization code to store old->new pointers
 	without hitting the write barrier in the common case of
@@ -314,7 +295,6 @@ object *factor_vm::allot_object(header header, cell size)
 	char *start = (char *)obj;
 	for(cell offset = 0; offset < size; offset += card_size)
 		write_barrier((cell *)(start + offset));
-	}
 
 	obj->h = header;
 	return obj;

vm/master.hpp

@@ -71,6 +71,7 @@ namespace factor
 #include "alien.hpp"
 #include "callbacks.hpp"
 #include "vm.hpp"
+#include "allot.hpp"
 #include "tagged.hpp"
 #include "local_roots.hpp"
 #include "slot_visitor.hpp"

vm/math.cpp

@@ -231,33 +231,19 @@ void factor_vm::primitive_byte_array_to_bignum()
 	drepl(tag<bignum>(result));
 }
 
-cell factor_vm::unbox_array_size()
+cell factor_vm::unbox_array_size_slow()
 {
-	switch(tagged<object>(dpeek()).type())
+	if(tagged<object>(dpeek()).type() == BIGNUM_TYPE)
 	{
-	case FIXNUM_TYPE:
-		{
-			fixnum n = untag_fixnum(dpeek());
-			if(n >= 0 && n < (fixnum)array_size_max)
-			{
-				dpop();
-				return n;
-			}
-			break;
-		}
-	case BIGNUM_TYPE:
-		{
-			bignum * zero = untag<bignum>(bignum_zero);
-			bignum * max = cell_to_bignum(array_size_max);
-			bignum * n = untag<bignum>(dpeek());
+		bignum *zero = untag<bignum>(bignum_zero);
+		bignum *max = cell_to_bignum(array_size_max);
+		bignum *n = untag<bignum>(dpeek());
 		if(bignum_compare(n,zero) != bignum_comparison_less
 			&& bignum_compare(n,max) == bignum_comparison_less)
 		{
 			dpop();
 			return bignum_to_cell(n);
 		}
-			break;
-		}
 	}
 
 	general_error(ERROR_ARRAY_SIZE,dpop(),tag_fixnum(array_size_max),NULL);

vm/math.hpp

@@ -58,7 +58,21 @@ inline double factor_vm::fixnum_to_float(cell tagged)
 	return (double)untag_fixnum(tagged);
 }
 
-// defined in assembler
+inline cell factor_vm::unbox_array_size()
+{
+	cell obj = dpeek();
+	if(TAG(obj) == FIXNUM_TYPE)
+	{
+		fixnum n = untag_fixnum(obj);
+		if(n >= 0 && n < (fixnum)array_size_max)
+		{
+			dpop();
+			return n;
+		}
+	}
+
+	return unbox_array_size_slow();
+}
 
 VM_C_API void box_float(float flo, factor_vm *vm);
 VM_C_API float to_float(cell value, factor_vm *vm);

vm/tuples.cpp

@@ -3,34 +3,29 @@
 namespace factor
 {
 
-/* push a new tuple on the stack */
-tuple *factor_vm::allot_tuple(cell layout_)
-{
-	gc_root<tuple_layout> layout(layout_,this);
-	gc_root<tuple> t(allot<tuple>(tuple_size(layout.untagged())),this);
-	t->layout = layout.value();
-	return t.untagged();
-}
-
+/* push a new tuple on the stack, filling its slots with f */
 void factor_vm::primitive_tuple()
 {
 	gc_root<tuple_layout> layout(dpop(),this);
-	tuple *t = allot_tuple(layout.value());
-	fixnum i;
-	for(i = tuple_size(layout.untagged()) - 1; i >= 0; i--)
-		t->data()[i] = false_object;
+	tagged<tuple> t(allot<tuple>(tuple_size(layout.untagged())));
+	t->layout = layout.value();
 
-	dpush(tag<tuple>(t));
+	memset_cell(t->data(),false_object,tuple_size(layout.untagged()) - sizeof(cell));
+
+	dpush(t.value());
 }
 
 /* push a new tuple on the stack, filling its slots from the stack */
 void factor_vm::primitive_tuple_boa()
 {
 	gc_root<tuple_layout> layout(dpop(),this);
-	gc_root<tuple> t(allot_tuple(layout.value()),this);
+	tagged<tuple> t(allot<tuple>(tuple_size(layout.untagged())));
+	t->layout = layout.value();
+
 	cell size = untag_fixnum(layout.untagged()->size) * sizeof(cell);
-	memcpy(t->data(),(cell *)(ds - (size - sizeof(cell))),size);
+	memcpy(t->data(),(cell *)(ds - size + sizeof(cell)),size);
 	ds -= size;
+
 	dpush(t.value());
 }
 

vm/utilities.hpp

@@ -1,6 +1,31 @@
 namespace factor
 {
-	vm_char *safe_strdup(const vm_char *str);
-	void print_cell_hex_pad(cell x);
-	cell read_cell_hex();
+
+inline static void memset_cell(void *dst, cell pattern, size_t size)
+{
+#ifdef __APPLE__
+	#ifdef FACTOR_64
+		memset_pattern8(dst,&pattern,size);
+	#else
+		memset_pattern4(dst,&pattern,size);
+	#endif
+#else
+	if(pattern == 0)
+		memset(dst,0,size);
+	else
+	{
+		cell *start = (cell *)dst;
+		cell *end = (cell *)((cell)dst + size);
+		while(start < end)
+		{
+			*start = pattern;
+			start++;
+		}
+	}
+#endif
+}
+
+vm_char *safe_strdup(const vm_char *str);
+cell read_cell_hex();
+
 }

vm/vm.hpp

@@ -257,9 +257,10 @@ struct factor_vm
 	void primitive_compact_gc();
 	void primitive_become();
 	void inline_gc(cell *gc_roots_base, cell gc_roots_size);
-	object *allot_object(header header, cell size);
 	void primitive_enable_gc_events();
 	void primitive_disable_gc_events();
+	object *allot_object(header header, cell size);
+	object *allot_large_object(header header, cell size);
 
 	template<typename Type> Type *allot(cell size)
 	{
@@ -345,7 +346,6 @@ struct factor_vm
 	template<typename T> byte_array *byte_array_from_values(T *values, cell len);
 
 	//tuples
-	tuple *allot_tuple(cell layout_);
 	void primitive_tuple();
 	void primitive_tuple_boa();
 
@@ -392,7 +392,8 @@ struct factor_vm
 	void primitive_bignum_log2();
 	unsigned int bignum_producer(unsigned int digit);
 	void primitive_byte_array_to_bignum();
-	cell unbox_array_size();
+	inline cell unbox_array_size();
+	cell unbox_array_size_slow();
 	void primitive_fixnum_to_float();
 	void primitive_bignum_to_float();
 	void primitive_str_to_float();
@@ -610,7 +611,6 @@ struct factor_vm
 	cell nth_hashcode(tuple_layout *layout, fixnum echelon);
 	cell lookup_tuple_method(cell obj, cell methods);
 	cell lookup_hi_tag_method(cell obj, cell methods);
-	cell lookup_hairy_method(cell obj, cell methods);
 	cell lookup_method(cell obj, cell methods);
 	void primitive_lookup_method();
 	cell object_class(cell obj);