factor/native/memory.c

#include "factor.h"

/* set up guard pages to check for under/overflow.
size must be a multiple of the page size */

#ifdef WIN32
void *alloc_guarded(CELL size)
{
       SYSTEM_INFO si;
       char *mem;
       DWORD ignore;

       GetSystemInfo(&si);
       mem = (char *)VirtualAlloc(NULL, si.dwPageSize*2 + size, MEM_COMMIT, PAGE_EXECUTE_READWRITE);

       if (!VirtualProtect(mem, si.dwPageSize, PAGE_NOACCESS, &ignore))
	       fatal_error("Cannot allocate low guard page", (CELL)mem);

       if (!VirtualProtect(mem+size+si.dwPageSize, si.dwPageSize, PAGE_NOACCESS, &ignore))
	       fatal_error("Cannot allocate high guard page", (CELL)mem);

       return mem + si.dwPageSize;
}
#else
void* alloc_guarded(CELL size)
{
	int pagesize = getpagesize();

	char* array = mmap((void*)0,pagesize + size + pagesize,
		PROT_READ | PROT_WRITE | PROT_EXEC,
		MAP_ANON | MAP_PRIVATE,-1,0);

	if(mprotect(array,pagesize,PROT_NONE) == -1)
		fatal_error("Cannot allocate low guard page",(CELL)array);

	if(mprotect(array + pagesize + size,pagesize,PROT_NONE) == -1)
		fatal_error("Cannot allocate high guard page",(CELL)array);

	/* return bottom of actual array */
	return array + pagesize;
}
#endif

void init_zone(ZONE* z, CELL size)
{
	z->base = z->here = align8((CELL)alloc_guarded(size));
	if(z->base == 0)
		fatal_error("Cannot allocate zone",size);
	z->limit = z->base + size;
	z->alarm = z->base + (size * 3) / 4;
	z->base = align8(z->base);
}

void init_arena(CELL size)
{
	init_zone(&active,size);
	init_zone(&prior,size);
	allot_profiling = false;
	gc_in_progress = false;
}

void allot_profile_step(CELL a)
{
	CELL depth = (cs - cs_bot) / CELLS;
	int i;
	CELL obj;

	if(gc_in_progress)
		return;

	for(i = profile_depth; i < depth; i++)
	{
		obj = get(cs_bot + i * CELLS);
		if(TAG(obj) == WORD_TYPE)
			untag_word(obj)->allot_count += a;
	}

	executing->allot_count += a;
}

void flip_zones()
{
	ZONE z = active;
	active = prior;
	prior = z;
}

bool in_zone(ZONE* z, CELL pointer)
{
	return pointer >= z->base && pointer < z->limit;
}

void primitive_room(void)
{
	box_integer(compiling.limit - compiling.here);
	box_integer(compiling.limit - compiling.base);
	box_integer(active.limit - active.here);
	box_integer(active.limit - active.base);
}

void primitive_allot_profiling(void)
{
	CELL d = dpop();
	if(d == F)
		allot_profiling = false;
	else
	{
		allot_profiling = true;
		profile_depth = to_fixnum(d);
	}
}

void primitive_address(void)
{
	dpush(tag_object(s48_ulong_to_bignum(dpop())));
}

void primitive_heap_stats(void)
{
	int instances[TYPE_COUNT], bytes[TYPE_COUNT];
	int i;
	CELL ptr;
	CELL list = F;

	for(i = 0; i < TYPE_COUNT; i++)
		instances[i] = 0;

	for(i = 0; i < TYPE_COUNT; i++)
		bytes[i] = 0;

	ptr = active.base;
	while(ptr < active.here)
	{
		CELL value = get(ptr);
		CELL size;
		CELL type;

		if(TAG(value) == HEADER_TYPE)
		{
			size = align8(untagged_object_size(ptr));
			type = untag_header(value);
		}
		else
		{
			size = CELLS * 2;
			type = CONS_TYPE;
		}

		instances[type]++;
		bytes[type] += size;
		ptr += size;
	}

	for(i = TYPE_COUNT - 1; i >= 0; i--)
	{
		list = cons(
			cons(tag_fixnum(instances[i]),tag_fixnum(bytes[i])),
			list);
	}

	dpush(list);
}