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 )
: 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.
! Image header
-: emit-header ( -- )
+: emit-image-header ( -- )
image-magic emit
image-version emit
data-base emit ! relocation base at end of header
: 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
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
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 )
TUPLE: node < identity-tuple ;
-M: node hashcode* drop node hashcode* ;
-
TUPLE: #introduce < node out-d ;
: #introduce ( out-d -- node )
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 -- )
[ [] ] 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 ;
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 ;
: <model> ( value -- model )
model new-model ;
-M: model hashcode* drop model hashcode* ;
-
: add-dependency ( dep model -- )
dependencies>> push ;
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 ;
introductions
loop? ;
-M: inline-recursive hashcode* id>> hashcode* ;
-
: inlined-block? ( word -- ? ) "inlined-block" word-prop ;
: <inline-recursive> ( word -- label )
\ disable-gc-events { } { object } define-primitive
\ profiling { object } { } define-primitive
+
+\ identity-hashcode { object } { fixnum } define-primitive
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 ;
: 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 ;
{ "<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
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 -- )
$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:"
{ $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" } }
[ 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
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
: tag-fixnum ( n -- tagged )
tag-bits get shift ;
+: tag-header ( n -- tagged )
+ 2 shift ;
+
: untag-fixnum ( n -- tagged )
tag-bits get neg shift ;
* 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 */
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);
}
}
void visit_object_code_block(object *obj)
{
- switch(obj->h.hi_tag())
+ switch(obj->type())
{
case WORD_TYPE:
{
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;
}
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);
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();
}
{
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();
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();
{
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);
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:
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));
}
};
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);
* 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))
a nursery allocation */
write_barrier(obj,size);
- obj->h = header;
+ obj->initialize(type);
return obj;
}
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);
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);
#define TYPE_COUNT 14
-#define FORWARDING_POINTER 5 /* can be anything other than FIXNUM_TYPE */
-
enum code_block_type
{
code_block_unoptimized,
struct object;
-struct header {
- cell value;
+#define NO_TYPE_CHECK static const cell type_number = TYPE_COUNT
- /* Default ctor to make gcc 3.x happy */
- explicit header() { abort(); }
+struct object {
+ NO_TYPE_CHECK;
+ cell header;
- explicit header(cell value_) : value(value_ << TAG_BITS) {}
+ cell size() const;
+ cell binary_payload_start() const;
+
+ cell *slots() const { return (cell *)this; }
- void check_header() const
+ /* 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
{
-#ifdef FACTOR_DEBUG
- assert(TAG(value) == FIXNUM_TYPE && untag_fixnum(value) < TYPE_COUNT);
-#endif
+ return (header & 1) == 1;
}
- cell hi_tag() const
+ cell type() const
{
- check_header();
- return value >> TAG_BITS;
+ return (header >> 2) & TAG_MASK;
}
- bool forwarding_pointer_p() const
+ void initialize(cell type)
{
- return TAG(value) == FORWARDING_POINTER;
+ header = type << 2;
}
- object *forwarding_pointer() const
+ cell hashcode() const
{
- return (object *)UNTAG(value);
+ return (header >> 6);
}
- void forward_to(object *pointer)
+ void set_hashcode(cell hashcode)
{
- value = RETAG(pointer,FORWARDING_POINTER);
+ header = (header & 0x3f) | (hashcode << 6);
}
-};
-#define NO_TYPE_CHECK static const cell type_number = TYPE_COUNT
-
-struct object {
- NO_TYPE_CHECK;
- header h;
-
- cell size() const;
- cell binary_payload_start() const;
+ bool forwarding_pointer_p() const
+ {
+ return (header & 2) == 2;
+ }
- cell *slots() const { return (cell *)this; }
+ object *forwarding_pointer() const
+ {
+ return (object *)UNTAG(header);
+ }
- /* Only valid for objects in tenured space; must fast to free_heap_block
- to do anything with it if its free */
- bool free_p() const
+ void forward_to(object *pointer)
{
- return (h.value & 1) == 1;
+ header = ((cell)pointer | 2);
}
};
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());
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);
}
}
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,
primitive_callback,
primitive_enable_gc_events,
primitive_disable_gc_events,
+ primitive_identity_hashcode,
};
}
inline static cell tag_dynamic(object *value)
{
- return RETAG(value,value->h.hi_tag());
+ return RETAG(value,value->type());
}
template<typename Type>
// 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();
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)
projects / factor.git / commitdiff