From 064c00f78d934f8051fa7bc2dea5d998bf0efc06 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 10 Nov 2009 21:06:36 -0600 Subject: [PATCH] New identity-hashcode primitive --- basis/bootstrap/image/image.factor | 11 ++- basis/compiler/cfg/cfg.factor | 6 +- .../expressions/expressions.factor | 3 + basis/compiler/tree/tree.factor | 2 - basis/cpu/ppc/ppc.factor | 2 +- basis/cpu/x86/x86.factor | 2 +- basis/io/launcher/launcher.factor | 2 - basis/models/models.factor | 2 - basis/serialize/serialize.factor | 2 +- basis/stack-checker/inlining/inlining.factor | 2 - .../known-words/known-words.factor | 2 + basis/stack-checker/values/values.factor | 8 +- core/bootstrap/primitives.factor | 1 + core/destructors/destructors.factor | 6 +- core/hashtables/hashtables-docs.factor | 3 +- core/kernel/kernel-docs.factor | 6 +- core/kernel/kernel-tests.factor | 4 + core/kernel/kernel.factor | 2 + core/layouts/layouts.factor | 3 + vm/allot.hpp | 6 +- vm/code_block_visitor.hpp | 2 +- vm/collector.hpp | 9 +-- vm/compaction.cpp | 4 +- vm/data_heap.cpp | 6 +- vm/debug.cpp | 2 +- vm/gc.cpp | 4 +- vm/image.cpp | 6 +- vm/layouts.hpp | 80 +++++++++---------- vm/objects.cpp | 20 ++++- vm/primitives.cpp | 2 + vm/tagged.hpp | 2 +- vm/vm.hpp | 7 +- 32 files changed, 122 insertions(+), 97 deletions(-) diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 2178b5d4cb..b2c7f37013 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -71,6 +71,9 @@ C: 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 image set 20000 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 index 369e6ebc32..a595a87b3b 100644 --- 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>> ; - : ( -- 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 index 6534aa74ab..d2e7c2ac86 100644 --- a/basis/compiler/cfg/value-numbering/expressions/expressions.factor +++ b/basis/compiler/cfg/value-numbering/expressions/expressions.factor @@ -27,6 +27,9 @@ C: 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 ) expr>vn ; inline GENERIC: >expr ( insn -- expr ) diff --git a/basis/compiler/tree/tree.factor b/basis/compiler/tree/tree.factor index 7fa096b623..82b8fbb843 100644 --- 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 index 0f33df8df7..0fb99374a0 100644 --- 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 index a63b92e050..d78d05bac7 100644 --- 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 index 34325780c0..d4bfbb35c2 100755 --- 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 index 1c03bb224c..f9927cfd4c 100644 --- a/basis/models/models.factor +++ b/basis/models/models.factor @@ -17,8 +17,6 @@ value connections dependencies ref locked? ; : ( 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 index 4de858e811..9b4b0ac46b 100644 --- a/basis/serialize/serialize.factor +++ b/basis/serialize/serialize.factor @@ -26,7 +26,7 @@ TUPLE: id obj ; C: 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 index 2a2f86df3d..38ac2b0e71 100644 --- 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 ; : ( word -- label ) diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 1a9eb4afa4..01c5742959 100644 --- 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 index 97545a872f..7e11ec3edb 100644 --- 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 ; : ( 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 index 702590516c..26a5e15d6c 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -518,6 +518,7 @@ tuple { "" "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 index 3e57f498af..8cceeefdce 100644 --- 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 index 37d6de0a76..f239458355 100755 --- 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 index 9a4fd4495a..0e8c3368ff 100644 --- 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 index 726fa1f5bb..ded2ee9702 100644 --- 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 index bb27f7e57e..58c25732f1 100644 --- 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 index 7518dbf0cb..7ba2bdf8e2 100644 --- 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 index 9a00bafd38..2c2c58c278 100644 --- 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 index 0f17d4041d..09410d4ae4 100644 --- a/vm/code_block_visitor.hpp +++ b/vm/code_block_visitor.hpp @@ -42,7 +42,7 @@ template 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 index 2e28da3f49..db5b33ba23 100644 --- a/vm/collector.hpp +++ b/vm/collector.hpp @@ -16,11 +16,10 @@ template 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 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 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 index 1c9dfc0def..0bbc7c8d06 100644 --- 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 index c62b433af0..43fbd930f1 100755 --- 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 index df23615419..376b9b8346 100755 --- 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 index 977266bd7d..a9372535d4 100755 --- 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; } diff --git a/vm/image.cpp b/vm/image.cpp index be6cd813fc..0a84c2d337 100755 --- a/vm/image.cpp +++ b/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); diff --git a/vm/layouts.hpp b/vm/layouts.hpp index 831cc387d2..f9aace963b 100644 --- a/vm/layouts.hpp +++ b/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); } }; diff --git a/vm/objects.cpp b/vm/objects.cpp index fa2446d54f..81ba63a616 100644 --- a/vm/objects.cpp +++ b/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(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); } } diff --git a/vm/primitives.cpp b/vm/primitives.cpp index 013250a502..20860af084 100644 --- a/vm/primitives.cpp +++ b/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, }; } diff --git a/vm/tagged.hpp b/vm/tagged.hpp index e520e326fa..e9f89528bc 100755 --- a/vm/tagged.hpp +++ b/vm/tagged.hpp @@ -8,7 +8,7 @@ template cell tag(Type *value) inline static cell tag_dynamic(object *value) { - return RETAG(value,value->h.hi_tag()); + return RETAG(value,value->type()); } template diff --git a/vm/vm.hpp b/vm/vm.hpp index 05f15af560..8d7ef556bd 100755 --- a/vm/vm.hpp +++ b/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 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)