factor/native/memory.c

174 lines
3.4 KiB
C
Raw Normal View History

2004-07-16 02:26:21 -04:00
#include "factor.h"
2004-08-12 23:40:28 -04:00
/* set up guard pages to check for under/overflow.
size must be a multiple of the page size */
2004-12-10 21:39:45 -05:00
#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)
{
2004-08-12 23:40:28 -04:00
int pagesize = getpagesize();
2004-08-12 23:40:28 -04:00
char* array = mmap((void*)0,pagesize + size + pagesize,
2004-09-11 15:26:24 -04:00
PROT_READ | PROT_WRITE | PROT_EXEC,
MAP_ANON | MAP_PRIVATE,-1,0);
2004-08-12 23:40:28 -04:00
if(mprotect(array,pagesize,PROT_NONE) == -1)
2004-08-12 02:13:43 -04:00
fatal_error("Cannot allocate low guard page",(CELL)array);
2004-08-12 23:40:28 -04:00
if(mprotect(array + pagesize + size,pagesize,PROT_NONE) == -1)
2004-08-12 02:13:43 -04:00
fatal_error("Cannot allocate high guard page",(CELL)array);
2004-08-12 02:13:43 -04:00
/* return bottom of actual array */
2004-08-12 23:40:28 -04:00
return array + pagesize;
}
2004-12-10 21:39:45 -05:00
#endif
void init_zone(ZONE* z, CELL size)
2004-07-16 02:26:21 -04:00
{
2004-09-06 02:32:04 -04:00
z->base = z->here = align8((CELL)alloc_guarded(size));
2004-07-16 02:26:21 -04:00
if(z->base == 0)
fatal_error("Cannot allocate zone",size);
z->limit = z->base + size;
2004-07-29 17:18:41 -04:00
z->alarm = z->base + (size * 3) / 4;
2004-07-16 02:26:21 -04:00
z->base = align8(z->base);
}
void init_arena(CELL size)
{
init_zone(&active,size);
init_zone(&prior,size);
2004-08-29 03:20:19 -04:00
allot_profiling = false;
gc_in_progress = false;
2005-02-17 21:19:27 -05:00
heap_scan = false;
2004-12-25 02:55:03 -05:00
gc_time = 0;
2004-07-16 02:26:21 -04:00
}
2004-08-29 03:20:19 -04:00
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(type_of(obj) == WORD_TYPE)
2004-08-29 03:20:19 -04:00
untag_word(obj)->allot_count += a;
}
2004-12-31 02:38:58 -05:00
if(in_zone(&prior,executing))
critical_error("executing in prior zone",executing);
untag_word_fast(executing)->allot_count += a;
2004-08-29 03:20:19 -04:00
}
2004-07-16 02:26:21 -04:00
void flip_zones()
{
2004-09-01 21:04:16 -04:00
ZONE z = active;
active = prior;
prior = z;
active.here = active.base;
2004-07-16 02:26:21 -04:00
}
bool in_zone(ZONE* z, CELL pointer)
{
return pointer >= z->base && pointer < z->limit;
}
2004-07-24 00:54:57 -04:00
void primitive_room(void)
{
box_integer(compiling.limit - compiling.here);
box_integer(compiling.limit - compiling.base);
2004-09-19 17:39:28 -04:00
box_integer(active.limit - active.here);
box_integer(active.limit - active.base);
2004-07-24 00:54:57 -04:00
}
2004-08-29 03:20:19 -04:00
void primitive_allot_profiling(void)
{
CELL d = dpop();
if(d == F)
allot_profiling = false;
else
{
allot_profiling = true;
profile_depth = to_fixnum(d);
}
}
2004-09-18 22:29:29 -04:00
void primitive_address(void)
{
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())));
}
void primitive_begin_scan(void)
{
primitive_gc();
heap_scan_ptr = active.base;
heap_scan_end = active.here;
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);
if(heap_scan_ptr >= heap_scan_end)
{
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;
}