New identity-hashcode primitive

basis/bootstrap/image/image.factor

@@ -71,6 +71,9 @@ C: <eq-wrapper> eq-wrapper
 M: eq-wrapper equal?
     over eq-wrapper? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ;
 
+M: eq-wrapper hashcode*
+    nip obj>> identity-hashcode ;
+
 SYMBOL: objects
 
 : cache-eql-object ( obj quot -- value )
@@ -224,9 +227,11 @@ USERENV: undefined-quot 60
 
 : emit-fixnum ( n -- ) tag-fixnum emit ;
 
+: emit-header ( n -- ) tag-header emit ;
+
 : emit-object ( class quot -- addr )
     [ type-number ] dip over here-as
-    [ swap tag-fixnum emit call align-here ] dip ;
+    [ swap emit-header call align-here ] dip ;
     inline
 
 ! Write an object to the image.
@@ -234,7 +239,7 @@ GENERIC: ' ( obj -- ptr )
 
 ! Image header
 
-: emit-header ( -- )
+: emit-image-header ( -- )
     image-magic emit
     image-version emit
     data-base emit ! relocation base at end of header
@@ -518,7 +523,7 @@ M: quotation '
 : build-image ( -- image )
     800000 <vector> image set
     20000 <hashtable> objects set
-    emit-header t, 0, 1, -1,
+    emit-image-header t, 0, 1, -1,
     "Building generic words..." print flush
     remake-generics
     "Serializing words..." print flush

basis/compiler/cfg/cfg.factor

@@ -4,20 +4,16 @@ USING: kernel math vectors arrays accessors namespaces ;
 IN: compiler.cfg
 
 TUPLE: basic-block < identity-tuple
-{ id integer }
 number
 { instructions vector }
 { successors vector }
 { predecessors vector } ;
 
-M: basic-block hashcode* nip id>> ;
-
 : <basic-block> ( -- bb )
     basic-block new
         V{ } clone >>instructions
         V{ } clone >>successors
-        V{ } clone >>predecessors
-        \ basic-block counter >>id ;
+        V{ } clone >>predecessors ;
 
 TUPLE: cfg { entry basic-block } word label
 spill-area-size reps

basis/compiler/cfg/value-numbering/expressions/expressions.factor

@@ -27,6 +27,9 @@ C: <reference> reference-expr
 M: reference-expr equal?
     over reference-expr? [ [ value>> ] bi@ eq? ] [ 2drop f ] if ;
 
+M: reference-expr hashcode*
+    nip value>> identity-hashcode ;
+
 : constant>vn ( constant -- vn ) <constant> expr>vn ; inline
 
 GENERIC: >expr ( insn -- expr )

basis/compiler/tree/tree.factor

@@ -10,8 +10,6 @@ IN: compiler.tree
 
 TUPLE: node < identity-tuple ;
 
-M: node hashcode* drop node hashcode* ;
-
 TUPLE: #introduce < node out-d ;
 
 : #introduce ( out-d -- node )

basis/cpu/ppc/ppc.factor

@@ -373,7 +373,7 @@ M: ppc %set-alien-double -rot STFD ;
     scratch-reg nursery-ptr 0 STW ;
 
 :: store-header ( dst class -- )
-    class type-number tag-fixnum scratch-reg LI
+    class type-number tag-header scratch-reg LI
     scratch-reg dst 0 STW ;
 
 : store-tagged ( dst tag -- )

basis/cpu/x86/x86.factor

@@ -430,7 +430,7 @@ M: x86 %vm-field-ptr ( dst field -- )
     [ [] ] dip data-alignment get align ADD ;
 
 : store-header ( temp class -- )
-    [ [] ] [ type-number tag-fixnum ] bi* MOV ;
+    [ [] ] [ type-number tag-header ] bi* MOV ;
 
 : store-tagged ( dst tag -- )
     type-number OR ;

basis/io/launcher/launcher.factor

@@ -82,8 +82,6 @@ SYMBOL: wait-flag
     V{ } clone swap processes get set-at
     wait-flag get-global raise-flag ;
 
-M: process hashcode* handle>> hashcode* ;
-
 : pass-environment? ( process -- ? )
     dup environment>> assoc-empty? not
     swap environment-mode>> +replace-environment+ eq? or ;

basis/models/models.factor

@@ -17,8 +17,6 @@ value connections dependencies ref locked? ;
 : <model> ( value -- model )
     model new-model ;
 
-M: model hashcode* drop model hashcode* ;
-
 : add-dependency ( dep model -- )
     dependencies>> push ;
 

basis/serialize/serialize.factor

@@ -26,7 +26,7 @@ TUPLE: id obj ;
 
 C: <id> id
 
-M: id hashcode* obj>> hashcode* ;
+M: id hashcode* nip obj>> identity-hashcode ;
 
 M: id equal? over id? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ;
 

basis/stack-checker/inlining/inlining.factor

@@ -29,8 +29,6 @@ fixed-point
 introductions
 loop? ;
 
-M: inline-recursive hashcode* id>> hashcode* ;
-
 : inlined-block? ( word -- ? ) "inlined-block" word-prop ;
 
 : <inline-recursive> ( word -- label )

basis/stack-checker/known-words/known-words.factor

@@ -712,3 +712,5 @@ M: bad-executable summary
 \ disable-gc-events { } { object } define-primitive
 
 \ profiling { object } { } define-primitive
+
+\ identity-hashcode { object } { fixnum } define-primitive

basis/stack-checker/values/values.factor

@@ -37,14 +37,14 @@ GENERIC: (input-value?) ( value -- ? )
 GENERIC: (literal) ( known -- literal )
 
 ! Literal value
-TUPLE: literal < identity-tuple value recursion hashcode ;
+TUPLE: literal < identity-tuple value recursion ;
 
 : literal ( value -- literal ) known (literal) ;
 
-M: literal hashcode* nip hashcode>> ;
+M: literal hashcode* nip value>> identity-hashcode ;
 
 : <literal> ( obj -- value )
-    recursive-state get over hashcode \ literal boa ;
+    recursive-state get \ literal boa ;
 
 M: literal (input-value?) drop f ;
 
@@ -55,7 +55,7 @@ M: literal (literal) ;
 : curried/composed-literal ( input1 input2 quot -- literal )
     [ [ literal ] bi@ ] dip
     [ [ [ value>> ] bi@ ] dip call ] [ drop nip recursion>> ] 3bi
-    over hashcode \ literal boa ; inline
+    \ literal boa ; inline
 
 ! Result of curry
 TUPLE: curried obj quot ;

core/bootstrap/primitives.factor

@@ -518,6 +518,7 @@ tuple
     { "<callback>" "alien" (( word -- alien )) }
     { "enable-gc-events" "memory" (( -- )) }
     { "disable-gc-events" "memory" (( -- events )) }
+    { "identity-hashcode" "kernel" (( obj -- code )) }
 } [ [ first3 ] dip swap make-primitive ] each-index
 
 ! Bump build number

core/destructors/destructors.factor

@@ -26,15 +26,11 @@ SLOT: continuation
 PRIVATE>
 
 TUPLE: disposable < identity-tuple
-{ id integer }
 { disposed boolean }
 continuation ;
 
-M: disposable hashcode* nip id>> ;
-
 : new-disposable ( class -- disposable )
-    new \ disposable counter >>id
-    dup register-disposable ; inline
+    new dup register-disposable ; inline
 
 GENERIC: dispose* ( disposable -- )
 

core/hashtables/hashtables-docs.factor

@@ -46,7 +46,8 @@ $nl
 $nl
 "In certain advanced applications, this cannot be avoided and the best design involves mutating hashtable keys. In this case, a custom " { $link hashcode* } " method must be defined which only depends on immutable slots."
 $nl
-"In addition, the " { $link equal? } " and " { $link hashcode* } " methods must be congruent, and if one is defined the other should be defined also. This is documented in detail in the documentation for these respective words." ;
+"In addition, the " { $link equal? } " and " { $link hashcode* } " methods must be congruent, and if one is defined the other should be defined also. This is documented in detail in the documentation for these respective words."
+{ $subsections hashcode hashcode* identity-hashcode } ;
 
 ARTICLE: "hashtables.utilities" "Hashtable utilities"
 "Utility words to create a new hashtable from a single key/value pair:"

core/kernel/kernel-docs.factor

@@ -72,7 +72,11 @@ HELP: hashcode
 { $values { "obj" object } { "code" fixnum } }
 { $description "Computes the hashcode of an object with a default hashing depth. See " { $link hashcode* } " for the hashcode contract." } ;
 
-{ hashcode hashcode* } related-words
+HELP: identity-hashcode
+{ $values { "obj" object } { "code" fixnum } }
+{ $description "Outputs the identity hashcode of an object. The identity hashcode is not guaranteed to be unique, however it will not change during the object's lifetime." } ;
+
+{ hashcode hashcode* identity-hashcode } related-words
 
 HELP: =
 { $values { "obj1" object } { "obj2" object } { "?" "a boolean" } }

core/kernel/kernel-tests.factor

@@ -169,3 +169,7 @@ IN: kernel.tests
 [ 3 -1 5/6 ] [ 1 2 3 4 5 6 [ + ] [ - ] [ / ] 2tri* ] unit-test
 
 [ { 1 2 } { 3 4 } { 5 6 } ] [ 1 2 3 4 5 6 [ 2array ] 2tri@ ] unit-test
+
+[ t ] [ { } identity-hashcode fixnum? ] unit-test
+[ 123 ] [ 123 identity-hashcode ] unit-test
+[ t ] [ f identity-hashcode fixnum? ] unit-test

core/kernel/kernel.factor

@@ -200,6 +200,8 @@ TUPLE: identity-tuple ;
 
 M: identity-tuple equal? 2drop f ; inline
 
+M: identity-tuple hashcode* nip identity-hashcode ; inline
+
 : = ( obj1 obj2 -- ? )
     2dup eq? [ 2drop t ] [
         2dup both-fixnums? [ 2drop f ] [ equal? ] if

core/layouts/layouts.factor

@@ -22,6 +22,9 @@ SYMBOL: mega-cache-size
 : tag-fixnum ( n -- tagged )
     tag-bits get shift ;
 
+: tag-header ( n -- tagged )
+    2 shift ;
+
 : untag-fixnum ( n -- tagged )
     tag-bits get neg shift ;
 

vm/allot.hpp

@@ -5,7 +5,7 @@ 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)
+inline object *factor_vm::allot_object(cell type, cell size)
 {
 	/* If the object is smaller than the nursery, allocate it in the nursery,
 	after a GC if needed */
@@ -17,13 +17,13 @@ inline object *factor_vm::allot_object(header header, cell size)
 
 		object *obj = nursery.allot(size);
 
-		obj->h = header;
+		obj->initialize(type);
 		return obj;
 	}
 	/* If the object is bigger than the nursery, allocate it in
 	tenured space */
 	else
-		return allot_large_object(header,size);
+		return allot_large_object(type,size);
 }
 
 }

vm/code_block_visitor.hpp

@@ -42,7 +42,7 @@ template<typename Visitor> struct code_block_visitor {
 
 	void visit_object_code_block(object *obj)
 	{
-		switch(obj->h.hi_tag())
+		switch(obj->type())
 		{
 		case WORD_TYPE:
 			{

vm/collector.hpp

@@ -16,11 +16,10 @@ template<typename TargetGeneration, typename Policy> struct collector_workhorse
 		parent->check_data_pointer(untagged);
 
 		/* is there another forwarding pointer? */
-		while(untagged->h.forwarding_pointer_p())
-			untagged = untagged->h.forwarding_pointer();
+		while(untagged->forwarding_pointer_p())
+			untagged = untagged->forwarding_pointer();
 
 		/* we've found the destination */
-		untagged->h.check_header();
 		return untagged;
 	}
 
@@ -32,7 +31,7 @@ template<typename TargetGeneration, typename Policy> struct collector_workhorse
 		if(!newpointer) longjmp(parent->current_gc->gc_unwind,1);
 
 		memcpy(newpointer,untagged,size);
-		untagged->h.forward_to(newpointer);
+		untagged->forward_to(newpointer);
 
 		policy.promoted_object(newpointer);
 
@@ -114,7 +113,7 @@ template<typename TargetGeneration, typename Policy> struct collector {
 	void trace_object(object *ptr)
 	{
 		workhorse.visit_slots(ptr);
-		if(ptr->h.hi_tag() == ALIEN_TYPE)
+		if(ptr->type() == ALIEN_TYPE)
 			((alien *)ptr)->update_address();
 	}
 

vm/compaction.cpp

@@ -45,7 +45,7 @@ struct compaction_sizer {
 	{
 		if(!forwarding_map->marked_p(obj))
 			return forwarding_map->unmarked_block_size(obj);
-		else if(obj->h.hi_tag() == TUPLE_TYPE)
+		else if(obj->type() == TUPLE_TYPE)
 			return align(tuple_size_with_forwarding(forwarding_map,obj),data_alignment);
 		else
 			return obj->size();
@@ -72,7 +72,7 @@ struct object_compaction_updater {
 	void operator()(object *old_address, object *new_address, cell size)
 	{
 		cell payload_start;
-		if(old_address->h.hi_tag() == TUPLE_TYPE)
+		if(old_address->type() == TUPLE_TYPE)
 			payload_start = tuple_size_with_forwarding(data_forwarding_map,old_address);
 		else
 			payload_start = old_address->binary_payload_start();

vm/data_heap.cpp

@@ -126,7 +126,7 @@ cell object::size() const
 {
 	if(free_p()) return ((free_heap_block *)this)->size();
 
-	switch(h.hi_tag())
+	switch(type())
 	{
 	case ARRAY_TYPE:
 		return align(array_size((array*)this),data_alignment);
@@ -166,7 +166,7 @@ the GC. Some types have a binary payload at the end (string, word, DLL) which
 we ignore. */
 cell object::binary_payload_start() const
 {
-	switch(h.hi_tag())
+	switch(type())
 	{
 	/* these objects do not refer to other objects at all */
 	case FLOAT_TYPE:
@@ -234,7 +234,7 @@ struct object_accumulator {
 
 	void operator()(object *obj)
 	{
-		if(type == TYPE_COUNT || obj->h.hi_tag() == type)
+		if(type == TYPE_COUNT || obj->type() == type)
 			objects.push_back(tag_dynamic(obj));
 	}
 };

vm/debug.cpp

@@ -243,7 +243,7 @@ struct object_dumper {
 
 	void operator()(object *obj)
 	{
-		if(type == TYPE_COUNT || obj->h.hi_tag() == type)
+		if(type == TYPE_COUNT || obj->type() == type)
 		{
 			std::cout << padded_address((cell)obj) << " ";
 			parent->print_nested_obj(tag_dynamic(obj),2);

vm/gc.cpp

@@ -234,7 +234,7 @@ VM_C_API void inline_gc(cell *data_roots_base, cell data_roots_size, factor_vm *
  * It is up to the caller to fill in the object's fields in a meaningful
  * fashion!
  */
-object *factor_vm::allot_large_object(header header, cell size)
+object *factor_vm::allot_large_object(cell type, cell size)
 {
 	/* If tenured space does not have enough room, collect and compact */
 	if(!data->tenured->can_allot_p(size))
@@ -257,7 +257,7 @@ object *factor_vm::allot_large_object(header header, cell size)
 	a nursery allocation */
 	write_barrier(obj,size);
 
-	obj->h = header;
+	obj->initialize(type);
 	return obj;
 }
 

vm/image.cpp

@@ -135,12 +135,12 @@ void factor_vm::relocate_object(object *object,
 	cell data_relocation_base,
 	cell code_relocation_base)
 {
-	cell hi_tag = object->h.hi_tag();
+	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
 	out of the question */
-	if(hi_tag == TUPLE_TYPE)
+	if(type == TUPLE_TYPE)
 	{
 		tuple *t = (tuple *)object;
 		data_fixup(&t->layout,data_relocation_base);
@@ -156,7 +156,7 @@ void factor_vm::relocate_object(object *object,
 		object_fixupper fixupper(this,data_relocation_base);
 		do_slots(object,fixupper);
 
-		switch(hi_tag)
+		switch(type)
 		{
 		case WORD_TYPE:
 			fixup_word((word *)object,code_relocation_base);

vm/layouts.hpp

@@ -51,8 +51,6 @@ static const cell data_alignment = 16;
 
 #define TYPE_COUNT 14
 
-#define FORWARDING_POINTER 5 /* can be anything other than FIXNUM_TYPE */
-
 enum code_block_type
 {
 	code_block_unoptimized,
@@ -95,59 +93,57 @@ inline static cell tag_fixnum(fixnum untagged)
 
 struct object;
 
-struct header {
-	cell value;
-
-        /* Default ctor to make gcc 3.x happy */
-        explicit header() { abort(); }
-
-	explicit header(cell value_) : value(value_ << TAG_BITS) {}
-
-	void check_header() const
-	{
-#ifdef FACTOR_DEBUG
-		assert(TAG(value) == FIXNUM_TYPE && untag_fixnum(value) < TYPE_COUNT);
-#endif
-	}
-
-	cell hi_tag() const
-	{
-		check_header();
-		return value >> TAG_BITS;
-	}
-
-	bool forwarding_pointer_p() const
-	{
-		return TAG(value) == FORWARDING_POINTER;
-	}
-
-	object *forwarding_pointer() const
-	{
-		return (object *)UNTAG(value);
-	}
-
-	void forward_to(object *pointer)
-	{
-		value = RETAG(pointer,FORWARDING_POINTER);
-	}
-};
-
 #define NO_TYPE_CHECK static const cell type_number = TYPE_COUNT
 
 struct object {
 	NO_TYPE_CHECK;
-	header h;
+	cell header;
 
 	cell size() const;
 	cell binary_payload_start() const;
 
 	cell *slots()  const { return (cell *)this; }
 
-	/* Only valid for objects in tenured space; must fast to free_heap_block
+	/* Only valid for objects in tenured space; must cast to free_heap_block
 	to do anything with it if its free */
 	bool free_p() const
 	{
-		return (h.value & 1) == 1;
+		return (header & 1) == 1;
+	}
+
+	cell type() const
+	{
+		return (header >> 2) & TAG_MASK;
+	}
+
+	void initialize(cell type)
+	{
+		header = type << 2;
+	}
+
+	cell hashcode() const
+	{
+		return (header >> 6);
+	}
+
+	void set_hashcode(cell hashcode)
+	{
+		header = (header & 0x3f) | (hashcode << 6);
+	}
+
+	bool forwarding_pointer_p() const
+	{
+		return (header & 2) == 2;
+	}
+
+	object *forwarding_pointer() const
+	{
+		return (object *)UNTAG(header);
+	}
+
+	void forward_to(object *pointer)
+	{
+		header = ((cell)pointer | 2);
 	}
 };
 

vm/objects.cpp

@@ -16,6 +16,23 @@ void factor_vm::primitive_set_special_object()
 	special_objects[e] = value;
 }
 
+void factor_vm::primitive_identity_hashcode()
+{
+	cell tagged = dpeek();
+	if(immediate_p(tagged))
+		drepl(tagged & ~TAG_MASK);
+	else
+	{
+		object *obj = untag<object>(tagged);
+		if(obj->hashcode() == 0)
+		{
+			/* Use megamorphic_cache_misses as a random source of randomness */
+			obj->set_hashcode(((cell)obj / block_granularity) ^ dispatch_stats.megamorphic_cache_hits);
+		}
+		drepl(tag_fixnum(obj->hashcode()));
+	}
+}
+
 void factor_vm::primitive_set_slot()
 {
 	fixnum slot = untag_fixnum(dpop());
@@ -36,8 +53,9 @@ cell factor_vm::clone_object(cell obj_)
 	else
 	{
 		cell size = object_size(obj.value());
-		object *new_obj = allot_object(header(obj.type()),size);
+		object *new_obj = allot_object(obj.type(),size);
 		memcpy(new_obj,obj.untagged(),size);
+		new_obj->set_hashcode(0);
 		return tag_dynamic(new_obj);
 	}
 }

vm/primitives.cpp

@@ -126,6 +126,7 @@ PRIMITIVE_FORWARD(strip_stack_traces)
 PRIMITIVE_FORWARD(callback)
 PRIMITIVE_FORWARD(enable_gc_events)
 PRIMITIVE_FORWARD(disable_gc_events)
+PRIMITIVE_FORWARD(identity_hashcode)
 
 const primitive_type primitives[] = {
 	primitive_bignum_to_fixnum,
@@ -288,6 +289,7 @@ const primitive_type primitives[] = {
 	primitive_callback,
 	primitive_enable_gc_events,
 	primitive_disable_gc_events,
+	primitive_identity_hashcode,
 };
 
 }

vm/tagged.hpp

@@ -8,7 +8,7 @@ template<typename Type> cell tag(Type *value)
 
 inline static cell tag_dynamic(object *value)
 {
-	return RETAG(value,value->h.hi_tag());
+	return RETAG(value,value->type());
 }
 
 template<typename Type>

vm/vm.hpp

@@ -121,6 +121,7 @@ struct factor_vm
 	// objects
 	void primitive_special_object();
 	void primitive_set_special_object();
+	void primitive_identity_hashcode();
 	cell object_size(cell tagged);
 	cell clone_object(cell obj_);
 	void primitive_clone();
@@ -284,12 +285,12 @@ struct factor_vm
 	void inline_gc(cell *data_roots_base, cell data_roots_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);
+	object *allot_object(cell type, cell size);
+	object *allot_large_object(cell type, cell size);
 
 	template<typename Type> Type *allot(cell size)
 	{
-		return (Type *)allot_object(header(Type::type_number),size);
+		return (Type *)allot_object(Type::type_number,size);
 	}
 
 	inline void check_data_pointer(object *pointer)