New identity-hashcode primitive

factor · Nov 11, 2009 · 064c00f · 064c00f
1 parent 4162ee2
commit 064c00f
Show file tree

Hide file tree

Showing 32 changed files with 114 additions and 89 deletions.
diff --git a/basis/bootstrap/image/image.factor b/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,17 +227,19 @@ 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.
 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

diff --git a/basis/compiler/cfg/cfg.factor b/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

diff --git a/basis/compiler/cfg/value-numbering/expressions/expressions.factor b/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 )

diff --git a/basis/compiler/tree/tree.factor b/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 )

diff --git a/basis/cpu/ppc/ppc.factor b/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 -- )

diff --git a/basis/cpu/x86/x86.factor b/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 ;

diff --git a/basis/io/launcher/launcher.factor b/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 ;

diff --git a/basis/models/models.factor b/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 ;
 

diff --git a/basis/serialize/serialize.factor b/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 ;
 

diff --git a/basis/stack-checker/inlining/inlining.factor b/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 )

diff --git a/basis/stack-checker/known-words/known-words.factor b/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
diff --git a/basis/stack-checker/values/values.factor b/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 ;

diff --git a/core/bootstrap/primitives.factor b/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

diff --git a/core/destructors/destructors.factor b/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 -- )
 

diff --git a/core/hashtables/hashtables-docs.factor b/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:"

diff --git a/core/kernel/kernel-docs.factor b/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" } }

diff --git a/core/kernel/kernel-tests.factor b/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
diff --git a/core/kernel/kernel.factor b/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

diff --git a/core/layouts/layouts.factor b/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 ;
 

diff --git a/vm/allot.hpp b/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);
 }
 
 }
diff --git a/vm/code_block_visitor.hpp b/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:
 			{

diff --git a/vm/collector.hpp b/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();
 	}
 

diff --git a/vm/compaction.cpp b/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();

diff --git a/vm/data_heap.cpp b/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));
 	}
 };

diff --git a/vm/debug.cpp b/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);

diff --git a/vm/gc.cpp b/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;
 }
Original file line number	Diff line number	Diff line change
Expand Up		@@ -712,3 +712,5 @@ M: bad-executable summary
		\ disable-gc-events { } { object } define-primitive

		\ profiling { object } { } define-primitive

		\ identity-hashcode { object } { fixnum } define-primitive