2004-07-16 02:26:21 -04:00
|
|
|
#include "factor.h"
|
|
|
|
|
2005-05-13 00:09:49 -04:00
|
|
|
CELL object_size(CELL pointer)
|
2005-05-10 22:30:58 -04:00
|
|
|
{
|
2005-05-13 00:09:49 -04:00
|
|
|
CELL size;
|
|
|
|
|
|
|
|
switch(TAG(pointer))
|
|
|
|
{
|
|
|
|
case FIXNUM_TYPE:
|
|
|
|
size = 0;
|
|
|
|
break;
|
|
|
|
case BIGNUM_TYPE:
|
|
|
|
size = untagged_object_size(UNTAG(pointer));
|
|
|
|
break;
|
|
|
|
case CONS_TYPE:
|
|
|
|
size = sizeof(F_CONS);
|
|
|
|
break;
|
|
|
|
case RATIO_TYPE:
|
|
|
|
size = sizeof(F_RATIO);
|
|
|
|
break;
|
|
|
|
case FLOAT_TYPE:
|
|
|
|
size = sizeof(F_FLOAT);
|
|
|
|
break;
|
|
|
|
case COMPLEX_TYPE:
|
|
|
|
size = sizeof(F_CONS);
|
|
|
|
break;
|
|
|
|
case OBJECT_TYPE:
|
2005-07-06 01:13:01 -04:00
|
|
|
if(pointer == F)
|
|
|
|
size = 0;
|
|
|
|
else
|
|
|
|
size = untagged_object_size(UNTAG(pointer));
|
2005-05-13 00:09:49 -04:00
|
|
|
break;
|
|
|
|
default:
|
|
|
|
critical_error("Cannot determine object_size",pointer);
|
|
|
|
size = 0; /* Can't happen */
|
|
|
|
break;
|
|
|
|
}
|
|
|
|
|
|
|
|
return align8(size);
|
2004-12-10 21:39:45 -05:00
|
|
|
}
|
2005-05-10 22:30:58 -04:00
|
|
|
|
2005-05-13 00:09:49 -04:00
|
|
|
CELL untagged_object_size(CELL pointer)
|
2004-08-12 01:07:22 -04:00
|
|
|
{
|
2005-05-13 00:09:49 -04:00
|
|
|
CELL size;
|
2004-08-12 01:07:22 -04:00
|
|
|
|
2005-05-13 00:09:49 -04:00
|
|
|
switch(untag_header(get(pointer)))
|
|
|
|
{
|
|
|
|
case WORD_TYPE:
|
|
|
|
size = sizeof(F_WORD);
|
|
|
|
break;
|
|
|
|
case ARRAY_TYPE:
|
|
|
|
case TUPLE_TYPE:
|
|
|
|
case BIGNUM_TYPE:
|
|
|
|
case BYTE_ARRAY_TYPE:
|
2005-06-16 18:50:49 -04:00
|
|
|
size = array_size(array_capacity((F_ARRAY*)(pointer)));
|
2005-05-13 00:09:49 -04:00
|
|
|
break;
|
|
|
|
case HASHTABLE_TYPE:
|
|
|
|
size = sizeof(F_HASHTABLE);
|
|
|
|
break;
|
|
|
|
case VECTOR_TYPE:
|
|
|
|
size = sizeof(F_VECTOR);
|
|
|
|
break;
|
|
|
|
case STRING_TYPE:
|
2005-06-16 18:50:49 -04:00
|
|
|
size = string_size(string_capacity((F_STRING*)(pointer)));
|
2005-05-13 00:09:49 -04:00
|
|
|
break;
|
|
|
|
case SBUF_TYPE:
|
|
|
|
size = sizeof(F_SBUF);
|
|
|
|
break;
|
|
|
|
case FLOAT_TYPE:
|
|
|
|
size = sizeof(F_FLOAT);
|
|
|
|
break;
|
|
|
|
case DLL_TYPE:
|
|
|
|
size = sizeof(DLL);
|
|
|
|
break;
|
|
|
|
case ALIEN_TYPE:
|
|
|
|
size = sizeof(ALIEN);
|
|
|
|
break;
|
|
|
|
case DISPLACED_ALIEN_TYPE:
|
|
|
|
size = sizeof(DISPLACED_ALIEN);
|
|
|
|
break;
|
2005-08-03 23:56:28 -04:00
|
|
|
case WRAPPER_TYPE:
|
|
|
|
size = sizeof(F_WRAPPER);
|
|
|
|
break;
|
2005-05-13 00:09:49 -04:00
|
|
|
default:
|
|
|
|
critical_error("Cannot determine untagged_object_size",pointer);
|
|
|
|
size = -1;/* can't happen */
|
|
|
|
break;
|
|
|
|
}
|
2004-08-12 23:40:28 -04:00
|
|
|
|
2005-05-13 00:09:49 -04:00
|
|
|
return align8(size);
|
|
|
|
}
|
2004-08-12 01:07:22 -04:00
|
|
|
|
2005-05-13 00:09:49 -04:00
|
|
|
void primitive_type(void)
|
|
|
|
{
|
|
|
|
drepl(tag_fixnum(type_of(dpeek())));
|
|
|
|
}
|
2004-08-12 01:07:22 -04:00
|
|
|
|
2005-08-15 03:25:39 -04:00
|
|
|
void primitive_tag(void)
|
|
|
|
{
|
|
|
|
drepl(tag_fixnum(TAG(dpeek())));
|
|
|
|
}
|
|
|
|
|
2005-05-13 00:09:49 -04:00
|
|
|
#define SLOT(obj,slot) ((obj) + (slot) * CELLS)
|
2004-08-12 01:07:22 -04:00
|
|
|
|
2005-05-13 00:09:49 -04:00
|
|
|
void primitive_slot(void)
|
|
|
|
{
|
|
|
|
F_FIXNUM slot = untag_fixnum_fast(dpop());
|
|
|
|
CELL obj = UNTAG(dpop());
|
|
|
|
dpush(get(SLOT(obj,slot)));
|
|
|
|
}
|
2005-05-10 22:30:58 -04:00
|
|
|
|
2005-05-13 00:09:49 -04:00
|
|
|
void primitive_set_slot(void)
|
|
|
|
{
|
|
|
|
F_FIXNUM slot = untag_fixnum_fast(dpop());
|
|
|
|
CELL obj = UNTAG(dpop());
|
|
|
|
CELL value = dpop();
|
|
|
|
put(SLOT(obj,slot),value);
|
|
|
|
write_barrier(obj);
|
|
|
|
}
|
2005-05-12 01:02:39 -04:00
|
|
|
|
2005-05-13 00:09:49 -04:00
|
|
|
void primitive_integer_slot(void)
|
|
|
|
{
|
|
|
|
F_FIXNUM slot = untag_fixnum_fast(dpop());
|
|
|
|
CELL obj = UNTAG(dpop());
|
|
|
|
dpush(tag_integer(get(SLOT(obj,slot))));
|
|
|
|
}
|
2004-07-16 02:26:21 -04:00
|
|
|
|
2005-05-13 00:09:49 -04:00
|
|
|
void primitive_set_integer_slot(void)
|
|
|
|
{
|
|
|
|
F_FIXNUM slot = untag_fixnum_fast(dpop());
|
|
|
|
CELL obj = UNTAG(dpop());
|
|
|
|
F_FIXNUM value = to_fixnum(dpop());
|
|
|
|
put(SLOT(obj,slot),value);
|
2004-07-16 02:26:21 -04:00
|
|
|
}
|
|
|
|
|
2004-09-18 22:29:29 -04:00
|
|
|
void primitive_address(void)
|
2004-09-06 22:39:12 -04:00
|
|
|
{
|
2005-02-18 20:37:01 -05:00
|
|
|
drepl(tag_bignum(s48_ulong_to_bignum(dpeek())));
|
|
|
|
}
|
|
|
|
|
|
|
|
void primitive_size(void)
|
|
|
|
{
|
|
|
|
drepl(tag_fixnum(object_size(dpeek())));
|
|
|
|
}
|
|
|
|
|
2005-09-10 18:27:31 -04:00
|
|
|
void primitive_clone(void)
|
|
|
|
{
|
|
|
|
CELL obj = dpeek();
|
|
|
|
CELL size = object_size(obj);
|
|
|
|
CELL tag = TAG(obj);
|
|
|
|
void *new_obj = allot(size);
|
|
|
|
new_obj = RETAG(memcpy(new_obj,(void*)UNTAG(obj),size),tag);
|
|
|
|
drepl(new_obj);
|
|
|
|
}
|
|
|
|
|
2005-05-13 00:09:49 -04:00
|
|
|
void primitive_room(void)
|
|
|
|
{
|
|
|
|
CELL list = F;
|
|
|
|
int gen;
|
2005-07-26 19:54:43 -04:00
|
|
|
box_unsigned_cell(compiling.limit - compiling.here);
|
|
|
|
box_unsigned_cell(compiling.limit - compiling.base);
|
|
|
|
box_unsigned_cell(cards_end - cards);
|
|
|
|
box_unsigned_cell(prior.limit - prior.base);
|
2005-07-13 15:14:57 -04:00
|
|
|
for(gen = gen_count - 1; gen >= 0; gen--)
|
2005-05-13 00:09:49 -04:00
|
|
|
{
|
|
|
|
ZONE *z = &generations[gen];
|
2005-07-26 19:54:43 -04:00
|
|
|
list = cons(cons(tag_cell(z->limit - z->here),
|
|
|
|
tag_cell(z->limit - z->base)),
|
2005-05-13 00:09:49 -04:00
|
|
|
list);
|
|
|
|
}
|
|
|
|
dpush(list);
|
|
|
|
}
|
|
|
|
|
2005-02-18 20:37:01 -05:00
|
|
|
void primitive_begin_scan(void)
|
|
|
|
{
|
2005-05-12 01:02:39 -04:00
|
|
|
garbage_collection(TENURED);
|
2005-05-11 00:43:52 -04:00
|
|
|
heap_scan_ptr = tenured.base;
|
2005-02-18 20:37:01 -05:00
|
|
|
heap_scan = true;
|
|
|
|
}
|
|
|
|
|
|
|
|
void primitive_next_object(void)
|
|
|
|
{
|
|
|
|
CELL value = get(heap_scan_ptr);
|
|
|
|
CELL obj = heap_scan_ptr;
|
|
|
|
CELL size, type;
|
|
|
|
|
|
|
|
if(!heap_scan)
|
|
|
|
general_error(ERROR_HEAP_SCAN,F);
|
|
|
|
|
2005-05-13 00:09:49 -04:00
|
|
|
if(heap_scan_ptr >= tenured.here)
|
2005-02-18 20:37:01 -05:00
|
|
|
{
|
|
|
|
dpush(F);
|
|
|
|
return;
|
|
|
|
}
|
|
|
|
|
|
|
|
if(headerp(value))
|
|
|
|
{
|
|
|
|
size = align8(untagged_object_size(heap_scan_ptr));
|
|
|
|
type = untag_header(value);
|
|
|
|
}
|
|
|
|
else
|
|
|
|
{
|
|
|
|
size = CELLS * 2;
|
|
|
|
type = CONS_TYPE;
|
|
|
|
}
|
|
|
|
|
|
|
|
heap_scan_ptr += size;
|
|
|
|
|
|
|
|
if(type < HEADER_TYPE)
|
|
|
|
dpush(RETAG(obj,type));
|
|
|
|
else
|
|
|
|
dpush(RETAG(obj,OBJECT_TYPE));
|
|
|
|
}
|
|
|
|
|
|
|
|
void primitive_end_scan(void)
|
|
|
|
{
|
|
|
|
heap_scan = false;
|
2004-09-06 22:39:12 -04:00
|
|
|
}
|