steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Move vmpp to vm

db4
Slava Pestov 2009-05-02 20:37:18 -05:00
parent 0614f54ba3
commit b923d548cf
275 changed files with 95 additions and 13846 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

112
Makefile
View File

@ -27,40 +27,40 @@ ifdef CONFIG
endif
DLL_OBJS = $(PLAF_DLL_OBJS) \
vmpp/alien.o \
vmpp/arrays.o \
vmpp/bignum.o \
vmpp/booleans.o \
vmpp/byte_arrays.o \
vmpp/callstack.o \
vmpp/code_block.o \
vmpp/code_gc.o \
vmpp/code_heap.o \
vmpp/data_gc.o \
vmpp/data_heap.o \
vmpp/debug.o \
vmpp/dispatch.o \
vmpp/errors.o \
vmpp/factor.o \
vmpp/image.o \
vmpp/inline_cache.o \
vmpp/io.o \
vmpp/jit.o \
vmpp/local_roots.o \
vmpp/math.o \
vmpp/primitives.o \
vmpp/profiler.o \
vmpp/quotations.o \
vmpp/run.o \
vmpp/strings.o \
vmpp/tuples.o \
vmpp/utilities.o \
vmpp/words.o \
vmpp/write_barrier.o
vm/alien.o \
vm/arrays.o \
vm/bignum.o \
vm/booleans.o \
vm/byte_arrays.o \
vm/callstack.o \
vm/code_block.o \
vm/code_gc.o \
vm/code_heap.o \
vm/data_gc.o \
vm/data_heap.o \
vm/debug.o \
vm/dispatch.o \
vm/errors.o \
vm/factor.o \
vm/image.o \
vm/inline_cache.o \
vm/io.o \
vm/jit.o \
vm/local_roots.o \
vm/math.o \
vm/primitives.o \
vm/profiler.o \
vm/quotations.o \
vm/run.o \
vm/strings.o \
vm/tuples.o \
vm/utilities.o \
vm/words.o \
vm/write_barrier.o
EXE_OBJS = $(PLAF_EXE_OBJS)
TEST_OBJS = vmpp/ffi_test.o
TEST_OBJS = vm/ffi_test.o
default:
$(MAKE) `./build-support/factor.sh make-target`
@ -95,60 +95,60 @@ help:
@echo "X11=1 force link with X11 libraries instead of Cocoa (only on Mac OS X)"
openbsd-x86-32:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.openbsd.x86.32
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.openbsd.x86.32
openbsd-x86-64:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.openbsd.x86.64
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.openbsd.x86.64
freebsd-x86-32:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.freebsd.x86.32
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.freebsd.x86.32
freebsd-x86-64:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.freebsd.x86.64
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.freebsd.x86.64
netbsd-x86-32:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.netbsd.x86.32
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.netbsd.x86.32
netbsd-x86-64:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.netbsd.x86.64
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.netbsd.x86.64
macosx-ppc:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) macosx.app CONFIG=vmpp/Config.macosx.ppc
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) macosx.app CONFIG=vm/Config.macosx.ppc
macosx-x86-32:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) macosx.app CONFIG=vmpp/Config.macosx.x86.32
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) macosx.app CONFIG=vm/Config.macosx.x86.32
macosx-x86-64:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) macosx.app CONFIG=vmpp/Config.macosx.x86.64
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) macosx.app CONFIG=vm/Config.macosx.x86.64
linux-x86-32:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.linux.x86.32
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.linux.x86.32
linux-x86-64:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.linux.x86.64
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.linux.x86.64
linux-ppc:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.linux.ppc
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.linux.ppc
linux-arm:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.linux.arm
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.linux.arm
solaris-x86-32:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.solaris.x86.32
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.solaris.x86.32
solaris-x86-64:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.solaris.x86.64
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.solaris.x86.64
winnt-x86-32:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.windows.nt.x86.32
$(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vmpp/Config.windows.nt.x86.32
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.windows.nt.x86.32
$(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32
winnt-x86-64:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.windows.nt.x86.64
$(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vmpp/Config.windows.nt.x86.64
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.windows.nt.x86.64
$(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64
wince-arm:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.windows.ce.arm
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.windows.ce.arm
macosx.app: factor
mkdir -p $(BUNDLE)/Contents/MacOS
@ -172,17 +172,17 @@ $(CONSOLE_EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS)
$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) $(CFLAGS_CONSOLE) -o factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION) $(EXE_OBJS)
$(TEST_LIBRARY): vmpp/ffi_test.o
$(TEST_LIBRARY): vm/ffi_test.o
$(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o libfactor-ffi-test$(SHARED_DLL_EXTENSION) $(TEST_OBJS)
clean:
rm -f vmpp/*.o
rm -f vm/*.o
rm -f factor*.dll libfactor.{a,so,dylib} libfactor-ffi-test.{a,so,dylib} Factor.app/Contents/Frameworks/libfactor.dylib
vmpp/resources.o:
$(WINDRES) vmpp/factor.rs vmpp/resources.o
vm/resources.o:
$(WINDRES) vm/factor.rs vm/resources.o
vmpp/ffi_test.o: vmpp/ffi_test.c
vm/ffi_test.o: vm/ffi_test.c
$(CC) -c $(CFLAGS) $(FFI_TEST_CFLAGS) -o $@ $<
.c.o:

2
vm/Config.arm
View File

@ -1 +1 @@
PLAF_DLL_OBJS += vm/cpu-arm.o
PLAF_DLL_OBJS += vmpp/cpu-arm.o

4
vm/Config.freebsd
View File

@ -1,4 +1,4 @@
include vm/Config.unix
PLAF_DLL_OBJS += vm/os-genunix.o vm/os-freebsd.o
include vmpp/Config.unix
PLAF_DLL_OBJS += vmpp/os-genunix.o vmpp/os-freebsd.o
CFLAGS += -export-dynamic
LIBS = -L/usr/local/lib/ -lm $(X11_UI_LIBS)

2
vm/Config.macosx
View File

@ -14,7 +14,7 @@ else
LIBS = -lm -framework Cocoa -framework AppKit
endif
LINKER = gcc $(CFLAGS) -dynamiclib -single_module -std=gnu99 \
LINKER = $(CPP) $(CFLAGS) -dynamiclib -single_module -std=gnu99 \
-current_version $(VERSION) \
-compatibility_version $(VERSION) \
-fvisibility=hidden \

234
vm/alien.c
View File

@ -1,234 +0,0 @@
#include "master.h"
/* gets the address of an object representing a C pointer */
void *alien_offset(CELL object)
{
F_ALIEN *alien;
F_BYTE_ARRAY *byte_array;
switch(type_of(object))
{
case BYTE_ARRAY_TYPE:
byte_array = untag_object(object);
return byte_array + 1;
case ALIEN_TYPE:
alien = untag_object(object);
if(alien->expired != F)
general_error(ERROR_EXPIRED,object,F,NULL);
return alien_offset(alien->alien) + alien->displacement;
case F_TYPE:
return NULL;
default:
type_error(ALIEN_TYPE,object);
return NULL; /* can't happen */
}
}
/* gets the address of an object representing a C pointer, with the
intention of storing the pointer across code which may potentially GC. */
void *pinned_alien_offset(CELL object)
{
F_ALIEN *alien;
switch(type_of(object))
{
case ALIEN_TYPE:
alien = untag_object(object);
if(alien->expired != F)
general_error(ERROR_EXPIRED,object,F,NULL);
return pinned_alien_offset(alien->alien) + alien->displacement;
case F_TYPE:
return NULL;
default:
type_error(ALIEN_TYPE,object);
return NULL; /* can't happen */
}
}
/* pop an object representing a C pointer */
void *unbox_alien(void)
{
return alien_offset(dpop());
}
/* make an alien */
CELL allot_alien(CELL delegate, CELL displacement)
{
REGISTER_ROOT(delegate);
F_ALIEN *alien = allot_object(ALIEN_TYPE,sizeof(F_ALIEN));
UNREGISTER_ROOT(delegate);
if(type_of(delegate) == ALIEN_TYPE)
{
F_ALIEN *delegate_alien = untag_object(delegate);
displacement += delegate_alien->displacement;
alien->alien = delegate_alien->alien;
}
else
alien->alien = delegate;
alien->displacement = displacement;
alien->expired = F;
return tag_object(alien);
}
/* make an alien and push */
void box_alien(void *ptr)
{
if(ptr == NULL)
dpush(F);
else
dpush(allot_alien(F,(CELL)ptr));
}
/* make an alien pointing at an offset of another alien */
void primitive_displaced_alien(void)
{
CELL alien = dpop();
CELL displacement = to_cell(dpop());
if(alien == F && displacement == 0)
dpush(F);
else
{
switch(type_of(alien))
{
case BYTE_ARRAY_TYPE:
case ALIEN_TYPE:
case F_TYPE:
dpush(allot_alien(alien,displacement));
break;
default:
type_error(ALIEN_TYPE,alien);
break;
}
}
}
/* address of an object representing a C pointer. Explicitly throw an error
if the object is a byte array, as a sanity check. */
void primitive_alien_address(void)
{
box_unsigned_cell((CELL)pinned_alien_offset(dpop()));
}
/* pop ( alien n ) from datastack, return alien's address plus n */
INLINE void *alien_pointer(void)
{
F_FIXNUM offset = to_fixnum(dpop());
return unbox_alien() + offset;
}
/* define words to read/write values at an alien address */
#define DEFINE_ALIEN_ACCESSOR(name,type,boxer,to) \
void primitive_alien_##name(void) \
{ \
boxer(*(type*)alien_pointer()); \
} \
void primitive_set_alien_##name(void) \
{ \
type* ptr = alien_pointer(); \
type value = to(dpop()); \
*ptr = value; \
}
DEFINE_ALIEN_ACCESSOR(signed_cell,F_FIXNUM,box_signed_cell,to_fixnum)
DEFINE_ALIEN_ACCESSOR(unsigned_cell,CELL,box_unsigned_cell,to_cell)
DEFINE_ALIEN_ACCESSOR(signed_8,s64,box_signed_8,to_signed_8)
DEFINE_ALIEN_ACCESSOR(unsigned_8,u64,box_unsigned_8,to_unsigned_8)
DEFINE_ALIEN_ACCESSOR(signed_4,s32,box_signed_4,to_fixnum)
DEFINE_ALIEN_ACCESSOR(unsigned_4,u32,box_unsigned_4,to_cell)
DEFINE_ALIEN_ACCESSOR(signed_2,s16,box_signed_2,to_fixnum)
DEFINE_ALIEN_ACCESSOR(unsigned_2,u16,box_unsigned_2,to_cell)
DEFINE_ALIEN_ACCESSOR(signed_1,s8,box_signed_1,to_fixnum)
DEFINE_ALIEN_ACCESSOR(unsigned_1,u8,box_unsigned_1,to_cell)
DEFINE_ALIEN_ACCESSOR(float,float,box_float,to_float)
DEFINE_ALIEN_ACCESSOR(double,double,box_double,to_double)
DEFINE_ALIEN_ACCESSOR(cell,void *,box_alien,pinned_alien_offset)
/* for FFI calls passing structs by value */
void to_value_struct(CELL src, void *dest, CELL size)
{
memcpy(dest,alien_offset(src),size);
}
/* for FFI callbacks receiving structs by value */
void box_value_struct(void *src, CELL size)
{
F_BYTE_ARRAY *array = allot_byte_array(size);
memcpy(array + 1,src,size);
dpush(tag_object(array));
}
/* On some x86 OSes, structs <= 8 bytes are returned in registers. */
void box_small_struct(CELL x, CELL y, CELL size)
{
CELL data[2];
data[0] = x;
data[1] = y;
box_value_struct(data,size);
}
/* On OS X/PPC, complex numbers are returned in registers. */
void box_medium_struct(CELL x1, CELL x2, CELL x3, CELL x4, CELL size)
{
CELL data[4];
data[0] = x1;
data[1] = x2;
data[2] = x3;
data[3] = x4;
box_value_struct(data,size);
}
/* open a native library and push a handle */
void primitive_dlopen(void)
{
CELL path = tag_object(string_to_native_alien(
untag_string(dpop())));
REGISTER_ROOT(path);
F_DLL* dll = allot_object(DLL_TYPE,sizeof(F_DLL));
UNREGISTER_ROOT(path);
dll->path = path;
ffi_dlopen(dll);
dpush(tag_object(dll));
}
/* look up a symbol in a native library */
void primitive_dlsym(void)
{
CELL dll = dpop();
REGISTER_ROOT(dll);
F_SYMBOL *sym = unbox_symbol_string();
UNREGISTER_ROOT(dll);
F_DLL *d;
if(dll == F)
box_alien(ffi_dlsym(NULL,sym));
else
{
d = untag_dll(dll);
if(d->dll == NULL)
dpush(F);
else
box_alien(ffi_dlsym(d,sym));
}
}
/* close a native library handle */
void primitive_dlclose(void)
{
ffi_dlclose(untag_dll(dpop()));
}
void primitive_dll_validp(void)
{
CELL dll = dpop();
if(dll == F)
dpush(T);
else
{
F_DLL *d = untag_dll(dll);
dpush(d->dll == NULL ? F : T);
}
}

10
vmpp/alien.cpp → vm/alien.cpp
View File

@ -9,10 +9,10 @@ char *alien_offset(CELL object)
switch(type_of(object))
{
case BYTE_ARRAY_TYPE:
byte_array = untagged<F_BYTE_ARRAY>(object);
byte_array = untag<F_BYTE_ARRAY>(object);
return (char *)(byte_array + 1);
case ALIEN_TYPE:
alien = untagged<F_ALIEN>(object);
alien = untag<F_ALIEN>(object);
if(alien->expired != F)
general_error(ERROR_EXPIRED,object,F,NULL);
return alien_offset(alien->alien) + alien->displacement;
@ -33,7 +33,7 @@ char *pinned_alien_offset(CELL object)
switch(type_of(object))
{
case ALIEN_TYPE:
alien = untagged<F_ALIEN>(object);
alien = untag<F_ALIEN>(object);
if(alien->expired != F)
general_error(ERROR_EXPIRED,object,F,NULL);
return pinned_alien_offset(alien->alien) + alien->displacement;
@ -157,7 +157,7 @@ void box_value_struct(void *src, CELL size)
{
F_BYTE_ARRAY *array = allot_byte_array(size);
memcpy(array + 1,src,size);
dpush(tag_object(array));
dpush(tag<F_BYTE_ARRAY>(array));
}
/* On some x86 OSes, structs <= 8 bytes are returned in registers. */
@ -216,7 +216,7 @@ void primitive_dlsym(void)
/* close a native library handle */
void primitive_dlclose(void)
{
ffi_dlclose(untag_dll(dpop()));
ffi_dlclose(untag_check<F_DLL>(dpop()));
}
void primitive_dll_validp(void)

50
vm/alien.h
View File

@ -1,50 +0,0 @@
CELL allot_alien(CELL delegate, CELL displacement);
void primitive_displaced_alien(void);
void primitive_alien_address(void);
DLLEXPORT void *alien_offset(CELL object);
void fixup_alien(F_ALIEN* d);
DLLEXPORT void *unbox_alien(void);
DLLEXPORT void box_alien(void *ptr);
void primitive_alien_signed_cell(void);
void primitive_set_alien_signed_cell(void);
void primitive_alien_unsigned_cell(void);
void primitive_set_alien_unsigned_cell(void);
void primitive_alien_signed_8(void);
void primitive_set_alien_signed_8(void);
void primitive_alien_unsigned_8(void);
void primitive_set_alien_unsigned_8(void);
void primitive_alien_signed_4(void);
void primitive_set_alien_signed_4(void);
void primitive_alien_unsigned_4(void);
void primitive_set_alien_unsigned_4(void);
void primitive_alien_signed_2(void);
void primitive_set_alien_signed_2(void);
void primitive_alien_unsigned_2(void);
void primitive_set_alien_unsigned_2(void);
void primitive_alien_signed_1(void);
void primitive_set_alien_signed_1(void);
void primitive_alien_unsigned_1(void);
void primitive_set_alien_unsigned_1(void);
void primitive_alien_float(void);
void primitive_set_alien_float(void);
void primitive_alien_double(void);
void primitive_set_alien_double(void);
void primitive_alien_cell(void);
void primitive_set_alien_cell(void);
DLLEXPORT void to_value_struct(CELL src, void *dest, CELL size);
DLLEXPORT void box_value_struct(void *src, CELL size);
DLLEXPORT void box_small_struct(CELL x, CELL y, CELL size);
void box_medium_struct(CELL x1, CELL x2, CELL x3, CELL x4, CELL size);
DEFINE_UNTAG(F_DLL,DLL_TYPE,dll)
void primitive_dlopen(void);
void primitive_dlsym(void);
void primitive_dlclose(void);
void primitive_dll_validp(void);

4
vmpp/alien.hpp → vm/alien.hpp
View File

@ -1,5 +1,3 @@
DEFINE_UNTAG(F_ALIEN,ALIEN_TYPE,alien)
CELL allot_alien(CELL delegate, CELL displacement);
void primitive_displaced_alien(void);
@ -42,8 +40,6 @@ DLLEXPORT void box_value_struct(void *src, CELL size);
DLLEXPORT void box_small_struct(CELL x, CELL y, CELL size);
void box_medium_struct(CELL x1, CELL x2, CELL x3, CELL x4, CELL size);
DEFINE_UNTAG(F_DLL,DLL_TYPE,dll)
void primitive_dlopen(void);
void primitive_dlsym(void);
void primitive_dlclose(void);

159
vm/arrays.c
View File

@ -1,159 +0,0 @@
#include "master.h"
/* the array is full of undefined data, and must be correctly filled before the
next GC. size is in cells */
F_ARRAY *allot_array_internal(CELL type, CELL capacity)
{
F_ARRAY *array = allot_object(type,array_size(capacity));
array->capacity = tag_fixnum(capacity);
return array;
}
/* make a new array with an initial element */
F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill)
{
int i;
REGISTER_ROOT(fill);
F_ARRAY* array = allot_array_internal(type, capacity);
UNREGISTER_ROOT(fill);
if(fill == 0)
memset((void*)AREF(array,0),'\0',capacity * CELLS);
else
{
/* No need for write barrier here. Either the object is in
the nursery, or it was allocated directly in tenured space
and the write barrier is already hit for us in that case. */
for(i = 0; i < capacity; i++)
put(AREF(array,i),fill);
}
return array;
}
/* push a new array on the stack */
void primitive_array(void)
{
CELL initial = dpop();
CELL size = unbox_array_size();
dpush(tag_array(allot_array(ARRAY_TYPE,size,initial)));
}
CELL allot_array_1(CELL obj)
{
REGISTER_ROOT(obj);
F_ARRAY *a = allot_array_internal(ARRAY_TYPE,1);
UNREGISTER_ROOT(obj);
set_array_nth(a,0,obj);
return tag_array(a);
}
CELL allot_array_2(CELL v1, CELL v2)
{
REGISTER_ROOT(v1);
REGISTER_ROOT(v2);
F_ARRAY *a = allot_array_internal(ARRAY_TYPE,2);
UNREGISTER_ROOT(v2);
UNREGISTER_ROOT(v1);
set_array_nth(a,0,v1);
set_array_nth(a,1,v2);
return tag_array(a);
}
CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4)
{
REGISTER_ROOT(v1);
REGISTER_ROOT(v2);
REGISTER_ROOT(v3);
REGISTER_ROOT(v4);
F_ARRAY *a = allot_array_internal(ARRAY_TYPE,4);
UNREGISTER_ROOT(v4);
UNREGISTER_ROOT(v3);
UNREGISTER_ROOT(v2);
UNREGISTER_ROOT(v1);
set_array_nth(a,0,v1);
set_array_nth(a,1,v2);
set_array_nth(a,2,v3);
set_array_nth(a,3,v4);
return tag_array(a);
}
static bool reallot_array_in_place_p(F_ARRAY *array, CELL capacity)
{
return in_zone(&nursery,(CELL)array) && capacity <= array_capacity(array);
}
F_ARRAY *reallot_array(F_ARRAY *array, CELL capacity)
{
#ifdef FACTOR_DEBUG
CELL header = untag_header(array->header);
assert(header == ARRAY_TYPE || header == BIGNUM_TYPE);
#endif
if(reallot_array_in_place_p(array,capacity))
{
array->capacity = tag_fixnum(capacity);
return array;
}
else
{
CELL to_copy = array_capacity(array);
if(capacity < to_copy)
to_copy = capacity;
REGISTER_UNTAGGED(array);
F_ARRAY* new_array = allot_array_internal(untag_header(array->header),capacity);
UNREGISTER_UNTAGGED(array);
memcpy(new_array + 1,array + 1,to_copy * CELLS);
memset((char *)AREF(new_array,to_copy),'\0',(capacity - to_copy) * CELLS);
return new_array;
}
}
void primitive_resize_array(void)
{
F_ARRAY* array = untag_array(dpop());
CELL capacity = unbox_array_size();
dpush(tag_array(reallot_array(array,capacity)));
}
void growable_array_add(F_GROWABLE_ARRAY *array, CELL elt)
{
F_ARRAY *underlying = untag_object(array->array);
REGISTER_ROOT(elt);
if(array->count == array_capacity(underlying))
{
underlying = reallot_array(underlying,array->count * 2);
array->array = tag_array(underlying);
}
UNREGISTER_ROOT(elt);
set_array_nth(underlying,array->count++,elt);
}
void growable_array_append(F_GROWABLE_ARRAY *array, F_ARRAY *elts)
{
REGISTER_UNTAGGED(elts);
F_ARRAY *underlying = untag_object(array->array);
CELL elts_size = array_capacity(elts);
CELL new_size = array->count + elts_size;
if(new_size >= array_capacity(underlying))
{
underlying = reallot_array(underlying,new_size * 2);
array->array = tag_array(underlying);
}
UNREGISTER_UNTAGGED(elts);
write_barrier(array->array);
memcpy((void *)AREF(underlying,array->count),
(void *)AREF(elts,0),
elts_size * CELLS);
array->count += elts_size;
}

6
vmpp/arrays.cpp → vm/arrays.cpp
View File

@ -25,7 +25,7 @@ void primitive_array(void)
{
CELL initial = dpop();
CELL size = unbox_array_size();
dpush(tag_array(allot_array(size,initial)));
dpush(tag<F_ARRAY>(allot_array(size,initial)));
}
CELL allot_array_1(CELL obj_)
@ -62,9 +62,9 @@ CELL allot_array_4(CELL v1_, CELL v2_, CELL v3_, CELL v4_)
void primitive_resize_array(void)
{
F_ARRAY* array = untag_array(dpop());
F_ARRAY* array = untag_check<F_ARRAY>(dpop());
CELL capacity = unbox_array_size();
dpush(tag_array(reallot_array(array,capacity)));
dpush(tag<F_ARRAY>(reallot_array(array,capacity)));
}
void growable_array::add(CELL elt_)

95
vm/arrays.h
View File

@ -1,95 +0,0 @@
DEFINE_UNTAG(F_ARRAY,ARRAY_TYPE,array)
INLINE CELL tag_array(F_ARRAY *array)
{
return RETAG(array,ARRAY_TYPE);
}
/* Inline functions */
INLINE CELL array_size(CELL size)
{
return sizeof(F_ARRAY) + size * CELLS;
}
INLINE CELL array_capacity(F_ARRAY* array)
{
#ifdef FACTOR_DEBUG
CELL header = untag_header(array->header);
assert(header == ARRAY_TYPE || header == BIGNUM_TYPE || header == BYTE_ARRAY_TYPE);
#endif
return array->capacity >> TAG_BITS;
}
#define AREF(array,index) ((CELL)(array) + sizeof(F_ARRAY) + (index) * CELLS)
#define UNAREF(array,ptr) (((CELL)(ptr)-(CELL)(array)-sizeof(F_ARRAY)) / CELLS)
INLINE CELL array_nth(F_ARRAY *array, CELL slot)
{
#ifdef FACTOR_DEBUG
assert(slot < array_capacity(array));
assert(untag_header(array->header) == ARRAY_TYPE);
#endif
return get(AREF(array,slot));
}
INLINE void set_array_nth(F_ARRAY *array, CELL slot, CELL value)
{
#ifdef FACTOR_DEBUG
assert(slot < array_capacity(array));
assert(untag_header(array->header) == ARRAY_TYPE);
#endif
put(AREF(array,slot),value);
write_barrier((CELL)array);
}
F_ARRAY *allot_array_internal(CELL type, CELL capacity);
F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill);
F_BYTE_ARRAY *allot_byte_array(CELL size);
CELL allot_array_1(CELL obj);
CELL allot_array_2(CELL v1, CELL v2);
CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4);
void primitive_array(void);
F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity);
void primitive_resize_array(void);
/* Macros to simulate a vector in C */
typedef struct {
CELL count;
CELL array;
} F_GROWABLE_ARRAY;
/* Allocates memory */
INLINE F_GROWABLE_ARRAY make_growable_array(void)
{
F_GROWABLE_ARRAY result;
result.count = 0;
result.array = tag_array(allot_array(ARRAY_TYPE,100,F));
return result;
}
#define GROWABLE_ARRAY(result) F_GROWABLE_ARRAY result##_g = make_growable_array(); \
REGISTER_ROOT(result##_g.array)
void growable_array_add(F_GROWABLE_ARRAY *result, CELL elt);
#define GROWABLE_ARRAY_ADD(result,elt) \
growable_array_add(&result##_g,elt)
void growable_array_append(F_GROWABLE_ARRAY *result, F_ARRAY *elts);
#define GROWABLE_ARRAY_APPEND(result,elts) \
growable_array_append(&result##_g,elts)
INLINE void growable_array_trim(F_GROWABLE_ARRAY *array)
{
array->array = tag_array(reallot_array(untag_object(array->array),array->count));
}
#define GROWABLE_ARRAY_TRIM(result) growable_array_trim(&result##_g)
#define GROWABLE_ARRAY_DONE(result) \
UNREGISTER_ROOT(result##_g.array); \
CELL result = result##_g.array;

0
vmpp/arrays.hpp → vm/arrays.hpp
View File

1878
vm/bignum.c
View File

File diff suppressed because it is too large Load Diff

0
vmpp/bignum.cpp → vm/bignum.cpp
View File

127
vm/bignum.h
View File

@ -1,127 +0,0 @@
/* :tabSize=2:indentSize=2:noTabs=true:
Copyright (C) 1989-1992 Massachusetts Institute of Technology
Portions copyright (C) 2004-2007 Slava Pestov
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
Computer Science. Permission to copy and modify this software, to
redistribute either the original software or a modified version, and
to use this software for any purpose is granted, subject to the
following restrictions and understandings.
1. Any copy made of this software must include this copyright notice
in full.
2. Users of this software agree to make their best efforts (a) to
return to the MIT Scheme project any improvements or extensions that
they make, so that these may be included in future releases; and (b)
to inform MIT of noteworthy uses of this software.
3. All materials developed as a consequence of the use of this
software shall duly acknowledge such use, in accordance with the usual
standards of acknowledging credit in academic research.
4. MIT has made no warrantee or representation that the operation of
this software will be error-free, and MIT is under no obligation to
provide any services, by way of maintenance, update, or otherwise.
5. In conjunction with products arising from the use of this material,
there shall be no use of the name of the Massachusetts Institute of
Technology nor of any adaptation thereof in any advertising,
promotional, or sales literature without prior written consent from
MIT in each case. */
typedef F_ARRAY * bignum_type;
#define BIGNUM_OUT_OF_BAND ((bignum_type) 0)
enum bignum_comparison
{
bignum_comparison_equal = 0,
bignum_comparison_less = -1,
bignum_comparison_greater = 1
};
int bignum_equal_p(bignum_type, bignum_type);
enum bignum_comparison bignum_compare(bignum_type, bignum_type);
bignum_type bignum_add(bignum_type, bignum_type);
bignum_type bignum_subtract(bignum_type, bignum_type);
bignum_type bignum_negate(bignum_type);
bignum_type bignum_multiply(bignum_type, bignum_type);
void
bignum_divide(bignum_type numerator, bignum_type denominator,
bignum_type * quotient, bignum_type * remainder);
bignum_type bignum_quotient(bignum_type, bignum_type);
bignum_type bignum_remainder(bignum_type, bignum_type);
DLLEXPORT bignum_type fixnum_to_bignum(F_FIXNUM);
DLLEXPORT bignum_type cell_to_bignum(CELL);
DLLEXPORT bignum_type long_long_to_bignum(s64 n);
DLLEXPORT bignum_type ulong_long_to_bignum(u64 n);
F_FIXNUM bignum_to_fixnum(bignum_type);
CELL bignum_to_cell(bignum_type);
s64 bignum_to_long_long(bignum_type);
u64 bignum_to_ulong_long(bignum_type);
bignum_type double_to_bignum(double);
double bignum_to_double(bignum_type);
/* Added bitwise operators. */
DLLEXPORT bignum_type bignum_bitwise_not(bignum_type),
bignum_arithmetic_shift(bignum_type, F_FIXNUM),
bignum_bitwise_and(bignum_type, bignum_type),
bignum_bitwise_ior(bignum_type, bignum_type),
bignum_bitwise_xor(bignum_type, bignum_type);
/* Forward references */
int bignum_equal_p_unsigned(bignum_type, bignum_type);
enum bignum_comparison bignum_compare_unsigned(bignum_type, bignum_type);
bignum_type bignum_add_unsigned(bignum_type, bignum_type, int);
bignum_type bignum_subtract_unsigned(bignum_type, bignum_type);
bignum_type bignum_multiply_unsigned(bignum_type, bignum_type, int);
bignum_type bignum_multiply_unsigned_small_factor
(bignum_type, bignum_digit_type, int);
void bignum_destructive_scale_up(bignum_type, bignum_digit_type);
void bignum_destructive_add(bignum_type, bignum_digit_type);
void bignum_divide_unsigned_large_denominator
(bignum_type, bignum_type, bignum_type *, bignum_type *, int, int);
void bignum_destructive_normalization(bignum_type, bignum_type, int);
void bignum_destructive_unnormalization(bignum_type, int);
void bignum_divide_unsigned_normalized(bignum_type, bignum_type, bignum_type);
bignum_digit_type bignum_divide_subtract
(bignum_digit_type *, bignum_digit_type *, bignum_digit_type,
bignum_digit_type *);
void bignum_divide_unsigned_medium_denominator
(bignum_type, bignum_digit_type, bignum_type *, bignum_type *, int, int);
bignum_digit_type bignum_digit_divide
(bignum_digit_type, bignum_digit_type, bignum_digit_type, bignum_digit_type *);
bignum_digit_type bignum_digit_divide_subtract
(bignum_digit_type, bignum_digit_type, bignum_digit_type, bignum_digit_type *);
void bignum_divide_unsigned_small_denominator
(bignum_type, bignum_digit_type, bignum_type *, bignum_type *, int, int);
bignum_digit_type bignum_destructive_scale_down
(bignum_type, bignum_digit_type);
bignum_type bignum_remainder_unsigned_small_denominator
(bignum_type, bignum_digit_type, int);
bignum_type bignum_digit_to_bignum(bignum_digit_type, int);
bignum_type allot_bignum(bignum_length_type, int);
bignum_type allot_bignum_zeroed(bignum_length_type, int);
bignum_type bignum_shorten_length(bignum_type, bignum_length_type);
bignum_type bignum_trim(bignum_type);
bignum_type bignum_new_sign(bignum_type, int);
bignum_type bignum_maybe_new_sign(bignum_type, int);
void bignum_destructive_copy(bignum_type, bignum_type);
/* Added for bitwise operations. */
bignum_type bignum_magnitude_ash(bignum_type arg1, F_FIXNUM n);
bignum_type bignum_pospos_bitwise_op(int op, bignum_type, bignum_type);
bignum_type bignum_posneg_bitwise_op(int op, bignum_type, bignum_type);
bignum_type bignum_negneg_bitwise_op(int op, bignum_type, bignum_type);
void bignum_negate_magnitude(bignum_type);
bignum_type bignum_integer_length(bignum_type arg1);
int bignum_unsigned_logbitp(int shift, bignum_type bignum);
int bignum_logbitp(int shift, bignum_type arg);
bignum_type digit_stream_to_bignum(unsigned int n_digits,
unsigned int (*producer)(unsigned int),
unsigned int radix,
int negative_p);

0
vmpp/bignum.hpp → vm/bignum.hpp
View File

100
vm/bignumint.h
View File

@ -1,100 +0,0 @@
/* -*-C-*-
$Id: s48_bignumint.h,v 1.14 2005/12/21 02:36:52 spestov Exp $
Copyright (c) 1989-1992 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
Computer Science. Permission to copy and modify this software, to
redistribute either the original software or a modified version, and
to use this software for any purpose is granted, subject to the
following restrictions and understandings.
1. Any copy made of this software must include this copyright notice
in full.
2. Users of this software agree to make their best efforts (a) to
return to the MIT Scheme project any improvements or extensions that
they make, so that these may be included in future releases; and (b)
to inform MIT of noteworthy uses of this software.
3. All materials developed as a consequence of the use of this
software shall duly acknowledge such use, in accordance with the usual
standards of acknowledging credit in academic research.
4. MIT has made no warrantee or representation that the operation of
this software will be error-free, and MIT is under no obligation to
provide any services, by way of maintenance, update, or otherwise.
5. In conjunction with products arising from the use of this material,
there shall be no use of the name of the Massachusetts Institute of
Technology nor of any adaptation thereof in any advertising,
promotional, or sales literature without prior written consent from
MIT in each case. */
/* Internal Interface to Bignum Code */
#undef BIGNUM_ZERO_P
#undef BIGNUM_NEGATIVE_P
/* The memory model is based on the following definitions, and on the
definition of the type `bignum_type'. The only other special
definition is `CHAR_BIT', which is defined in the Ansi C header
file "limits.h". */
typedef F_FIXNUM bignum_digit_type;
typedef F_FIXNUM bignum_length_type;
/* BIGNUM_TO_POINTER casts a bignum object to a digit array pointer. */
#define BIGNUM_TO_POINTER(bignum) ((bignum_digit_type *)AREF(bignum,0))
/* BIGNUM_EXCEPTION is invoked to handle assertion violations. */
#define BIGNUM_EXCEPTION abort
#define BIGNUM_DIGIT_LENGTH (((sizeof (bignum_digit_type)) * CHAR_BIT) - 2)
#define BIGNUM_HALF_DIGIT_LENGTH (BIGNUM_DIGIT_LENGTH / 2)
#define BIGNUM_RADIX (((CELL) 1) << BIGNUM_DIGIT_LENGTH)
#define BIGNUM_RADIX_ROOT (((CELL) 1) << BIGNUM_HALF_DIGIT_LENGTH)
#define BIGNUM_DIGIT_MASK (BIGNUM_RADIX - 1)
#define BIGNUM_HALF_DIGIT_MASK (BIGNUM_RADIX_ROOT - 1)
#define BIGNUM_START_PTR(bignum) \
((BIGNUM_TO_POINTER (bignum)) + 1)
#define BIGNUM_LENGTH(bignum) (untag_fixnum_fast((bignum)->capacity) - 1)
#define BIGNUM_NEGATIVE_P(bignum) (get(AREF(bignum,0)) != 0)
#define BIGNUM_SET_NEGATIVE_P(bignum,neg) put(AREF(bignum,0),neg)
#define BIGNUM_ZERO_P(bignum) \
((BIGNUM_LENGTH (bignum)) == 0)
#define BIGNUM_REF(bignum, index) \
(* ((BIGNUM_START_PTR (bignum)) + (index)))
/* These definitions are here to facilitate caching of the constants
0, 1, and -1. */
#define BIGNUM_ZERO() untag_object(bignum_zero)
#define BIGNUM_ONE(neg_p) \
untag_object(neg_p ? bignum_neg_one : bignum_pos_one)
#define HD_LOW(digit) ((digit) & BIGNUM_HALF_DIGIT_MASK)
#define HD_HIGH(digit) ((digit) >> BIGNUM_HALF_DIGIT_LENGTH)
#define HD_CONS(high, low) (((high) << BIGNUM_HALF_DIGIT_LENGTH) | (low))
#define BIGNUM_BITS_TO_DIGITS(n) \
(((n) + (BIGNUM_DIGIT_LENGTH - 1)) / BIGNUM_DIGIT_LENGTH)
#define BIGNUM_DIGITS_FOR(type) \
(BIGNUM_BITS_TO_DIGITS ((sizeof (type)) * CHAR_BIT))
#ifndef BIGNUM_DISABLE_ASSERTION_CHECKS
#define BIGNUM_ASSERT(expression) \
{ \
if (! (expression)) \
BIGNUM_EXCEPTION (); \
}
#endif /* not BIGNUM_DISABLE_ASSERTION_CHECKS */

0
vmpp/bignumint.hpp → vm/bignumint.hpp
View File

13
vm/booleans.c
View File

@ -1,13 +0,0 @@
#include "master.h"
/* FFI calls this */
void box_boolean(bool value)
{
dpush(value ? T : F);
}
/* FFI calls this */
bool to_boolean(CELL value)
{
return value != F;
}

0
vmpp/booleans.cpp → vm/booleans.cpp
View File

7
vm/booleans.h
View File

@ -1,7 +0,0 @@
INLINE CELL tag_boolean(CELL untagged)
{
return (untagged == false ? F : T);
}
DLLEXPORT void box_boolean(bool value);
DLLEXPORT bool to_boolean(CELL value);

0
vmpp/booleans.hpp → vm/booleans.hpp
View File

85
vm/byte_arrays.c
View File

@ -1,85 +0,0 @@
#include "master.h"
/* must fill out array before next GC */
F_BYTE_ARRAY *allot_byte_array_internal(CELL size)
{
F_BYTE_ARRAY *array = allot_object(BYTE_ARRAY_TYPE,
byte_array_size(size));
array->capacity = tag_fixnum(size);
return array;
}
/* size is in bytes this time */
F_BYTE_ARRAY *allot_byte_array(CELL size)
{
F_BYTE_ARRAY *array = allot_byte_array_internal(size);
memset(array + 1,0,size);
return array;
}
/* push a new byte array on the stack */
void primitive_byte_array(void)
{
CELL size = unbox_array_size();
dpush(tag_object(allot_byte_array(size)));
}
void primitive_uninitialized_byte_array(void)
{
CELL size = unbox_array_size();
dpush(tag_object(allot_byte_array_internal(size)));
}
static bool reallot_byte_array_in_place_p(F_BYTE_ARRAY *array, CELL capacity)
{
return in_zone(&nursery,(CELL)array) && capacity <= array_capacity(array);
}
F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity)
{
#ifdef FACTOR_DEBUG
assert(untag_header(array->header) == BYTE_ARRAY_TYPE);
#endif
if(reallot_byte_array_in_place_p(array,capacity))
{
array->capacity = tag_fixnum(capacity);
return array;
}
else
{
CELL to_copy = array_capacity(array);
if(capacity < to_copy)
to_copy = capacity;
REGISTER_UNTAGGED(array);
F_BYTE_ARRAY *new_array = allot_byte_array_internal(capacity);
UNREGISTER_UNTAGGED(array);
memcpy(new_array + 1,array + 1,to_copy);
return new_array;
}
}
void primitive_resize_byte_array(void)
{
F_BYTE_ARRAY* array = untag_byte_array(dpop());
CELL capacity = unbox_array_size();
dpush(tag_object(reallot_byte_array(array,capacity)));
}
void growable_byte_array_append(F_GROWABLE_BYTE_ARRAY *array, void *elts, CELL len)
{
CELL new_size = array->count + len;
F_BYTE_ARRAY *underlying = untag_object(array->array);
if(new_size >= byte_array_capacity(underlying))
{
underlying = reallot_byte_array(underlying,new_size * 2);
array->array = tag_object(underlying);
}
memcpy((void *)BREF(underlying,array->count),elts,len);
array->count += len;
}

0
vmpp/byte_arrays.cpp → vm/byte_arrays.cpp
View File

40
vm/byte_arrays.h
View File

@ -1,40 +0,0 @@
DEFINE_UNTAG(F_BYTE_ARRAY,BYTE_ARRAY_TYPE,byte_array)
INLINE CELL byte_array_capacity(F_BYTE_ARRAY *array)
{
return untag_fixnum_fast(array->capacity);
}
INLINE CELL byte_array_size(CELL size)
{
return sizeof(F_BYTE_ARRAY) + size;
}
F_BYTE_ARRAY *allot_byte_array(CELL size);
F_BYTE_ARRAY *allot_byte_array_internal(CELL size);
F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity);
void primitive_byte_array(void);
void primitive_uninitialized_byte_array(void);
void primitive_resize_byte_array(void);
/* Macros to simulate a byte vector in C */
typedef struct {
CELL count;
CELL array;
} F_GROWABLE_BYTE_ARRAY;
INLINE F_GROWABLE_BYTE_ARRAY make_growable_byte_array(void)
{
F_GROWABLE_BYTE_ARRAY result;
result.count = 0;
result.array = tag_object(allot_byte_array(100));
return result;
}
void growable_byte_array_append(F_GROWABLE_BYTE_ARRAY *result, void *elts, CELL len);
INLINE void growable_byte_array_trim(F_GROWABLE_BYTE_ARRAY *byte_array)
{
byte_array->array = tag_object(reallot_byte_array(untag_object(byte_array->array),byte_array->count));
}

0
vmpp/byte_arrays.hpp → vm/byte_arrays.hpp
View File

230
vm/callstack.c
View File

@ -1,230 +0,0 @@
#include "master.h"
/* called before entry into Factor code. */
F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom)
{
stack_chain->callstack_bottom = callstack_bottom;
}
void iterate_callstack(CELL top, CELL bottom, CALLSTACK_ITER iterator)
{
F_STACK_FRAME *frame = (F_STACK_FRAME *)bottom - 1;
while((CELL)frame >= top)
{
F_STACK_FRAME *next = frame_successor(frame);
iterator(frame);
frame = next;
}
}
void iterate_callstack_object(F_CALLSTACK *stack, CALLSTACK_ITER iterator)
{
CELL top = (CELL)FIRST_STACK_FRAME(stack);
CELL bottom = top + untag_fixnum_fast(stack->length);
iterate_callstack(top,bottom,iterator);
}
F_CALLSTACK *allot_callstack(CELL size)
{
F_CALLSTACK *callstack = allot_object(
CALLSTACK_TYPE,
callstack_size(size));
callstack->length = tag_fixnum(size);
return callstack;
}
F_STACK_FRAME *fix_callstack_top(F_STACK_FRAME *top, F_STACK_FRAME *bottom)
{
F_STACK_FRAME *frame = bottom - 1;
while(frame >= top)
frame = frame_successor(frame);
return frame + 1;
}
/* We ignore the topmost frame, the one calling 'callstack',
so that set-callstack doesn't get stuck in an infinite loop.
This means that if 'callstack' is called in tail position, we
will have popped a necessary frame... however this word is only
called by continuation implementation, and user code shouldn't
be calling it at all, so we leave it as it is for now. */
F_STACK_FRAME *capture_start(void)
{
F_STACK_FRAME *frame = stack_chain->callstack_bottom - 1;
while(frame >= stack_chain->callstack_top
&& frame_successor(frame) >= stack_chain->callstack_top)
{
frame = frame_successor(frame);
}
return frame + 1;
}
void primitive_callstack(void)
{
F_STACK_FRAME *top = capture_start();
F_STACK_FRAME *bottom = stack_chain->callstack_bottom;
F_FIXNUM size = (CELL)bottom - (CELL)top;
if(size < 0)
size = 0;
F_CALLSTACK *callstack = allot_callstack(size);
memcpy(FIRST_STACK_FRAME(callstack),top,size);
dpush(tag_object(callstack));
}
void primitive_set_callstack(void)
{
F_CALLSTACK *stack = untag_callstack(dpop());
set_callstack(stack_chain->callstack_bottom,
FIRST_STACK_FRAME(stack),
untag_fixnum_fast(stack->length),
memcpy);
/* We cannot return here ... */
critical_error("Bug in set_callstack()",0);
}
F_CODE_BLOCK *frame_code(F_STACK_FRAME *frame)
{
return (F_CODE_BLOCK *)frame->xt - 1;
}
CELL frame_type(F_STACK_FRAME *frame)
{
return frame_code(frame)->block.type;
}
CELL frame_executing(F_STACK_FRAME *frame)
{
F_CODE_BLOCK *compiled = frame_code(frame);
if(compiled->literals == F || !stack_traces_p())
return F;
else
{
F_ARRAY *array = untag_object(compiled->literals);
return array_nth(array,0);
}
}
F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame)
{
if(frame->size == 0)
critical_error("Stack frame has zero size",(CELL)frame);
return (F_STACK_FRAME *)((CELL)frame - frame->size);
}
CELL frame_scan(F_STACK_FRAME *frame)
{
if(frame_type(frame) == QUOTATION_TYPE)
{
CELL quot = frame_executing(frame);
if(quot == F)
return F;
else
{
XT return_addr = FRAME_RETURN_ADDRESS(frame);
XT quot_xt = (XT)(frame_code(frame) + 1);
return tag_fixnum(quot_code_offset_to_scan(
quot,(CELL)(return_addr - quot_xt)));
}
}
else
return F;
}
/* C doesn't have closures... */
static CELL frame_count;
void count_stack_frame(F_STACK_FRAME *frame)
{
frame_count += 2;
}
static CELL frame_index;
static F_ARRAY *array;
void stack_frame_to_array(F_STACK_FRAME *frame)
{
set_array_nth(array,frame_index++,frame_executing(frame));
set_array_nth(array,frame_index++,frame_scan(frame));
}
void primitive_callstack_to_array(void)
{
F_CALLSTACK *stack = untag_callstack(dpop());
frame_count = 0;
iterate_callstack_object(stack,count_stack_frame);
REGISTER_UNTAGGED(stack);
array = allot_array_internal(ARRAY_TYPE,frame_count);
UNREGISTER_UNTAGGED(stack);
frame_index = 0;
iterate_callstack_object(stack,stack_frame_to_array);
dpush(tag_array(array));
}
F_STACK_FRAME *innermost_stack_frame(F_CALLSTACK *callstack)
{
F_STACK_FRAME *top = FIRST_STACK_FRAME(callstack);
CELL bottom = (CELL)top + untag_fixnum_fast(callstack->length);
F_STACK_FRAME *frame = (F_STACK_FRAME *)bottom - 1;
while(frame >= top && frame_successor(frame) >= top)
frame = frame_successor(frame);
return frame;
}
/* Some primitives implementing a limited form of callstack mutation.
Used by the single stepper. */
void primitive_innermost_stack_frame_quot(void)
{
F_STACK_FRAME *inner = innermost_stack_frame(
untag_callstack(dpop()));
type_check(QUOTATION_TYPE,frame_executing(inner));
dpush(frame_executing(inner));
}
void primitive_innermost_stack_frame_scan(void)
{
F_STACK_FRAME *inner = innermost_stack_frame(
untag_callstack(dpop()));
type_check(QUOTATION_TYPE,frame_executing(inner));
dpush(frame_scan(inner));
}
void primitive_set_innermost_stack_frame_quot(void)
{
F_CALLSTACK *callstack = untag_callstack(dpop());
F_QUOTATION *quot = untag_quotation(dpop());
REGISTER_UNTAGGED(callstack);
REGISTER_UNTAGGED(quot);
jit_compile(tag_quotation(quot),true);
UNREGISTER_UNTAGGED(quot);
UNREGISTER_UNTAGGED(callstack);
F_STACK_FRAME *inner = innermost_stack_frame(callstack);
type_check(QUOTATION_TYPE,frame_executing(inner));
CELL offset = FRAME_RETURN_ADDRESS(inner) - inner->xt;
inner->xt = quot->xt;
FRAME_RETURN_ADDRESS(inner) = quot->xt + offset;
}

0
vmpp/callstack.cpp → vm/callstack.cpp
View File

28
vm/callstack.h
View File

@ -1,28 +0,0 @@
INLINE CELL callstack_size(CELL size)
{
return sizeof(F_CALLSTACK) + size;
}
DEFINE_UNTAG(F_CALLSTACK,CALLSTACK_TYPE,callstack)
F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom);
#define FIRST_STACK_FRAME(stack) (F_STACK_FRAME *)((stack) + 1)
typedef void (*CALLSTACK_ITER)(F_STACK_FRAME *frame);
F_STACK_FRAME *fix_callstack_top(F_STACK_FRAME *top, F_STACK_FRAME *bottom);
void iterate_callstack(CELL top, CELL bottom, CALLSTACK_ITER iterator);
void iterate_callstack_object(F_CALLSTACK *stack, CALLSTACK_ITER iterator);
F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame);
F_CODE_BLOCK *frame_code(F_STACK_FRAME *frame);
CELL frame_executing(F_STACK_FRAME *frame);
CELL frame_scan(F_STACK_FRAME *frame);
CELL frame_type(F_STACK_FRAME *frame);
void primitive_callstack(void);
void primitive_set_callstack(void);
void primitive_callstack_to_array(void);
void primitive_innermost_stack_frame_quot(void);
void primitive_innermost_stack_frame_scan(void);
void primitive_set_innermost_stack_frame_quot(void);

0
vmpp/callstack.hpp → vm/callstack.hpp
View File

506
vm/code_block.c
View File

@ -1,506 +0,0 @@
#include "master.h"
void flush_icache_for(F_CODE_BLOCK *block)
{
flush_icache((CELL)block,block->block.size);
}
void iterate_relocations(F_CODE_BLOCK *compiled, RELOCATION_ITERATOR iter)
{
if(compiled->relocation != F)
{
F_BYTE_ARRAY *relocation = untag_object(compiled->relocation);
CELL index = stack_traces_p() ? 1 : 0;
F_REL *rel = (F_REL *)(relocation + 1);
F_REL *rel_end = (F_REL *)((char *)rel + byte_array_capacity(relocation));
while(rel < rel_end)
{
iter(*rel,index,compiled);
switch(REL_TYPE(*rel))
{
case RT_PRIMITIVE:
case RT_XT:
case RT_XT_DIRECT:
case RT_IMMEDIATE:
case RT_HERE:
case RT_UNTAGGED:
index++;
break;
case RT_DLSYM:
index += 2;
break;
case RT_THIS:
case RT_STACK_CHAIN:
break;
default:
critical_error("Bad rel type",*rel);
return; /* Can't happen */
}
rel++;
}
}
}
/* Store a 32-bit value into a PowerPC LIS/ORI sequence */
INLINE void store_address_2_2(CELL cell, CELL value)
{
put(cell - CELLS,((get(cell - CELLS) & ~0xffff) | ((value >> 16) & 0xffff)));
put(cell,((get(cell) & ~0xffff) | (value & 0xffff)));
}
/* Store a value into a bitfield of a PowerPC instruction */
INLINE void store_address_masked(CELL cell, F_FIXNUM value, CELL mask, F_FIXNUM shift)
{
/* This is unaccurate but good enough */
F_FIXNUM test = (F_FIXNUM)mask >> 1;
if(value <= -test || value >= test)
critical_error("Value does not fit inside relocation",0);
u32 original = *(u32*)cell;
original &= ~mask;
*(u32*)cell = (original | ((value >> shift) & mask));
}
/* Perform a fixup on a code block */
void store_address_in_code_block(CELL class, CELL offset, F_FIXNUM absolute_value)
{
F_FIXNUM relative_value = absolute_value - offset;
switch(class)
{
case RC_ABSOLUTE_CELL:
put(offset,absolute_value);
break;
case RC_ABSOLUTE:
*(u32*)offset = absolute_value;
break;
case RC_RELATIVE:
*(u32*)offset = relative_value - sizeof(u32);
break;
case RC_ABSOLUTE_PPC_2_2:
store_address_2_2(offset,absolute_value);
break;
case RC_RELATIVE_PPC_2:
store_address_masked(offset,relative_value,REL_RELATIVE_PPC_2_MASK,0);
break;
case RC_RELATIVE_PPC_3:
store_address_masked(offset,relative_value,REL_RELATIVE_PPC_3_MASK,0);
break;
case RC_RELATIVE_ARM_3:
store_address_masked(offset,relative_value - CELLS * 2,
REL_RELATIVE_ARM_3_MASK,2);
break;
case RC_INDIRECT_ARM:
store_address_masked(offset,relative_value - CELLS,
REL_INDIRECT_ARM_MASK,0);
break;
case RC_INDIRECT_ARM_PC:
store_address_masked(offset,relative_value - CELLS * 2,
REL_INDIRECT_ARM_MASK,0);
break;
default:
critical_error("Bad rel class",class);
break;
}
}
void update_literal_references_step(F_REL rel, CELL index, F_CODE_BLOCK *compiled)
{
if(REL_TYPE(rel) == RT_IMMEDIATE)
{
CELL offset = REL_OFFSET(rel) + (CELL)(compiled + 1);
F_ARRAY *literals = untag_object(compiled->literals);
F_FIXNUM absolute_value = array_nth(literals,index);
store_address_in_code_block(REL_CLASS(rel),offset,absolute_value);
}
}
/* Update pointers to literals from compiled code. */
void update_literal_references(F_CODE_BLOCK *compiled)
{
iterate_relocations(compiled,update_literal_references_step);
flush_icache_for(compiled);
}
/* Copy all literals referenced from a code block to newspace. Only for
aging and nursery collections */
void copy_literal_references(F_CODE_BLOCK *compiled)
{
if(collecting_gen >= compiled->block.last_scan)
{
if(collecting_accumulation_gen_p())
compiled->block.last_scan = collecting_gen;
else
compiled->block.last_scan = collecting_gen + 1;
/* initialize chase pointer */
CELL scan = newspace->here;
copy_handle(&compiled->literals);
copy_handle(&compiled->relocation);
/* do some tracing so that all reachable literals are now
at their final address */
copy_reachable_objects(scan,&newspace->here);
update_literal_references(compiled);
}
}
CELL object_xt(CELL obj)
{
if(TAG(obj) == QUOTATION_TYPE)
{
F_QUOTATION *quot = untag_object(obj);
return (CELL)quot->xt;
}
else
{
F_WORD *word = untag_object(obj);
return (CELL)word->xt;
}
}
CELL word_direct_xt(CELL obj)
{
#ifdef FACTOR_DEBUG
type_check(WORD_TYPE,obj);
#endif
F_WORD *word = untag_object(obj);
CELL quot = word->direct_entry_def;
if(quot == F || max_pic_size == 0)
return (CELL)word->xt;
else
{
F_QUOTATION *untagged = untag_object(quot);
#ifdef FACTOR_DEBUG
type_check(QUOTATION_TYPE,quot);
#endif
if(untagged->compiledp == F)
return (CELL)word->xt;
else
return (CELL)untagged->xt;
}
}
void update_word_references_step(F_REL rel, CELL index, F_CODE_BLOCK *compiled)
{
F_RELTYPE type = REL_TYPE(rel);
if(type == RT_XT || type == RT_XT_DIRECT)
{
CELL offset = REL_OFFSET(rel) + (CELL)(compiled + 1);
F_ARRAY *literals = untag_object(compiled->literals);
CELL obj = array_nth(literals,index);
CELL xt;
if(type == RT_XT)
xt = object_xt(obj);
else
xt = word_direct_xt(obj);
store_address_in_code_block(REL_CLASS(rel),offset,xt);
}
}
/* Relocate new code blocks completely; updating references to literals,
dlsyms, and words. For all other words in the code heap, we only need
to update references to other words, without worrying about literals
or dlsyms. */
void update_word_references(F_CODE_BLOCK *compiled)
{
if(compiled->block.needs_fixup)
relocate_code_block(compiled);
/* update_word_references() is always applied to every block in
the code heap. Since it resets all call sites to point to
their canonical XT (cold entry point for non-tail calls,
standard entry point for tail calls), it means that no PICs
are referenced after this is done. So instead of polluting
the code heap with dead PICs that will be freed on the next
GC, we add them to the free list immediately. */
else if(compiled->block.type == PIC_TYPE)
{
fflush(stdout);
heap_free(&code_heap,&compiled->block);
}
else
{
iterate_relocations(compiled,update_word_references_step);
flush_icache_for(compiled);
}
}
void update_literal_and_word_references(F_CODE_BLOCK *compiled)
{
update_literal_references(compiled);
update_word_references(compiled);
}
INLINE void check_code_address(CELL address)
{
#ifdef FACTOR_DEBUG
assert(address >= code_heap.segment->start && address < code_heap.segment->end);
#endif
}
/* Update references to words. This is done after a new code block
is added to the heap. */
/* Mark all literals referenced from a word XT. Only for tenured
collections */
void mark_code_block(F_CODE_BLOCK *compiled)
{
check_code_address((CELL)compiled);
mark_block(&compiled->block);
copy_handle(&compiled->literals);
copy_handle(&compiled->relocation);
}
void mark_stack_frame_step(F_STACK_FRAME *frame)
{
mark_code_block(frame_code(frame));
}
/* Mark code blocks executing in currently active stack frames. */
void mark_active_blocks(F_CONTEXT *stacks)
{
if(collecting_gen == TENURED)
{
CELL top = (CELL)stacks->callstack_top;
CELL bottom = (CELL)stacks->callstack_bottom;
iterate_callstack(top,bottom,mark_stack_frame_step);
}
}
void mark_object_code_block(CELL scan)
{
F_WORD *word;
F_QUOTATION *quot;
F_CALLSTACK *stack;
switch(hi_tag(scan))
{
case WORD_TYPE:
word = (F_WORD *)scan;
if(word->code)
mark_code_block(word->code);
if(word->profiling)
mark_code_block(word->profiling);
break;
case QUOTATION_TYPE:
quot = (F_QUOTATION *)scan;
if(quot->compiledp != F)
mark_code_block(quot->code);
break;
case CALLSTACK_TYPE:
stack = (F_CALLSTACK *)scan;
iterate_callstack_object(stack,mark_stack_frame_step);
break;
}
}
/* References to undefined symbols are patched up to call this function on
image load */
void undefined_symbol(void)
{
general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL);
}
/* Look up an external library symbol referenced by a compiled code block */
void *get_rel_symbol(F_ARRAY *literals, CELL index)
{
CELL symbol = array_nth(literals,index);
CELL library = array_nth(literals,index + 1);
F_DLL *dll = (library == F ? NULL : untag_dll(library));
if(dll != NULL && !dll->dll)
return undefined_symbol;
if(type_of(symbol) == BYTE_ARRAY_TYPE)
{
F_SYMBOL *name = alien_offset(symbol);
void *sym = ffi_dlsym(dll,name);
if(sym)
return sym;
}
else if(type_of(symbol) == ARRAY_TYPE)
{
CELL i;
F_ARRAY *names = untag_object(symbol);
for(i = 0; i < array_capacity(names); i++)
{
F_SYMBOL *name = alien_offset(array_nth(names,i));
void *sym = ffi_dlsym(dll,name);
if(sym)
return sym;
}
}
return undefined_symbol;
}
/* Compute an address to store at a relocation */
void relocate_code_block_step(F_REL rel, CELL index, F_CODE_BLOCK *compiled)
{
#ifdef FACTOR_DEBUG
type_check(ARRAY_TYPE,compiled->literals);
type_check(BYTE_ARRAY_TYPE,compiled->relocation);
#endif
CELL offset = REL_OFFSET(rel) + (CELL)(compiled + 1);
F_ARRAY *literals = untag_object(compiled->literals);
F_FIXNUM absolute_value;
switch(REL_TYPE(rel))
{
case RT_PRIMITIVE:
absolute_value = (CELL)primitives[to_fixnum(array_nth(literals,index))];
break;
case RT_DLSYM:
absolute_value = (CELL)get_rel_symbol(literals,index);
break;
case RT_IMMEDIATE:
absolute_value = array_nth(literals,index);
break;
case RT_XT:
absolute_value = object_xt(array_nth(literals,index));
break;
case RT_XT_DIRECT:
absolute_value = word_direct_xt(array_nth(literals,index));
break;
case RT_HERE:
absolute_value = offset + (short)to_fixnum(array_nth(literals,index));
break;
case RT_THIS:
absolute_value = (CELL)(compiled + 1);
break;
case RT_STACK_CHAIN:
absolute_value = (CELL)&stack_chain;
break;
case RT_UNTAGGED:
absolute_value = to_fixnum(array_nth(literals,index));
break;
default:
critical_error("Bad rel type",rel);
return; /* Can't happen */
}
store_address_in_code_block(REL_CLASS(rel),offset,absolute_value);
}
/* Perform all fixups on a code block */
void relocate_code_block(F_CODE_BLOCK *compiled)
{
compiled->block.last_scan = NURSERY;
compiled->block.needs_fixup = false;
iterate_relocations(compiled,relocate_code_block_step);
flush_icache_for(compiled);
}
/* Fixup labels. This is done at compile time, not image load time */
void fixup_labels(F_ARRAY *labels, F_CODE_BLOCK *compiled)
{
CELL i;
CELL size = array_capacity(labels);
for(i = 0; i < size; i += 3)
{
CELL class = to_fixnum(array_nth(labels,i));
CELL offset = to_fixnum(array_nth(labels,i + 1));
CELL target = to_fixnum(array_nth(labels,i + 2));
store_address_in_code_block(class,
offset + (CELL)(compiled + 1),
target + (CELL)(compiled + 1));
}
}
/* Might GC */
F_CODE_BLOCK *allot_code_block(CELL size)
{
F_BLOCK *block = heap_allot(&code_heap,size + sizeof(F_CODE_BLOCK));
/* If allocation failed, do a code GC */
if(block == NULL)
{
gc();
block = heap_allot(&code_heap,size + sizeof(F_CODE_BLOCK));
/* Insufficient room even after code GC, give up */
if(block == NULL)
{
CELL used, total_free, max_free;
heap_usage(&code_heap,&used,&total_free,&max_free);
print_string("Code heap stats:\n");
print_string("Used: "); print_cell(used); nl();
print_string("Total free space: "); print_cell(total_free); nl();
print_string("Largest free block: "); print_cell(max_free); nl();
fatal_error("Out of memory in add-compiled-block",0);
}
}
return (F_CODE_BLOCK *)block;
}
/* Might GC */
F_CODE_BLOCK *add_code_block(
CELL type,
F_BYTE_ARRAY *code,
F_ARRAY *labels,
CELL relocation,
CELL literals)
{
#ifdef FACTOR_DEBUG
type_check(ARRAY_TYPE,literals);
type_check(BYTE_ARRAY_TYPE,relocation);
assert(untag_header(code->header) == BYTE_ARRAY_TYPE);
#endif
CELL code_length = align8(array_capacity(code));
REGISTER_ROOT(literals);
REGISTER_ROOT(relocation);
REGISTER_UNTAGGED(code);
REGISTER_UNTAGGED(labels);
F_CODE_BLOCK *compiled = allot_code_block(code_length);
UNREGISTER_UNTAGGED(labels);
UNREGISTER_UNTAGGED(code);
UNREGISTER_ROOT(relocation);
UNREGISTER_ROOT(literals);
/* slight space optimization */
if(type_of(literals) == ARRAY_TYPE && array_capacity(untag_object(literals)) == 0)
literals = F;
/* compiled header */
compiled->block.type = type;
compiled->block.last_scan = NURSERY;
compiled->block.needs_fixup = true;
compiled->literals = literals;
compiled->relocation = relocation;
/* code */
memcpy(compiled + 1,code + 1,code_length);
/* fixup labels */
if(labels) fixup_labels(labels,compiled);
/* next time we do a minor GC, we have to scan the code heap for
literals */
last_code_heap_scan = NURSERY;
return compiled;
}

0
vmpp/code_block.cpp → vm/code_block.cpp
View File

92
vm/code_block.h
View File

@ -1,92 +0,0 @@
typedef enum {
/* arg is a primitive number */
RT_PRIMITIVE,
/* arg is a literal table index, holding an array pair (symbol/dll) */
RT_DLSYM,
/* a pointer to a compiled word reference */
RT_DISPATCH,
/* a word's general entry point XT */
RT_XT,
/* a word's direct entry point XT */
RT_XT_DIRECT,
/* current offset */
RT_HERE,
/* current code block */
RT_THIS,
/* immediate literal */
RT_IMMEDIATE,
/* address of stack_chain var */
RT_STACK_CHAIN,
/* untagged fixnum literal */
RT_UNTAGGED,
} F_RELTYPE;
typedef enum {
/* absolute address in a 64-bit location */
RC_ABSOLUTE_CELL,
/* absolute address in a 32-bit location */
RC_ABSOLUTE,
/* relative address in a 32-bit location */
RC_RELATIVE,
/* relative address in a PowerPC LIS/ORI sequence */
RC_ABSOLUTE_PPC_2_2,
/* relative address in a PowerPC LWZ/STW/BC instruction */
RC_RELATIVE_PPC_2,
/* relative address in a PowerPC B/BL instruction */
RC_RELATIVE_PPC_3,
/* relative address in an ARM B/BL instruction */
RC_RELATIVE_ARM_3,
/* pointer to address in an ARM LDR/STR instruction */
RC_INDIRECT_ARM,
/* pointer to address in an ARM LDR/STR instruction offset by 8 bytes */
RC_INDIRECT_ARM_PC
} F_RELCLASS;
#define REL_RELATIVE_PPC_2_MASK 0xfffc
#define REL_RELATIVE_PPC_3_MASK 0x3fffffc
#define REL_INDIRECT_ARM_MASK 0xfff
#define REL_RELATIVE_ARM_3_MASK 0xffffff
/* code relocation table consists of a table of entries for each fixup */
typedef u32 F_REL;
#define REL_TYPE(r) (((r) & 0xf0000000) >> 28)
#define REL_CLASS(r) (((r) & 0x0f000000) >> 24)
#define REL_OFFSET(r) ((r) & 0x00ffffff)
void flush_icache_for(F_CODE_BLOCK *compiled);
typedef void (*RELOCATION_ITERATOR)(F_REL rel, CELL index, F_CODE_BLOCK *compiled);
void iterate_relocations(F_CODE_BLOCK *compiled, RELOCATION_ITERATOR iter);
void store_address_in_code_block(CELL class, CELL offset, F_FIXNUM absolute_value);
void relocate_code_block(F_CODE_BLOCK *compiled);
void update_literal_references(F_CODE_BLOCK *compiled);
void copy_literal_references(F_CODE_BLOCK *compiled);
void update_word_references(F_CODE_BLOCK *compiled);
void update_literal_and_word_references(F_CODE_BLOCK *compiled);
void mark_code_block(F_CODE_BLOCK *compiled);
void mark_active_blocks(F_CONTEXT *stacks);
void mark_object_code_block(CELL scan);
void relocate_code_block(F_CODE_BLOCK *relocating);
INLINE bool stack_traces_p(void)
{
return userenv[STACK_TRACES_ENV] != F;
}
F_CODE_BLOCK *add_code_block(
CELL type,
F_BYTE_ARRAY *code,
F_ARRAY *labels,
CELL relocation,
CELL literals);

0
vmpp/code_block.hpp → vm/code_block.hpp
View File

336
vm/code_gc.c
View File

@ -1,336 +0,0 @@
#include "master.h"
static void clear_free_list(F_HEAP *heap)
{
memset(&heap->free,0,sizeof(F_HEAP_FREE_LIST));
}
/* This malloc-style heap code is reasonably generic. Maybe in the future, it
will be used for the data heap too, if we ever get incremental
mark/sweep/compact GC. */
void new_heap(F_HEAP *heap, CELL size)
{
heap->segment = alloc_segment(align_page(size));
if(!heap->segment)
fatal_error("Out of memory in new_heap",size);
clear_free_list(heap);
}
static void add_to_free_list(F_HEAP *heap, F_FREE_BLOCK *block)
{
if(block->block.size < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT)
{
int index = block->block.size / BLOCK_SIZE_INCREMENT;
block->next_free = heap->free.small_blocks[index];
heap->free.small_blocks[index] = block;
}
else
{
block->next_free = heap->free.large_blocks;
heap->free.large_blocks = block;
}
}
/* Called after reading the code heap from the image file, and after code GC.
In the former case, we must add a large free block from compiling.base + size to
compiling.limit. */
void build_free_list(F_HEAP *heap, CELL size)
{
F_BLOCK *prev = NULL;
clear_free_list(heap);
size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1);
F_BLOCK *scan = first_block(heap);
F_FREE_BLOCK *end = (F_FREE_BLOCK *)(heap->segment->start + size);
/* Add all free blocks to the free list */
while(scan && scan < (F_BLOCK *)end)
{
switch(scan->status)
{
case B_FREE:
add_to_free_list(heap,(F_FREE_BLOCK *)scan);
break;
case B_ALLOCATED:
break;
default:
critical_error("Invalid scan->status",(CELL)scan);
break;
}
prev = scan;
scan = next_block(heap,scan);
}
/* If there is room at the end of the heap, add a free block. This
branch is only taken after loading a new image, not after code GC */
if((CELL)(end + 1) <= heap->segment->end)
{
end->block.status = B_FREE;
end->block.size = heap->segment->end - (CELL)end;
/* add final free block */
add_to_free_list(heap,end);
}
/* This branch is taken if the newly loaded image fits exactly, or
after code GC */
else
{
/* even if there's no room at the end of the heap for a new
free block, we might have to jigger it up by a few bytes in
case prev + prev->size */
if(prev) prev->size = heap->segment->end - (CELL)prev;
}
}
static void assert_free_block(F_FREE_BLOCK *block)
{
if(block->block.status != B_FREE)
critical_error("Invalid block in free list",(CELL)block);
}
static F_FREE_BLOCK *find_free_block(F_HEAP *heap, CELL size)
{
CELL attempt = size;
while(attempt < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT)
{
int index = attempt / BLOCK_SIZE_INCREMENT;
F_FREE_BLOCK *block = heap->free.small_blocks[index];
if(block)
{
assert_free_block(block);
heap->free.small_blocks[index] = block->next_free;
return block;
}
attempt *= 2;
}
F_FREE_BLOCK *prev = NULL;
F_FREE_BLOCK *block = heap->free.large_blocks;
while(block)
{
assert_free_block(block);
if(block->block.size >= size)
{
if(prev)
prev->next_free = block->next_free;
else
heap->free.large_blocks = block->next_free;
return block;
}
prev = block;
block = block->next_free;
}
return NULL;
}
static F_FREE_BLOCK *split_free_block(F_HEAP *heap, F_FREE_BLOCK *block, CELL size)
{
if(block->block.size != size )
{
/* split the block in two */
F_FREE_BLOCK *split = (F_FREE_BLOCK *)((CELL)block + size);
split->block.status = B_FREE;
split->block.size = block->block.size - size;
split->next_free = block->next_free;
block->block.size = size;
add_to_free_list(heap,split);
}
return block;
}
/* Allocate a block of memory from the mark and sweep GC heap */
F_BLOCK *heap_allot(F_HEAP *heap, CELL size)
{
size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1);
F_FREE_BLOCK *block = find_free_block(heap,size);
if(block)
{
block = split_free_block(heap,block,size);
block->block.status = B_ALLOCATED;
return &block->block;
}
else
return NULL;
}
/* Deallocates a block manually */
void heap_free(F_HEAP *heap, F_BLOCK *block)
{
block->status = B_FREE;
add_to_free_list(heap,(F_FREE_BLOCK *)block);
}
void mark_block(F_BLOCK *block)
{
/* If already marked, do nothing */
switch(block->status)
{
case B_MARKED:
return;
case B_ALLOCATED:
block->status = B_MARKED;
break;
default:
critical_error("Marking the wrong block",(CELL)block);
break;
}
}
/* If in the middle of code GC, we have to grow the heap, data GC restarts from
scratch, so we have to unmark any marked blocks. */
void unmark_marked(F_HEAP *heap)
{
F_BLOCK *scan = first_block(heap);
while(scan)
{
if(scan->status == B_MARKED)
scan->status = B_ALLOCATED;
scan = next_block(heap,scan);
}
}
/* After code GC, all referenced code blocks have status set to B_MARKED, so any
which are allocated and not marked can be reclaimed. */
void free_unmarked(F_HEAP *heap, HEAP_ITERATOR iter)
{
clear_free_list(heap);
F_BLOCK *prev = NULL;
F_BLOCK *scan = first_block(heap);
while(scan)
{
switch(scan->status)
{
case B_ALLOCATED:
if(secure_gc)
memset(scan + 1,0,scan->size - sizeof(F_BLOCK));
if(prev && prev->status == B_FREE)
prev->size += scan->size;
else
{
scan->status = B_FREE;
prev = scan;
}
break;
case B_FREE:
if(prev && prev->status == B_FREE)
prev->size += scan->size;
else
prev = scan;
break;
case B_MARKED:
if(prev && prev->status == B_FREE)
add_to_free_list(heap,(F_FREE_BLOCK *)prev);
scan->status = B_ALLOCATED;
prev = scan;
iter(scan);
break;
default:
critical_error("Invalid scan->status",(CELL)scan);
}
scan = next_block(heap,scan);
}
if(prev && prev->status == B_FREE)
add_to_free_list(heap,(F_FREE_BLOCK *)prev);
}
/* Compute total sum of sizes of free blocks, and size of largest free block */
void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free)
{
*used = 0;
*total_free = 0;
*max_free = 0;
F_BLOCK *scan = first_block(heap);
while(scan)
{
switch(scan->status)
{
case B_ALLOCATED:
*used += scan->size;
break;
case B_FREE:
*total_free += scan->size;
if(scan->size > *max_free)
*max_free = scan->size;
break;
default:
critical_error("Invalid scan->status",(CELL)scan);
}
scan = next_block(heap,scan);
}
}
/* The size of the heap, not including the last block if it's free */
CELL heap_size(F_HEAP *heap)
{
F_BLOCK *scan = first_block(heap);
while(next_block(heap,scan) != NULL)
scan = next_block(heap,scan);
/* this is the last block in the heap, and it is free */
if(scan->status == B_FREE)
return (CELL)scan - heap->segment->start;
/* otherwise the last block is allocated */
else
return heap->segment->size;
}
/* Compute where each block is going to go, after compaction */
CELL compute_heap_forwarding(F_HEAP *heap)
{
F_BLOCK *scan = first_block(heap);
CELL address = (CELL)first_block(heap);
while(scan)
{
if(scan->status == B_ALLOCATED)
{
scan->forwarding = (F_BLOCK *)address;
address += scan->size;
}
else if(scan->status == B_MARKED)
critical_error("Why is the block marked?",0);
scan = next_block(heap,scan);
}
return address - heap->segment->start;
}
void compact_heap(F_HEAP *heap)
{
F_BLOCK *scan = first_block(heap);
while(scan)
{
F_BLOCK *next = next_block(heap,scan);
if(scan->status == B_ALLOCATED && scan != scan->forwarding)
memcpy(scan->forwarding,scan,scan->size);
scan = next;
}
}

0
vmpp/code_gc.cpp → vm/code_gc.cpp
View File

45
vm/code_gc.h
View File

@ -1,45 +0,0 @@
#define FREE_LIST_COUNT 16
#define BLOCK_SIZE_INCREMENT 32
typedef struct {
F_FREE_BLOCK *small_blocks[FREE_LIST_COUNT];
F_FREE_BLOCK *large_blocks;
} F_HEAP_FREE_LIST;
typedef struct {
F_SEGMENT *segment;
F_HEAP_FREE_LIST free;
} F_HEAP;
typedef void (*HEAP_ITERATOR)(F_BLOCK *compiled);
void new_heap(F_HEAP *heap, CELL size);
void build_free_list(F_HEAP *heap, CELL size);
F_BLOCK *heap_allot(F_HEAP *heap, CELL size);
void heap_free(F_HEAP *heap, F_BLOCK *block);
void mark_block(F_BLOCK *block);
void unmark_marked(F_HEAP *heap);
void free_unmarked(F_HEAP *heap, HEAP_ITERATOR iter);
void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free);
CELL heap_size(F_HEAP *heap);
CELL compute_heap_forwarding(F_HEAP *heap);
void compact_heap(F_HEAP *heap);
INLINE F_BLOCK *next_block(F_HEAP *heap, F_BLOCK *block)
{
CELL next = ((CELL)block + block->size);
if(next == heap->segment->end)
return NULL;
else
return (F_BLOCK *)next;
}
INLINE F_BLOCK *first_block(F_HEAP *heap)
{
return (F_BLOCK *)heap->segment->start;
}
INLINE F_BLOCK *last_block(F_HEAP *heap)
{
return (F_BLOCK *)heap->segment->end;
}

0
vmpp/code_gc.hpp → vm/code_gc.hpp
View File

226
vm/code_heap.c
View File

@ -1,226 +0,0 @@
#include "master.h"
/* Allocate a code heap during startup */
void init_code_heap(CELL size)
{
new_heap(&code_heap,size);
}
bool in_code_heap_p(CELL ptr)
{
return (ptr >= code_heap.segment->start
&& ptr <= code_heap.segment->end);
}
/* Compile a word definition with the non-optimizing compiler. Allocates memory */
void jit_compile_word(F_WORD *word, CELL def, bool relocate)
{
REGISTER_ROOT(def);
REGISTER_UNTAGGED(word);
jit_compile(def,relocate);
UNREGISTER_UNTAGGED(word);
UNREGISTER_ROOT(def);
word->code = untag_quotation(def)->code;
if(word->direct_entry_def != F)
jit_compile(word->direct_entry_def,relocate);
}
/* Apply a function to every code block */
void iterate_code_heap(CODE_HEAP_ITERATOR iter)
{
F_BLOCK *scan = first_block(&code_heap);
while(scan)
{
if(scan->status != B_FREE)
iter((F_CODE_BLOCK *)scan);
scan = next_block(&code_heap,scan);
}
}
/* Copy literals referenced from all code blocks to newspace. Only for
aging and nursery collections */
void copy_code_heap_roots(void)
{
iterate_code_heap(copy_literal_references);
}
/* Update pointers to words referenced from all code blocks. Only after
defining a new word. */
void update_code_heap_words(void)
{
iterate_code_heap(update_word_references);
}
void primitive_modify_code_heap(void)
{
F_ARRAY *alist = untag_array(dpop());
CELL count = untag_fixnum_fast(alist->capacity);
if(count == 0)
return;
CELL i;
for(i = 0; i < count; i++)
{
F_ARRAY *pair = untag_array(array_nth(alist,i));
F_WORD *word = untag_word(array_nth(pair,0));
CELL data = array_nth(pair,1);
if(type_of(data) == QUOTATION_TYPE)
{
REGISTER_UNTAGGED(alist);
REGISTER_UNTAGGED(word);
jit_compile_word(word,data,false);
UNREGISTER_UNTAGGED(word);
UNREGISTER_UNTAGGED(alist);
}
else if(type_of(data) == ARRAY_TYPE)
{
F_ARRAY *compiled_code = untag_array(data);
CELL literals = array_nth(compiled_code,0);
CELL relocation = array_nth(compiled_code,1);
F_ARRAY *labels = untag_array(array_nth(compiled_code,2));
F_BYTE_ARRAY *code = untag_byte_array(array_nth(compiled_code,3));
REGISTER_UNTAGGED(alist);
REGISTER_UNTAGGED(word);
F_CODE_BLOCK *compiled = add_code_block(
WORD_TYPE,
code,
labels,
relocation,
literals);
UNREGISTER_UNTAGGED(word);
UNREGISTER_UNTAGGED(alist);
word->code = compiled;
}
else
critical_error("Expected a quotation or an array",data);
REGISTER_UNTAGGED(alist);
update_word_xt(word);
UNREGISTER_UNTAGGED(alist);
}
update_code_heap_words();
}
/* Push the free space and total size of the code heap */
void primitive_code_room(void)
{
CELL used, total_free, max_free;
heap_usage(&code_heap,&used,&total_free,&max_free);
dpush(tag_fixnum((code_heap.segment->size) / 1024));
dpush(tag_fixnum(used / 1024));
dpush(tag_fixnum(total_free / 1024));
dpush(tag_fixnum(max_free / 1024));
}
F_CODE_BLOCK *forward_xt(F_CODE_BLOCK *compiled)
{
return (F_CODE_BLOCK *)compiled->block.forwarding;
}
void forward_frame_xt(F_STACK_FRAME *frame)
{
CELL offset = (CELL)FRAME_RETURN_ADDRESS(frame) - (CELL)frame_code(frame);
F_CODE_BLOCK *forwarded = forward_xt(frame_code(frame));
frame->xt = (XT)(forwarded + 1);
FRAME_RETURN_ADDRESS(frame) = (XT)((CELL)forwarded + offset);
}
void forward_object_xts(void)
{
begin_scan();
CELL obj;
while((obj = next_object()) != F)
{
if(type_of(obj) == WORD_TYPE)
{
F_WORD *word = untag_object(obj);
word->code = forward_xt(word->code);
if(word->profiling)
word->profiling = forward_xt(word->profiling);
}
else if(type_of(obj) == QUOTATION_TYPE)
{
F_QUOTATION *quot = untag_object(obj);
if(quot->compiledp != F)
quot->code = forward_xt(quot->code);
}
else if(type_of(obj) == CALLSTACK_TYPE)
{
F_CALLSTACK *stack = untag_object(obj);
iterate_callstack_object(stack,forward_frame_xt);
}
}
/* End the heap scan */
gc_off = false;
}
/* Set the XT fields now that the heap has been compacted */
void fixup_object_xts(void)
{
begin_scan();
CELL obj;
while((obj = next_object()) != F)
{
if(type_of(obj) == WORD_TYPE)
{
F_WORD *word = untag_object(obj);
update_word_xt(word);
}
else if(type_of(obj) == QUOTATION_TYPE)
{
F_QUOTATION *quot = untag_object(obj);
if(quot->compiledp != F)
set_quot_xt(quot,quot->code);
}
}
/* End the heap scan */
gc_off = false;
}
/* Move all free space to the end of the code heap. This is not very efficient,
since it makes several passes over the code and data heaps, but we only ever
do this before saving a deployed image and exiting, so performaance is not
critical here */
void compact_code_heap(void)
{
/* Free all unreachable code blocks */
gc();
/* Figure out where the code heap blocks are going to end up */
CELL size = compute_heap_forwarding(&code_heap);
/* Update word and quotation code pointers */
forward_object_xts();
/* Actually perform the compaction */
compact_heap(&code_heap);
/* Update word and quotation XTs */
fixup_object_xts();
/* Now update the free list; there will be a single free block at
the end */
build_free_list(&code_heap,size);
}

0
vmpp/code_heap.cpp → vm/code_heap.cpp
View File

27
vm/code_heap.h
View File

@ -1,27 +0,0 @@
/* compiled code */
F_HEAP code_heap;
void init_code_heap(CELL size);
bool in_code_heap_p(CELL ptr);
void jit_compile_word(F_WORD *word, CELL def, bool relocate);
typedef void (*CODE_HEAP_ITERATOR)(F_CODE_BLOCK *compiled);
void iterate_code_heap(CODE_HEAP_ITERATOR iter);
void copy_code_heap_roots(void);
void primitive_modify_code_heap(void);
void primitive_code_room(void);
void compact_code_heap(void);
INLINE void check_code_pointer(CELL pointer)
{
#ifdef FACTOR_DEBUG
assert(pointer >= code_heap.segment->start && pointer < code_heap.segment->end);
#endif
}

0
vmpp/code_heap.hpp → vm/code_heap.hpp
View File

13
vm/cpu-arm.h
View File

@ -1,13 +0,0 @@
#define FACTOR_CPU_STRING "arm"
register CELL ds asm("r5");
register CELL rs asm("r6");
#define F_FASTCALL
#define FRAME_RETURN_ADDRESS(frame) *(XT *)(frame_successor(frame) + 1)
void c_to_factor(CELL quot);
void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy);
void throw_impl(CELL quot, F_STACK_FRAME *rewind);
void lazy_jit_compile(CELL quot);

0
vmpp/cpu-arm.hpp → vm/cpu-arm.hpp
View File

12
vm/cpu-ppc.h
View File

@ -1,12 +0,0 @@
#define FACTOR_CPU_STRING "ppc"
#define F_FASTCALL
register CELL ds asm("r29");
register CELL rs asm("r30");
void c_to_factor(CELL quot);
void undefined(CELL word);
void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy);
void throw_impl(CELL quot, F_STACK_FRAME *rewind);
void lazy_jit_compile(CELL quot);
void flush_icache(CELL start, CELL len);

0
vmpp/cpu-ppc.hpp → vm/cpu-ppc.hpp
View File

6
vm/cpu-x86.32.h
View File

@ -1,6 +0,0 @@
#define FACTOR_CPU_STRING "x86.32"
register CELL ds asm("esi");
register CELL rs asm("edi");
#define F_FASTCALL __attribute__ ((regparm (2)))

0
vmpp/cpu-x86.32.hpp → vm/cpu-x86.32.hpp
View File

6
vm/cpu-x86.64.h
View File

@ -1,6 +0,0 @@
#define FACTOR_CPU_STRING "x86.64"
register CELL ds asm("r14");
register CELL rs asm("r15");
#define F_FASTCALL

0
vmpp/cpu-x86.64.hpp → vm/cpu-x86.64.hpp
View File

35
vm/cpu-x86.h
View File

@ -1,35 +0,0 @@
#include <assert.h>
#define FRAME_RETURN_ADDRESS(frame) *(XT *)(frame_successor(frame) + 1)
INLINE void flush_icache(CELL start, CELL len) {}
F_FASTCALL void c_to_factor(CELL quot);
F_FASTCALL void throw_impl(CELL quot, F_STACK_FRAME *rewind_to);
F_FASTCALL void lazy_jit_compile(CELL quot);
void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy);
INLINE void check_call_site(CELL return_address)
{
/* An x86 CALL instruction looks like so:
|e8|..|..|..|..|
where the ... are a PC-relative jump address.
The return_address points to right after the
instruction. */
#ifdef FACTOR_DEBUG
assert(*(unsigned char *)(return_address - 5) == 0xe8);
#endif
}
INLINE CELL get_call_target(CELL return_address)
{
check_call_site(return_address);
return *(int *)(return_address - 4) + return_address;
}
INLINE void set_call_target(CELL return_address, CELL target)
{
check_call_site(return_address);
*(int *)(return_address - 4) = (target - return_address);
}

0
vmpp/cpu-x86.hpp → vm/cpu-x86.hpp
View File

618
vm/data_gc.c
View File

@ -1,618 +0,0 @@
#include "master.h"
/* Scan all the objects in the card */
void copy_card(F_CARD *ptr, CELL gen, CELL here)
{
CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + CARD_OFFSET(ptr);
CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1);
if(here < card_end)
card_end = here;
copy_reachable_objects(card_scan,&card_end);
cards_scanned++;
}
void copy_card_deck(F_DECK *deck, CELL gen, F_CARD mask, F_CARD unmask)
{
F_CARD *first_card = DECK_TO_CARD(deck);
F_CARD *last_card = DECK_TO_CARD(deck + 1);
CELL here = data_heap->generations[gen].here;
u32 *quad_ptr;
u32 quad_mask = mask | (mask << 8) | (mask << 16) | (mask << 24);
for(quad_ptr = (u32 *)first_card; quad_ptr < (u32 *)last_card; quad_ptr++)
{
if(*quad_ptr & quad_mask)
{
F_CARD *ptr = (F_CARD *)quad_ptr;
int card;
for(card = 0; card < 4; card++)
{
if(ptr[card] & mask)
{
copy_card(&ptr[card],gen,here);
ptr[card] &= ~unmask;
}
}
}
}
decks_scanned++;
}
/* Copy all newspace objects referenced from marked cards to the destination */
void copy_gen_cards(CELL gen)
{
F_DECK *first_deck = ADDR_TO_DECK(data_heap->generations[gen].start);
F_DECK *last_deck = ADDR_TO_DECK(data_heap->generations[gen].end);
F_CARD mask, unmask;
/* if we are collecting the nursery, we care about old->nursery pointers
but not old->aging pointers */
if(collecting_gen == NURSERY)
{
mask = CARD_POINTS_TO_NURSERY;
/* after the collection, no old->nursery pointers remain
anywhere, but old->aging pointers might remain in tenured
space */
if(gen == TENURED)
unmask = CARD_POINTS_TO_NURSERY;
/* after the collection, all cards in aging space can be
cleared */
else if(HAVE_AGING_P && gen == AGING)
unmask = CARD_MARK_MASK;
else
{
critical_error("bug in copy_gen_cards",gen);
return;
}
}
/* if we are collecting aging space into tenured space, we care about
all old->nursery and old->aging pointers. no old->aging pointers can
remain */
else if(HAVE_AGING_P && collecting_gen == AGING)
{
if(collecting_aging_again)
{
mask = CARD_POINTS_TO_AGING;
unmask = CARD_MARK_MASK;
}
/* after we collect aging space into the aging semispace, no
old->nursery pointers remain but tenured space might still have
pointers to aging space. */
else
{
mask = CARD_POINTS_TO_AGING;
unmask = CARD_POINTS_TO_NURSERY;
}
}
else
{
critical_error("bug in copy_gen_cards",gen);
return;
}
F_DECK *ptr;
for(ptr = first_deck; ptr < last_deck; ptr++)
{
if(*ptr & mask)
{
copy_card_deck(ptr,gen,mask,unmask);
*ptr &= ~unmask;
}
}
}
/* Scan cards in all generations older than the one being collected, copying
old->new references */
void copy_cards(void)
{
u64 start = current_micros();
int i;
for(i = collecting_gen + 1; i < data_heap->gen_count; i++)
copy_gen_cards(i);
card_scan_time += (current_micros() - start);
}
/* Copy all tagged pointers in a range of memory */
void copy_stack_elements(F_SEGMENT *region, CELL top)
{
CELL ptr = region->start;
for(; ptr <= top; ptr += CELLS)
copy_handle((CELL*)ptr);
}
void copy_registered_locals(void)
{
CELL ptr = gc_locals_region->start;
for(; ptr <= gc_locals; ptr += CELLS)
copy_handle(*(CELL **)ptr);
}
/* Copy roots over at the start of GC, namely various constants, stacks,
the user environment and extra roots registered with REGISTER_ROOT */
void copy_roots(void)
{
copy_handle(&T);
copy_handle(&bignum_zero);
copy_handle(&bignum_pos_one);
copy_handle(&bignum_neg_one);
copy_registered_locals();
copy_stack_elements(extra_roots_region,extra_roots);
if(!performing_compaction)
{
save_stacks();
F_CONTEXT *stacks = stack_chain;
while(stacks)
{
copy_stack_elements(stacks->datastack_region,stacks->datastack);
copy_stack_elements(stacks->retainstack_region,stacks->retainstack);
copy_handle(&stacks->catchstack_save);
copy_handle(&stacks->current_callback_save);
mark_active_blocks(stacks);
stacks = stacks->next;
}
}
int i;
for(i = 0; i < USER_ENV; i++)
copy_handle(&userenv[i]);
}
/* Given a pointer to oldspace, copy it to newspace */
INLINE void *copy_untagged_object(void *pointer, CELL size)
{
if(newspace->here + size >= newspace->end)
longjmp(gc_jmp,1);
allot_barrier(newspace->here);
void *newpointer = allot_zone(newspace,size);
F_GC_STATS *s = &gc_stats[collecting_gen];
s->object_count++;
s->bytes_copied += size;
memcpy(newpointer,pointer,size);
return newpointer;
}
INLINE void forward_object(CELL pointer, CELL newpointer)
{
if(pointer != newpointer)
put(UNTAG(pointer),RETAG(newpointer,GC_COLLECTED));
}
INLINE CELL copy_object_impl(CELL pointer)
{
CELL newpointer = (CELL)copy_untagged_object(
(void*)UNTAG(pointer),
object_size(pointer));
forward_object(pointer,newpointer);
return newpointer;
}
/* Follow a chain of forwarding pointers */
CELL resolve_forwarding(CELL untagged, CELL tag)
{
check_data_pointer(untagged);
CELL header = get(untagged);
/* another forwarding pointer */
if(TAG(header) == GC_COLLECTED)
return resolve_forwarding(UNTAG(header),tag);
/* we've found the destination */
else
{
check_header(header);
CELL pointer = RETAG(untagged,tag);
if(should_copy(untagged))
pointer = RETAG(copy_object_impl(pointer),tag);
return pointer;
}
}
/* Given a pointer to a tagged pointer to oldspace, copy it to newspace.
If the object has already been copied, return the forwarding
pointer address without copying anything; otherwise, install
a new forwarding pointer. */
INLINE CELL copy_object(CELL pointer)
{
check_data_pointer(pointer);
CELL tag = TAG(pointer);
CELL header = get(UNTAG(pointer));
if(TAG(header) == GC_COLLECTED)
return resolve_forwarding(UNTAG(header),tag);
else
{
check_header(header);
return RETAG(copy_object_impl(pointer),tag);
}
}
void copy_handle(CELL *handle)
{
CELL pointer = *handle;
if(!immediate_p(pointer))
{
check_data_pointer(pointer);
if(should_copy(pointer))
*handle = copy_object(pointer);
}
}
CELL copy_next_from_nursery(CELL scan)
{
CELL *obj = (CELL *)scan;
CELL *end = (CELL *)(scan + binary_payload_start(scan));
if(obj != end)
{
obj++;
CELL nursery_start = nursery.start;
CELL nursery_end = nursery.end;
for(; obj < end; obj++)
{
CELL pointer = *obj;
if(!immediate_p(pointer))
{
check_data_pointer(pointer);
if(pointer >= nursery_start && pointer < nursery_end)
*obj = copy_object(pointer);
}
}
}
return scan + untagged_object_size(scan);
}
CELL copy_next_from_aging(CELL scan)
{
CELL *obj = (CELL *)scan;
CELL *end = (CELL *)(scan + binary_payload_start(scan));
if(obj != end)
{
obj++;
CELL tenured_start = data_heap->generations[TENURED].start;
CELL tenured_end = data_heap->generations[TENURED].end;
CELL newspace_start = newspace->start;
CELL newspace_end = newspace->end;
for(; obj < end; obj++)
{
CELL pointer = *obj;
if(!immediate_p(pointer))
{
check_data_pointer(pointer);
if(!(pointer >= newspace_start && pointer < newspace_end)
&& !(pointer >= tenured_start && pointer < tenured_end))
*obj = copy_object(pointer);
}
}
}
return scan + untagged_object_size(scan);
}
CELL copy_next_from_tenured(CELL scan)
{
CELL *obj = (CELL *)scan;
CELL *end = (CELL *)(scan + binary_payload_start(scan));
if(obj != end)
{
obj++;
CELL newspace_start = newspace->start;
CELL newspace_end = newspace->end;
for(; obj < end; obj++)
{
CELL pointer = *obj;
if(!immediate_p(pointer))
{
check_data_pointer(pointer);
if(!(pointer >= newspace_start && pointer < newspace_end))
*obj = copy_object(pointer);
}
}
}
mark_object_code_block(scan);
return scan + untagged_object_size(scan);
}
void copy_reachable_objects(CELL scan, CELL *end)
{
if(collecting_gen == NURSERY)
{
while(scan < *end)
scan = copy_next_from_nursery(scan);
}
else if(HAVE_AGING_P && collecting_gen == AGING)
{
while(scan < *end)
scan = copy_next_from_aging(scan);
}
else if(collecting_gen == TENURED)
{
while(scan < *end)
scan = copy_next_from_tenured(scan);
}
}
/* Prepare to start copying reachable objects into an unused zone */
void begin_gc(CELL requested_bytes)
{
if(growing_data_heap)
{
if(collecting_gen != TENURED)
critical_error("Invalid parameters to begin_gc",0);
old_data_heap = data_heap;
set_data_heap(grow_data_heap(old_data_heap,requested_bytes));
newspace = &data_heap->generations[TENURED];
}
else if(collecting_accumulation_gen_p())
{
/* when collecting one of these generations, rotate it
with the semispace */
F_ZONE z = data_heap->generations[collecting_gen];
data_heap->generations[collecting_gen] = data_heap->semispaces[collecting_gen];
data_heap->semispaces[collecting_gen] = z;
reset_generation(collecting_gen);
newspace = &data_heap->generations[collecting_gen];
clear_cards(collecting_gen,collecting_gen);
clear_decks(collecting_gen,collecting_gen);
clear_allot_markers(collecting_gen,collecting_gen);
}
else
{
/* when collecting a younger generation, we copy
reachable objects to the next oldest generation,
so we set the newspace so the next generation. */
newspace = &data_heap->generations[collecting_gen + 1];
}
}
void end_gc(CELL gc_elapsed)
{
F_GC_STATS *s = &gc_stats[collecting_gen];
s->collections++;
s->gc_time += gc_elapsed;
if(s->max_gc_time < gc_elapsed)
s->max_gc_time = gc_elapsed;
if(growing_data_heap)
{
dealloc_data_heap(old_data_heap);
old_data_heap = NULL;
growing_data_heap = false;
}
if(collecting_accumulation_gen_p())
{
/* all younger generations except are now empty.
if collecting_gen == NURSERY here, we only have 1 generation;
old-school Cheney collector */
if(collecting_gen != NURSERY)
reset_generations(NURSERY,collecting_gen - 1);
}
else if(collecting_gen == NURSERY)
{
nursery.here = nursery.start;
}
else
{
/* all generations up to and including the one
collected are now empty */
reset_generations(NURSERY,collecting_gen);
}
collecting_aging_again = false;
}
/* Collect gen and all younger generations.
If growing_data_heap_ is true, we must grow the data heap to such a size that
an allocation of requested_bytes won't fail */
void garbage_collection(CELL gen,
bool growing_data_heap_,
CELL requested_bytes)
{
if(gc_off)
{
critical_error("GC disabled",gen);
return;
}
u64 start = current_micros();
performing_gc = true;
growing_data_heap = growing_data_heap_;
collecting_gen = gen;
/* we come back here if a generation is full */
if(setjmp(gc_jmp))
{
/* We have no older generations we can try collecting, so we
resort to growing the data heap */
if(collecting_gen == TENURED)
{
growing_data_heap = true;
/* see the comment in unmark_marked() */
unmark_marked(&code_heap);
}
/* we try collecting AGING space twice before going on to
collect TENURED */
else if(HAVE_AGING_P
&& collecting_gen == AGING
&& !collecting_aging_again)
{
collecting_aging_again = true;
}
/* Collect the next oldest generation */
else
{
collecting_gen++;
}
}
begin_gc(requested_bytes);
/* initialize chase pointer */
CELL scan = newspace->here;
/* collect objects referenced from stacks and environment */
copy_roots();
/* collect objects referenced from older generations */
copy_cards();
/* do some tracing */
copy_reachable_objects(scan,&newspace->here);
/* don't scan code heap unless it has pointers to this
generation or younger */
if(collecting_gen >= last_code_heap_scan)
{
code_heap_scans++;
if(collecting_gen == TENURED)
free_unmarked(&code_heap,(HEAP_ITERATOR)update_literal_and_word_references);
else
copy_code_heap_roots();
if(collecting_accumulation_gen_p())
last_code_heap_scan = collecting_gen;
else
last_code_heap_scan = collecting_gen + 1;
}
CELL gc_elapsed = (current_micros() - start);
end_gc(gc_elapsed);
performing_gc = false;
}
void gc(void)
{
garbage_collection(TENURED,false,0);
}
void minor_gc(void)
{
garbage_collection(NURSERY,false,0);
}
void primitive_gc(void)
{
gc();
}
void primitive_gc_stats(void)
{
GROWABLE_ARRAY(stats);
CELL i;
u64 total_gc_time = 0;
for(i = 0; i < MAX_GEN_COUNT; i++)
{
F_GC_STATS *s = &gc_stats[i];
GROWABLE_ARRAY_ADD(stats,allot_cell(s->collections));
GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(s->gc_time)));
GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(s->max_gc_time)));
GROWABLE_ARRAY_ADD(stats,allot_cell(s->collections == 0 ? 0 : s->gc_time / s->collections));
GROWABLE_ARRAY_ADD(stats,allot_cell(s->object_count));
GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(s->bytes_copied)));
total_gc_time += s->gc_time;
}
GROWABLE_ARRAY_ADD(stats,tag_bignum(ulong_long_to_bignum(total_gc_time)));
GROWABLE_ARRAY_ADD(stats,tag_bignum(ulong_long_to_bignum(cards_scanned)));
GROWABLE_ARRAY_ADD(stats,tag_bignum(ulong_long_to_bignum(decks_scanned)));
GROWABLE_ARRAY_ADD(stats,tag_bignum(ulong_long_to_bignum(card_scan_time)));
GROWABLE_ARRAY_ADD(stats,allot_cell(code_heap_scans));
GROWABLE_ARRAY_TRIM(stats);
GROWABLE_ARRAY_DONE(stats);
dpush(stats);
}
void clear_gc_stats(void)
{
int i;
for(i = 0; i < MAX_GEN_COUNT; i++)
memset(&gc_stats[i],0,sizeof(F_GC_STATS));
cards_scanned = 0;
decks_scanned = 0;
card_scan_time = 0;
code_heap_scans = 0;
}
void primitive_clear_gc_stats(void)
{
clear_gc_stats();
}
/* classes.tuple uses this to reshape tuples; tools.deploy.shaker uses this
to coalesce equal but distinct quotations and wrappers. */
void primitive_become(void)
{
F_ARRAY *new_objects = untag_array(dpop());
F_ARRAY *old_objects = untag_array(dpop());
CELL capacity = array_capacity(new_objects);
if(capacity != array_capacity(old_objects))
critical_error("bad parameters to become",0);
CELL i;
for(i = 0; i < capacity; i++)
{
CELL old_obj = array_nth(old_objects,i);
CELL new_obj = array_nth(new_objects,i);
forward_object(old_obj,new_obj);
}
gc();
/* If a word's definition quotation was in old_objects and the
quotation in new_objects is not compiled, we might leak memory
by referencing the old quotation unless we recompile all
unoptimized words. */
compile_all_words();
}

0
vmpp/data_gc.cpp → vm/data_gc.cpp
View File

17
vm/data_gc.h Executable file → Normal file
View File

@ -78,25 +78,18 @@ allocation (which does not call GC because of possible roots in volatile
registers) does not run out of memory */
#define ALLOT_BUFFER_ZONE 1024
/* If this is defined, we GC every 100 allocations. This catches missing local roots */
#ifdef GC_DEBUG
int gc_count;
#endif
/* If this is defined, we GC every allocation. This catches missing local roots */
/*
* It is up to the caller to fill in the object's fields in a meaningful
* fashion!
*/
int count;
INLINE void *allot_object(CELL type, CELL a)
{
#ifdef GC_DEBUG
if(!gc_off)
{
if(gc_count++ % 100 == 0)
gc();
}
gc();
#endif
CELL *object;
@ -109,7 +102,7 @@ INLINE void *allot_object(CELL type, CELL a)
CELL h = nursery.here;
nursery.here = h + align8(a);
object = (void*)h;
object = (CELL*)h;
}
/* If the object is bigger than the nursery, allocate it in
tenured space */
@ -131,7 +124,7 @@ INLINE void *allot_object(CELL type, CELL a)
tenured = &data_heap->generations[TENURED];
}
object = allot_zone(tenured,a);
object = (CELL *)allot_zone(tenured,a);
/* We have to do this */
allot_barrier((CELL)object);

0
vmpp/data_gc.hpp → vm/data_gc.hpp
View File

366
vm/data_heap.c
View File

@ -1,366 +0,0 @@
#include "master.h"
CELL init_zone(F_ZONE *z, CELL size, CELL start)
{
z->size = size;
z->start = z->here = start;
z->end = start + size;
return z->end;
}
void init_card_decks(void)
{
CELL start = align(data_heap->segment->start,DECK_SIZE);
allot_markers_offset = (CELL)data_heap->allot_markers - (start >> CARD_BITS);
cards_offset = (CELL)data_heap->cards - (start >> CARD_BITS);
decks_offset = (CELL)data_heap->decks - (start >> DECK_BITS);
}
F_DATA_HEAP *alloc_data_heap(CELL gens,
CELL young_size,
CELL aging_size,
CELL tenured_size)
{
young_size = align(young_size,DECK_SIZE);
aging_size = align(aging_size,DECK_SIZE);
tenured_size = align(tenured_size,DECK_SIZE);
F_DATA_HEAP *data_heap = safe_malloc(sizeof(F_DATA_HEAP));
data_heap->young_size = young_size;
data_heap->aging_size = aging_size;
data_heap->tenured_size = tenured_size;
data_heap->gen_count = gens;
CELL total_size;
if(data_heap->gen_count == 2)
total_size = young_size + 2 * tenured_size;
else if(data_heap->gen_count == 3)
total_size = young_size + 2 * aging_size + 2 * tenured_size;
else
{
fatal_error("Invalid number of generations",data_heap->gen_count);
return NULL; /* can't happen */
}
total_size += DECK_SIZE;
data_heap->segment = alloc_segment(total_size);
data_heap->generations = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
data_heap->semispaces = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
CELL cards_size = total_size >> CARD_BITS;
data_heap->allot_markers = safe_malloc(cards_size);
data_heap->allot_markers_end = data_heap->allot_markers + cards_size;
data_heap->cards = safe_malloc(cards_size);
data_heap->cards_end = data_heap->cards + cards_size;
CELL decks_size = total_size >> DECK_BITS;
data_heap->decks = safe_malloc(decks_size);
data_heap->decks_end = data_heap->decks + decks_size;
CELL alloter = align(data_heap->segment->start,DECK_SIZE);
alloter = init_zone(&data_heap->generations[TENURED],tenured_size,alloter);
alloter = init_zone(&data_heap->semispaces[TENURED],tenured_size,alloter);
if(data_heap->gen_count == 3)
{
alloter = init_zone(&data_heap->generations[AGING],aging_size,alloter);
alloter = init_zone(&data_heap->semispaces[AGING],aging_size,alloter);
}
if(data_heap->gen_count >= 2)
{
alloter = init_zone(&data_heap->generations[NURSERY],young_size,alloter);
alloter = init_zone(&data_heap->semispaces[NURSERY],0,alloter);
}
if(data_heap->segment->end - alloter > DECK_SIZE)
critical_error("Bug in alloc_data_heap",alloter);
return data_heap;
}
F_DATA_HEAP *grow_data_heap(F_DATA_HEAP *data_heap, CELL requested_bytes)
{
CELL new_tenured_size = (data_heap->tenured_size * 2) + requested_bytes;
return alloc_data_heap(data_heap->gen_count,
data_heap->young_size,
data_heap->aging_size,
new_tenured_size);
}
void dealloc_data_heap(F_DATA_HEAP *data_heap)
{
dealloc_segment(data_heap->segment);
free(data_heap->generations);
free(data_heap->semispaces);
free(data_heap->allot_markers);
free(data_heap->cards);
free(data_heap->decks);
free(data_heap);
}
void clear_cards(CELL from, CELL to)
{
/* NOTE: reverse order due to heap layout. */
F_CARD *first_card = ADDR_TO_CARD(data_heap->generations[to].start);
F_CARD *last_card = ADDR_TO_CARD(data_heap->generations[from].end);
memset(first_card,0,last_card - first_card);
}
void clear_decks(CELL from, CELL to)
{
/* NOTE: reverse order due to heap layout. */
F_DECK *first_deck = ADDR_TO_DECK(data_heap->generations[to].start);
F_DECK *last_deck = ADDR_TO_DECK(data_heap->generations[from].end);
memset(first_deck,0,last_deck - first_deck);
}
void clear_allot_markers(CELL from, CELL to)
{
/* NOTE: reverse order due to heap layout. */
F_CARD *first_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[to].start);
F_CARD *last_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[from].end);
memset(first_card,INVALID_ALLOT_MARKER,last_card - first_card);
}
void reset_generation(CELL i)
{
F_ZONE *z = (i == NURSERY ? &nursery : &data_heap->generations[i]);
z->here = z->start;
if(secure_gc)
memset((void*)z->start,69,z->size);
}
/* After garbage collection, any generations which are now empty need to have
their allocation pointers and cards reset. */
void reset_generations(CELL from, CELL to)
{
CELL i;
for(i = from; i <= to; i++)
reset_generation(i);
clear_cards(from,to);
clear_decks(from,to);
clear_allot_markers(from,to);
}
void set_data_heap(F_DATA_HEAP *data_heap_)
{
data_heap = data_heap_;
nursery = data_heap->generations[NURSERY];
init_card_decks();
clear_cards(NURSERY,TENURED);
clear_decks(NURSERY,TENURED);
clear_allot_markers(NURSERY,TENURED);
}
void init_data_heap(CELL gens,
CELL young_size,
CELL aging_size,
CELL tenured_size,
bool secure_gc_)
{
set_data_heap(alloc_data_heap(gens,young_size,aging_size,tenured_size));
gc_locals_region = alloc_segment(getpagesize());
gc_locals = gc_locals_region->start - CELLS;
extra_roots_region = alloc_segment(getpagesize());
extra_roots = extra_roots_region->start - CELLS;
secure_gc = secure_gc_;
}
/* Size of the object pointed to by a tagged pointer */
CELL object_size(CELL tagged)
{
if(immediate_p(tagged))
return 0;
else
return untagged_object_size(UNTAG(tagged));
}
/* Size of the object pointed to by an untagged pointer */
CELL untagged_object_size(CELL pointer)
{
return align8(unaligned_object_size(pointer));
}
/* Size of the data area of an object pointed to by an untagged pointer */
CELL unaligned_object_size(CELL pointer)
{
F_TUPLE *tuple;
F_TUPLE_LAYOUT *layout;
switch(untag_header(get(pointer)))
{
case ARRAY_TYPE:
case BIGNUM_TYPE:
return array_size(array_capacity((F_ARRAY*)pointer));
case BYTE_ARRAY_TYPE:
return byte_array_size(
byte_array_capacity((F_BYTE_ARRAY*)pointer));
case STRING_TYPE:
return string_size(string_capacity((F_STRING*)pointer));
case TUPLE_TYPE:
tuple = untag_object(pointer);
layout = untag_object(tuple->layout);
return tuple_size(layout);
case QUOTATION_TYPE:
return sizeof(F_QUOTATION);
case WORD_TYPE:
return sizeof(F_WORD);
case FLOAT_TYPE:
return sizeof(F_FLOAT);
case DLL_TYPE:
return sizeof(F_DLL);
case ALIEN_TYPE:
return sizeof(F_ALIEN);
case WRAPPER_TYPE:
return sizeof(F_WRAPPER);
case CALLSTACK_TYPE:
return callstack_size(
untag_fixnum_fast(((F_CALLSTACK *)pointer)->length));
default:
critical_error("Invalid header",pointer);
return -1; /* can't happen */
}
}
void primitive_size(void)
{
box_unsigned_cell(object_size(dpop()));
}
/* The number of cells from the start of the object which should be scanned by
the GC. Some types have a binary payload at the end (string, word, DLL) which
we ignore. */
CELL binary_payload_start(CELL pointer)
{
F_TUPLE *tuple;
F_TUPLE_LAYOUT *layout;
switch(untag_header(get(pointer)))
{
/* these objects do not refer to other objects at all */
case FLOAT_TYPE:
case BYTE_ARRAY_TYPE:
case BIGNUM_TYPE:
case CALLSTACK_TYPE:
return 0;
/* these objects have some binary data at the end */
case WORD_TYPE:
return sizeof(F_WORD) - CELLS * 3;
case ALIEN_TYPE:
return CELLS * 3;
case DLL_TYPE:
return CELLS * 2;
case QUOTATION_TYPE:
return sizeof(F_QUOTATION) - CELLS * 2;
case STRING_TYPE:
return sizeof(F_STRING);
/* everything else consists entirely of pointers */
case ARRAY_TYPE:
return array_size(array_capacity((F_ARRAY*)pointer));
case TUPLE_TYPE:
tuple = untag_object(pointer);
layout = untag_object(tuple->layout);
return tuple_size(layout);
case WRAPPER_TYPE:
return sizeof(F_WRAPPER);
default:
critical_error("Invalid header",pointer);
return -1; /* can't happen */
}
}
/* Push memory usage statistics in data heap */
void primitive_data_room(void)
{
dpush(tag_fixnum((data_heap->cards_end - data_heap->cards) >> 10));
dpush(tag_fixnum((data_heap->decks_end - data_heap->decks) >> 10));
GROWABLE_ARRAY(a);
int gen;
for(gen = 0; gen < data_heap->gen_count; gen++)
{
F_ZONE *z = (gen == NURSERY ? &nursery : &data_heap->generations[gen]);
GROWABLE_ARRAY_ADD(a,tag_fixnum((z->end - z->here) >> 10));
GROWABLE_ARRAY_ADD(a,tag_fixnum((z->size) >> 10));
}
GROWABLE_ARRAY_TRIM(a);
GROWABLE_ARRAY_DONE(a);
dpush(a);
}
/* Disables GC and activates next-object ( -- obj ) primitive */
void begin_scan(void)
{
heap_scan_ptr = data_heap->generations[TENURED].start;
gc_off = true;
}
void primitive_begin_scan(void)
{
begin_scan();
}
CELL next_object(void)
{
if(!gc_off)
general_error(ERROR_HEAP_SCAN,F,F,NULL);
CELL value = get(heap_scan_ptr);
CELL obj = heap_scan_ptr;
CELL type;
if(heap_scan_ptr >= data_heap->generations[TENURED].here)
return F;
type = untag_header(value);
heap_scan_ptr += untagged_object_size(heap_scan_ptr);
return RETAG(obj,type < HEADER_TYPE ? type : OBJECT_TYPE);
}
/* Push object at heap scan cursor and advance; pushes f when done */
void primitive_next_object(void)
{
dpush(next_object());
}
/* Re-enables GC */
void primitive_end_scan(void)
{
gc_off = false;
}
CELL find_all_words(void)
{
GROWABLE_ARRAY(words);
begin_scan();
CELL obj;
while((obj = next_object()) != F)
{
if(type_of(obj) == WORD_TYPE)
GROWABLE_ARRAY_ADD(words,obj);
}
/* End heap scan */
gc_off = false;
GROWABLE_ARRAY_TRIM(words);
GROWABLE_ARRAY_DONE(words);
return words;
}

0
vmpp/data_heap.cpp → vm/data_heap.cpp
View File

138
vm/data_heap.h
View File

@ -1,138 +0,0 @@
/* Set by the -securegc command line argument */
bool secure_gc;
/* generational copying GC divides memory into zones */
typedef struct {
/* allocation pointer is 'here'; its offset is hardcoded in the
compiler backends*/
CELL start;
CELL here;
CELL size;
CELL end;
} F_ZONE;
typedef struct {
F_SEGMENT *segment;
CELL young_size;
CELL aging_size;
CELL tenured_size;
CELL gen_count;
F_ZONE *generations;
F_ZONE* semispaces;
CELL *allot_markers;
CELL *allot_markers_end;
CELL *cards;
CELL *cards_end;
CELL *decks;
CELL *decks_end;
} F_DATA_HEAP;
F_DATA_HEAP *data_heap;
/* the 0th generation is where new objects are allocated. */
#define NURSERY 0
/* where objects hang around */
#define AGING (data_heap->gen_count-2)
#define HAVE_AGING_P (data_heap->gen_count>2)
/* the oldest generation */
#define TENURED (data_heap->gen_count-1)
#define MIN_GEN_COUNT 1
#define MAX_GEN_COUNT 3
/* new objects are allocated here */
DLLEXPORT F_ZONE nursery;
INLINE bool in_zone(F_ZONE *z, CELL pointer)
{
return pointer >= z->start && pointer < z->end;
}
CELL init_zone(F_ZONE *z, CELL size, CELL base);
void init_card_decks(void);
F_DATA_HEAP *grow_data_heap(F_DATA_HEAP *data_heap, CELL requested_bytes);
void dealloc_data_heap(F_DATA_HEAP *data_heap);
void clear_cards(CELL from, CELL to);
void clear_decks(CELL from, CELL to);
void clear_allot_markers(CELL from, CELL to);
void reset_generation(CELL i);
void reset_generations(CELL from, CELL to);
void set_data_heap(F_DATA_HEAP *data_heap_);
void init_data_heap(CELL gens,
CELL young_size,
CELL aging_size,
CELL tenured_size,
bool secure_gc_);
/* set up guard pages to check for under/overflow.
size must be a multiple of the page size */
F_SEGMENT *alloc_segment(CELL size);
void dealloc_segment(F_SEGMENT *block);
CELL untagged_object_size(CELL pointer);
CELL unaligned_object_size(CELL pointer);
CELL object_size(CELL pointer);
CELL binary_payload_start(CELL pointer);
void begin_scan(void);
CELL next_object(void);
void primitive_data_room(void);
void primitive_size(void);
void primitive_begin_scan(void);
void primitive_next_object(void);
void primitive_end_scan(void);
/* A heap walk allows useful things to be done, like finding all
references to an object for debugging purposes. */
CELL heap_scan_ptr;
/* GC is off during heap walking */
bool gc_off;
INLINE bool in_data_heap_p(CELL ptr)
{
return (ptr >= data_heap->segment->start
&& ptr <= data_heap->segment->end);
}
INLINE void *allot_zone(F_ZONE *z, CELL a)
{
CELL h = z->here;
z->here = h + align8(a);
return (void*)h;
}
CELL find_all_words(void);
/* Every object has a regular representation in the runtime, which makes GC
much simpler. Every slot of the object until binary_payload_start is a pointer
to some other object. */
INLINE void do_slots(CELL obj, void (* iter)(CELL *))
{
CELL scan = obj;
CELL payload_start = binary_payload_start(obj);
CELL end = obj + payload_start;
scan += CELLS;
while(scan < end)
{
iter((CELL *)scan);
scan += CELLS;
}
}

0
vmpp/data_heap.hpp → vm/data_heap.hpp
View File

501
vm/debug.c
View File

@ -1,501 +0,0 @@
#include "master.h"
static bool full_output;
void print_chars(F_STRING* str)
{
CELL i;
for(i = 0; i < string_capacity(str); i++)
putchar(string_nth(str,i));
}
void print_word(F_WORD* word, CELL nesting)
{
if(type_of(word->vocabulary) == STRING_TYPE)
{
print_chars(untag_string(word->vocabulary));
print_string(":");
}
if(type_of(word->name) == STRING_TYPE)
print_chars(untag_string(word->name));
else
{
print_string("#<not a string: ");
print_nested_obj(word->name,nesting);
print_string(">");
}
}
void print_factor_string(F_STRING* str)
{
putchar('"');
print_chars(str);
putchar('"');
}
void print_array(F_ARRAY* array, CELL nesting)
{
CELL length = array_capacity(array);
CELL i;
bool trimmed;
if(length > 10 && !full_output)
{
trimmed = true;
length = 10;
}
else
trimmed = false;
for(i = 0; i < length; i++)
{
print_string(" ");
print_nested_obj(array_nth(array,i),nesting);
}
if(trimmed)
print_string("...");
}
void print_tuple(F_TUPLE* tuple, CELL nesting)
{
F_TUPLE_LAYOUT *layout = untag_object(tuple->layout);
CELL length = to_fixnum(layout->size);
print_string(" ");
print_nested_obj(layout->class,nesting);
CELL i;
bool trimmed;
if(length > 10 && !full_output)
{
trimmed = true;
length = 10;
}
else
trimmed = false;
for(i = 0; i < length; i++)
{
print_string(" ");
print_nested_obj(tuple_nth(tuple,i),nesting);
}
if(trimmed)
print_string("...");
}
void print_nested_obj(CELL obj, F_FIXNUM nesting)
{
if(nesting <= 0 && !full_output)
{
print_string(" ... ");
return;
}
F_QUOTATION *quot;
switch(type_of(obj))
{
case FIXNUM_TYPE:
print_fixnum(untag_fixnum_fast(obj));
break;
case WORD_TYPE:
print_word(untag_word(obj),nesting - 1);
break;
case STRING_TYPE:
print_factor_string(untag_string(obj));
break;
case F_TYPE:
print_string("f");
break;
case TUPLE_TYPE:
print_string("T{");
print_tuple(untag_object(obj),nesting - 1);
print_string(" }");
break;
case ARRAY_TYPE:
print_string("{");
print_array(untag_object(obj),nesting - 1);
print_string(" }");
break;
case QUOTATION_TYPE:
print_string("[");
quot = untag_object(obj);
print_array(untag_object(quot->array),nesting - 1);
print_string(" ]");
break;
default:
print_string("#<type "); print_cell(type_of(obj)); print_string(" @ "); print_cell_hex(obj); print_string(">");
break;
}
}
void print_obj(CELL obj)
{
print_nested_obj(obj,10);
}
void print_objects(CELL start, CELL end)
{
for(; start <= end; start += CELLS)
{
print_obj(get(start));
nl();
}
}
void print_datastack(void)
{
print_string("==== DATA STACK:\n");
print_objects(ds_bot,ds);
}
void print_retainstack(void)
{
print_string("==== RETAIN STACK:\n");
print_objects(rs_bot,rs);
}
void print_stack_frame(F_STACK_FRAME *frame)
{
print_obj(frame_executing(frame));
print_string("\n");
print_obj(frame_scan(frame));
print_string("\n");
print_cell_hex((CELL)frame_executing(frame));
print_string(" ");
print_cell_hex((CELL)frame->xt);
print_string("\n");
}
void print_callstack(void)
{
print_string("==== CALL STACK:\n");
CELL bottom = (CELL)stack_chain->callstack_bottom;
CELL top = (CELL)stack_chain->callstack_top;
iterate_callstack(top,bottom,print_stack_frame);
}
void dump_cell(CELL cell)
{
print_cell_hex_pad(cell); print_string(": ");
cell = get(cell);
print_cell_hex_pad(cell); print_string(" tag "); print_cell(TAG(cell));
switch(TAG(cell))
{
case OBJECT_TYPE:
case BIGNUM_TYPE:
case FLOAT_TYPE:
if(cell == F)
print_string(" -- F");
else if(cell < TYPE_COUNT<<TAG_BITS)
{
print_string(" -- possible header: ");
print_cell(cell>>TAG_BITS);
}
else if(cell >= data_heap->segment->start
&& cell < data_heap->segment->end)
{
CELL header = get(UNTAG(cell));
CELL type = header>>TAG_BITS;
print_string(" -- object; ");
if(TAG(header) == 0 && type < TYPE_COUNT)
{
print_string(" type "); print_cell(type);
}
else
print_string(" header corrupt");
}
break;
}
nl();
}
void dump_memory(CELL from, CELL to)
{
from = UNTAG(from);
for(; from <= to; from += CELLS)
dump_cell(from);
}
void dump_zone(F_ZONE *z)
{
print_string("Start="); print_cell(z->start);
print_string(", size="); print_cell(z->size);
print_string(", here="); print_cell(z->here - z->start); nl();
}
void dump_generations(void)
{
CELL i;
print_string("Nursery: ");
dump_zone(&nursery);
for(i = 1; i < data_heap->gen_count; i++)
{
print_string("Generation "); print_cell(i); print_string(": ");
dump_zone(&data_heap->generations[i]);
}
for(i = 0; i < data_heap->gen_count; i++)
{
print_string("Semispace "); print_cell(i); print_string(": ");
dump_zone(&data_heap->semispaces[i]);
}
print_string("Cards: base=");
print_cell((CELL)data_heap->cards);
print_string(", size=");
print_cell((CELL)(data_heap->cards_end - data_heap->cards));
nl();
}
void dump_objects(F_FIXNUM type)
{
gc();
begin_scan();
CELL obj;
while((obj = next_object()) != F)
{
if(type == -1 || type_of(obj) == type)
{
print_cell_hex_pad(obj);
print_string(" ");
print_nested_obj(obj,2);
nl();
}
}
/* end scan */
gc_off = false;
}
CELL look_for;
CELL obj;
void find_data_references_step(CELL *scan)
{
if(look_for == *scan)
{
print_cell_hex_pad(obj);
print_string(" ");
print_nested_obj(obj,2);
nl();
}
}
void find_data_references(CELL look_for_)
{
look_for = look_for_;
begin_scan();
while((obj = next_object()) != F)
do_slots(UNTAG(obj),find_data_references_step);
/* end scan */
gc_off = false;
}
/* Dump all code blocks for debugging */
void dump_code_heap(void)
{
CELL reloc_size = 0, literal_size = 0;
F_BLOCK *scan = first_block(&code_heap);
while(scan)
{
char *status;
switch(scan->status)
{
case B_FREE:
status = "free";
break;
case B_ALLOCATED:
reloc_size += object_size(((F_CODE_BLOCK *)scan)->relocation);
literal_size += object_size(((F_CODE_BLOCK *)scan)->literals);
status = "allocated";
break;
case B_MARKED:
reloc_size += object_size(((F_CODE_BLOCK *)scan)->relocation);
literal_size += object_size(((F_CODE_BLOCK *)scan)->literals);
status = "marked";
break;
default:
status = "invalid";
break;
}
print_cell_hex((CELL)scan); print_string(" ");
print_cell_hex(scan->size); print_string(" ");
print_string(status); print_string("\n");
scan = next_block(&code_heap,scan);
}
print_cell(reloc_size); print_string(" bytes of relocation data\n");
print_cell(literal_size); print_string(" bytes of literal data\n");
}
void factorbug(void)
{
if(fep_disabled)
{
print_string("Low level debugger disabled\n");
exit(1);
}
/* open_console(); */
print_string("Starting low level debugger...\n");
print_string(" Basic commands:\n");
print_string("q -- continue executing Factor - NOT SAFE\n");
print_string("im -- save image to fep.image\n");
print_string("x -- exit Factor\n");
print_string(" Advanced commands:\n");
print_string("d <addr> <count> -- dump memory\n");
print_string("u <addr> -- dump object at tagged <addr>\n");
print_string(". <addr> -- print object at tagged <addr>\n");
print_string("t -- toggle output trimming\n");
print_string("s r -- dump data, retain stacks\n");
print_string(".s .r .c -- print data, retain, call stacks\n");
print_string("e -- dump environment\n");
print_string("g -- dump generations\n");
print_string("card <addr> -- print card containing address\n");
print_string("addr <card> -- print address containing card\n");
print_string("data -- data heap dump\n");
print_string("words -- words dump\n");
print_string("tuples -- tuples dump\n");
print_string("refs <addr> -- find data heap references to object\n");
print_string("push <addr> -- push object on data stack - NOT SAFE\n");
print_string("code -- code heap dump\n");
bool seen_command = false;
for(;;)
{
char cmd[1024];
print_string("READY\n");
fflush(stdout);
if(scanf("%1000s",cmd) <= 0)
{
if(!seen_command)
{
/* If we exit with an EOF immediately, then
dump stacks. This is useful for builder and
other cases where Factor is run with stdin
redirected to /dev/null */
fep_disabled = true;
print_datastack();
print_retainstack();
print_callstack();
}
exit(1);
}
seen_command = true;
if(strcmp(cmd,"d") == 0)
{
CELL addr = read_cell_hex();
if(scanf(" ") < 0) break;
CELL count = read_cell_hex();
dump_memory(addr,addr+count);
}
else if(strcmp(cmd,"u") == 0)
{
CELL addr = read_cell_hex();
CELL count = object_size(addr);
dump_memory(addr,addr+count);
}
else if(strcmp(cmd,".") == 0)
{
CELL addr = read_cell_hex();
print_obj(addr);
print_string("\n");
}
else if(strcmp(cmd,"t") == 0)
full_output = !full_output;
else if(strcmp(cmd,"s") == 0)
dump_memory(ds_bot,ds);
else if(strcmp(cmd,"r") == 0)
dump_memory(rs_bot,rs);
else if(strcmp(cmd,".s") == 0)
print_datastack();
else if(strcmp(cmd,".r") == 0)
print_retainstack();
else if(strcmp(cmd,".c") == 0)
print_callstack();
else if(strcmp(cmd,"e") == 0)
{
int i;
for(i = 0; i < USER_ENV; i++)
dump_cell((CELL)&userenv[i]);
}
else if(strcmp(cmd,"g") == 0)
dump_generations();
else if(strcmp(cmd,"card") == 0)
{
CELL addr = read_cell_hex();
print_cell_hex((CELL)ADDR_TO_CARD(addr));
nl();
}
else if(strcmp(cmd,"addr") == 0)
{
CELL card = read_cell_hex();
print_cell_hex((CELL)CARD_TO_ADDR(card));
nl();
}
else if(strcmp(cmd,"q") == 0)
return;
else if(strcmp(cmd,"x") == 0)
exit(1);
else if(strcmp(cmd,"im") == 0)
save_image(STRING_LITERAL("fep.image"));
else if(strcmp(cmd,"data") == 0)
dump_objects(-1);
else if(strcmp(cmd,"refs") == 0)
{
CELL addr = read_cell_hex();
print_string("Data heap references:\n");
find_data_references(addr);
nl();
}
else if(strcmp(cmd,"words") == 0)
dump_objects(WORD_TYPE);
else if(strcmp(cmd,"tuples") == 0)
dump_objects(TUPLE_TYPE);
else if(strcmp(cmd,"push") == 0)
{
CELL addr = read_cell_hex();
dpush(addr);
}
else if(strcmp(cmd,"code") == 0)
dump_code_heap();
else
print_string("unknown command\n");
}
}
void primitive_die(void)
{
print_string("The die word was called by the library. Unless you called it yourself,\n");
print_string("you have triggered a bug in Factor. Please report.\n");
factorbug();
}

0
vmpp/debug.cpp → vm/debug.cpp
View File

9
vm/debug.h
View File

@ -1,9 +0,0 @@
void print_obj(CELL obj);
void print_nested_obj(CELL obj, F_FIXNUM nesting);
void dump_generations(void);
void factorbug(void);
void dump_zone(F_ZONE *z);
bool fep_disabled;
void primitive_die(void);

0
vmpp/debug.hpp → vm/debug.hpp
View File

202
vm/dispatch.c
View File

@ -1,202 +0,0 @@
#include "master.h"
static CELL search_lookup_alist(CELL table, CELL class)
{
F_ARRAY *pairs = untag_object(table);
F_FIXNUM index = array_capacity(pairs) - 1;
while(index >= 0)
{
F_ARRAY *pair = untag_object(array_nth(pairs,index));
if(array_nth(pair,0) == class)
return array_nth(pair,1);
else
index--;
}
return F;
}
static CELL search_lookup_hash(CELL table, CELL class, CELL hashcode)
{
F_ARRAY *buckets = untag_object(table);
CELL bucket = array_nth(buckets,hashcode & (array_capacity(buckets) - 1));
if(type_of(bucket) == WORD_TYPE || bucket == F)
return bucket;
else
return search_lookup_alist(bucket,class);
}
static CELL nth_superclass(F_TUPLE_LAYOUT *layout, F_FIXNUM echelon)
{
CELL *ptr = (CELL *)(layout + 1);
return ptr[echelon * 2];
}
static CELL nth_hashcode(F_TUPLE_LAYOUT *layout, F_FIXNUM echelon)
{
CELL *ptr = (CELL *)(layout + 1);
return ptr[echelon * 2 + 1];
}
static CELL lookup_tuple_method(CELL object, CELL methods)
{
F_TUPLE *tuple = untag_object(object);
F_TUPLE_LAYOUT *layout = untag_object(tuple->layout);
F_ARRAY *echelons = untag_object(methods);
F_FIXNUM echelon = untag_fixnum_fast(layout->echelon);
F_FIXNUM max_echelon = array_capacity(echelons) - 1;
if(echelon > max_echelon) echelon = max_echelon;
while(echelon >= 0)
{
CELL echelon_methods = array_nth(echelons,echelon);
if(type_of(echelon_methods) == WORD_TYPE)
return echelon_methods;
else if(echelon_methods != F)
{
CELL class = nth_superclass(layout,echelon);
CELL hashcode = untag_fixnum_fast(nth_hashcode(layout,echelon));
CELL result = search_lookup_hash(echelon_methods,class,hashcode);
if(result != F)
return result;
}
echelon--;
}
critical_error("Cannot find tuple method",methods);
return F;
}
static CELL lookup_hi_tag_method(CELL object, CELL methods)
{
F_ARRAY *hi_tag_methods = untag_object(methods);
CELL tag = hi_tag(object) - HEADER_TYPE;
#ifdef FACTOR_DEBUG
assert(tag < TYPE_COUNT - HEADER_TYPE);
#endif
return array_nth(hi_tag_methods,tag);
}
static CELL lookup_hairy_method(CELL object, CELL methods)
{
CELL method = array_nth(untag_object(methods),TAG(object));
if(type_of(method) == WORD_TYPE)
return method;
else
{
switch(TAG(object))
{
case TUPLE_TYPE:
return lookup_tuple_method(object,method);
break;
case OBJECT_TYPE:
return lookup_hi_tag_method(object,method);
break;
default:
critical_error("Bad methods array",methods);
return -1;
}
}
}
CELL lookup_method(CELL object, CELL methods)
{
if(!HI_TAG_OR_TUPLE_P(object))
return array_nth(untag_object(methods),TAG(object));
else
return lookup_hairy_method(object,methods);
}
void primitive_lookup_method(void)
{
CELL methods = dpop();
CELL object = dpop();
dpush(lookup_method(object,methods));
}
CELL object_class(CELL object)
{
if(!HI_TAG_OR_TUPLE_P(object))
return tag_fixnum(TAG(object));
else
return get(HI_TAG_HEADER(object));
}
static CELL method_cache_hashcode(CELL class, F_ARRAY *array)
{
CELL capacity = (array_capacity(array) >> 1) - 1;
return ((class >> TAG_BITS) & capacity) << 1;
}
static void update_method_cache(CELL cache, CELL class, CELL method)
{
F_ARRAY *array = untag_object(cache);
CELL hashcode = method_cache_hashcode(class,array);
set_array_nth(array,hashcode,class);
set_array_nth(array,hashcode + 1,method);
}
void primitive_mega_cache_miss(void)
{
megamorphic_cache_misses++;
CELL cache = dpop();
F_FIXNUM index = untag_fixnum_fast(dpop());
CELL methods = dpop();
CELL object = get(ds - index * CELLS);
CELL class = object_class(object);
CELL method = lookup_method(object,methods);
update_method_cache(cache,class,method);
dpush(method);
}
void primitive_reset_dispatch_stats(void)
{
megamorphic_cache_hits = megamorphic_cache_misses = 0;
}
void primitive_dispatch_stats(void)
{
GROWABLE_ARRAY(stats);
GROWABLE_ARRAY_ADD(stats,allot_cell(megamorphic_cache_hits));
GROWABLE_ARRAY_ADD(stats,allot_cell(megamorphic_cache_misses));
GROWABLE_ARRAY_TRIM(stats);
GROWABLE_ARRAY_DONE(stats);
dpush(stats);
}
void jit_emit_class_lookup(F_JIT *jit, F_FIXNUM index, CELL type)
{
jit_emit_with(jit,userenv[PIC_LOAD],tag_fixnum(-index * CELLS));
jit_emit(jit,userenv[type]);
}
void jit_emit_mega_cache_lookup(F_JIT *jit, CELL methods, F_FIXNUM index, CELL cache)
{
/* Generate machine code to determine the object's class. */
jit_emit_class_lookup(jit,index,PIC_HI_TAG_TUPLE);
/* Do a cache lookup. */
jit_emit_with(jit,userenv[MEGA_LOOKUP],cache);
/* If we end up here, the cache missed. */
jit_emit(jit,userenv[JIT_PROLOG]);
/* Push index, method table and cache on the stack. */
jit_push(jit,methods);
jit_push(jit,tag_fixnum(index));
jit_push(jit,cache);
jit_word_call(jit,userenv[MEGA_MISS_WORD]);
/* Now the new method has been stored into the cache, and its on
the stack. */
jit_emit(jit,userenv[JIT_EPILOG]);
jit_emit(jit,userenv[JIT_EXECUTE_JUMP]);
}

0
vmpp/dispatch.cpp → vm/dispatch.cpp
View File

16
vm/dispatch.h
View File

@ -1,16 +0,0 @@
CELL megamorphic_cache_hits;
CELL megamorphic_cache_misses;
CELL lookup_method(CELL object, CELL methods);
void primitive_lookup_method(void);
CELL object_class(CELL object);
void primitive_mega_cache_miss(void);
void primitive_reset_dispatch_stats(void);
void primitive_dispatch_stats(void);
void jit_emit_class_lookup(F_JIT *jit, F_FIXNUM index, CELL type);
void jit_emit_mega_cache_lookup(F_JIT *jit, CELL methods, F_FIXNUM index, CELL cache);

0
vmpp/dispatch.hpp → vm/dispatch.hpp
View File

151
vm/errors.c
View File

@ -1,151 +0,0 @@
#include "master.h"
void out_of_memory(void)
{
print_string("Out of memory\n\n");
dump_generations();
exit(1);
}
void fatal_error(char* msg, CELL tagged)
{
print_string("fatal_error: "); print_string(msg);
print_string(": "); print_cell_hex(tagged); nl();
exit(1);
}
void critical_error(char* msg, CELL tagged)
{
print_string("You have triggered a bug in Factor. Please report.\n");
print_string("critical_error: "); print_string(msg);
print_string(": "); print_cell_hex(tagged); nl();
factorbug();
}
void throw_error(CELL error, F_STACK_FRAME *callstack_top)
{
/* If the error handler is set, we rewind any C stack frames and
pass the error to user-space. */
if(userenv[BREAK_ENV] != F)
{
/* If error was thrown during heap scan, we re-enable the GC */
gc_off = false;
/* Reset local roots */
gc_locals = gc_locals_region->start - CELLS;
extra_roots = extra_roots_region->start - CELLS;
/* If we had an underflow or overflow, stack pointers might be
out of bounds */
fix_stacks();
dpush(error);
/* Errors thrown from C code pass NULL for this parameter.
Errors thrown from Factor code, or signal handlers, pass the
actual stack pointer at the time, since the saved pointer is
not necessarily up to date at that point. */
if(callstack_top)
{
callstack_top = fix_callstack_top(callstack_top,
stack_chain->callstack_bottom);
}
else
callstack_top = stack_chain->callstack_top;
throw_impl(userenv[BREAK_ENV],callstack_top);
}
/* Error was thrown in early startup before error handler is set, just
crash. */
else
{
print_string("You have triggered a bug in Factor. Please report.\n");
print_string("early_error: ");
print_obj(error);
nl();
factorbug();
}
}
void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2,
F_STACK_FRAME *callstack_top)
{
throw_error(allot_array_4(userenv[ERROR_ENV],
tag_fixnum(error),arg1,arg2),callstack_top);
}
void type_error(CELL type, CELL tagged)
{
general_error(ERROR_TYPE,tag_fixnum(type),tagged,NULL);
}
void not_implemented_error(void)
{
general_error(ERROR_NOT_IMPLEMENTED,F,F,NULL);
}
/* Test if 'fault' is in the guard page at the top or bottom (depending on
offset being 0 or -1) of area+area_size */
bool in_page(CELL fault, CELL area, CELL area_size, int offset)
{
int pagesize = getpagesize();
area += area_size;
area += offset * pagesize;
return fault >= area && fault <= area + pagesize;
}
void memory_protection_error(CELL addr, F_STACK_FRAME *native_stack)
{
if(in_page(addr, ds_bot, 0, -1))
general_error(ERROR_DS_UNDERFLOW,F,F,native_stack);
else if(in_page(addr, ds_bot, ds_size, 0))
general_error(ERROR_DS_OVERFLOW,F,F,native_stack);
else if(in_page(addr, rs_bot, 0, -1))
general_error(ERROR_RS_UNDERFLOW,F,F,native_stack);
else if(in_page(addr, rs_bot, rs_size, 0))
general_error(ERROR_RS_OVERFLOW,F,F,native_stack);
else if(in_page(addr, nursery.end, 0, 0))
critical_error("allot_object() missed GC check",0);
else if(in_page(addr, gc_locals_region->start, 0, -1))
critical_error("gc locals underflow",0);
else if(in_page(addr, gc_locals_region->end, 0, 0))
critical_error("gc locals overflow",0);
else if(in_page(addr, extra_roots_region->start, 0, -1))
critical_error("extra roots underflow",0);
else if(in_page(addr, extra_roots_region->end, 0, 0))
critical_error("extra roots overflow",0);
else
general_error(ERROR_MEMORY,allot_cell(addr),F,native_stack);
}
void signal_error(int signal, F_STACK_FRAME *native_stack)
{
general_error(ERROR_SIGNAL,tag_fixnum(signal),F,native_stack);
}
void divide_by_zero_error(void)
{
general_error(ERROR_DIVIDE_BY_ZERO,F,F,NULL);
}
void memory_signal_handler_impl(void)
{
memory_protection_error(signal_fault_addr,signal_callstack_top);
}
void misc_signal_handler_impl(void)
{
signal_error(signal_number,signal_callstack_top);
}
void primitive_call_clear(void)
{
throw_impl(dpop(),stack_chain->callstack_bottom);
}
/* For testing purposes */
void primitive_unimplemented(void)
{
not_implemented_error();
}

0
vmpp/errors.cpp → vm/errors.cpp
View File

58
vm/errors.h
View File

@ -1,58 +0,0 @@
/* Runtime errors */
typedef enum
{
ERROR_EXPIRED = 0,
ERROR_IO,
ERROR_NOT_IMPLEMENTED,
ERROR_TYPE,
ERROR_DIVIDE_BY_ZERO,
ERROR_SIGNAL,
ERROR_ARRAY_SIZE,
ERROR_C_STRING,
ERROR_FFI,
ERROR_HEAP_SCAN,
ERROR_UNDEFINED_SYMBOL,
ERROR_DS_UNDERFLOW,
ERROR_DS_OVERFLOW,
ERROR_RS_UNDERFLOW,
ERROR_RS_OVERFLOW,
ERROR_MEMORY,
} F_ERRORTYPE;
void out_of_memory(void);
void fatal_error(char* msg, CELL tagged);
void critical_error(char* msg, CELL tagged);
void primitive_die(void);
void throw_error(CELL error, F_STACK_FRAME *native_stack);
void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2, F_STACK_FRAME *native_stack);
void divide_by_zero_error(void);
void memory_protection_error(CELL addr, F_STACK_FRAME *native_stack);
void signal_error(int signal, F_STACK_FRAME *native_stack);
void type_error(CELL type, CELL tagged);
void not_implemented_error(void);
void primitive_call_clear(void);
INLINE void type_check(CELL type, CELL tagged)
{
if(type_of(tagged) != type) type_error(type,tagged);
}
#define DEFINE_UNTAG(type,check,name) \
INLINE type *untag_##name(CELL obj) \
{ \
type_check(check,obj); \
return untag_object(obj); \
}
/* Global variables used to pass fault handler state from signal handler to
user-space */
CELL signal_number;
CELL signal_fault_addr;
void *signal_callstack_top;
void memory_signal_handler_impl(void);
void misc_signal_handler_impl(void);
void primitive_unimplemented(void);

0
vmpp/errors.hpp → vm/errors.hpp
View File

219
vm/factor.c
View File

@ -1,219 +0,0 @@
#include "master.h"
void default_parameters(F_PARAMETERS *p)
{
p->image_path = NULL;
/* We make a wild guess here that if we're running on ARM, we don't
have a lot of memory. */
#ifdef FACTOR_ARM
p->ds_size = 8 * CELLS;
p->rs_size = 8 * CELLS;
p->gen_count = 2;
p->code_size = 4;
p->young_size = 1;
p->aging_size = 1;
p->tenured_size = 6;
#else
p->ds_size = 32 * CELLS;
p->rs_size = 32 * CELLS;
p->gen_count = 3;
p->code_size = 8 * CELLS;
p->young_size = CELLS / 4;
p->aging_size = CELLS / 2;
p->tenured_size = 4 * CELLS;
#endif
p->max_pic_size = 3;
p->secure_gc = false;
p->fep = false;
#ifdef WINDOWS
p->console = false;
#else
p->console = true;
#endif
p->stack_traces = true;
}
INLINE bool factor_arg(const F_CHAR* str, const F_CHAR* arg, CELL* value)
{
int val;
if(SSCANF(str,arg,&val) > 0)
{
*value = val;
return true;
}
else
return false;
}
void init_parameters_from_args(F_PARAMETERS *p, int argc, F_CHAR **argv)
{
default_parameters(p);
p->executable_path = argv[0];
int i = 0;
for(i = 1; i < argc; i++)
{
if(factor_arg(argv[i],STRING_LITERAL("-datastack=%d"),&p->ds_size));
else if(factor_arg(argv[i],STRING_LITERAL("-retainstack=%d"),&p->rs_size));
else if(factor_arg(argv[i],STRING_LITERAL("-generations=%d"),&p->gen_count));
else if(factor_arg(argv[i],STRING_LITERAL("-young=%d"),&p->young_size));
else if(factor_arg(argv[i],STRING_LITERAL("-aging=%d"),&p->aging_size));
else if(factor_arg(argv[i],STRING_LITERAL("-tenured=%d"),&p->tenured_size));
else if(factor_arg(argv[i],STRING_LITERAL("-codeheap=%d"),&p->code_size));
else if(factor_arg(argv[i],STRING_LITERAL("-pic=%d"),&p->max_pic_size));
else if(STRCMP(argv[i],STRING_LITERAL("-securegc")) == 0) p->secure_gc = true;
else if(STRCMP(argv[i],STRING_LITERAL("-fep")) == 0) p->fep = true;
else if(STRNCMP(argv[i],STRING_LITERAL("-i="),3) == 0) p->image_path = argv[i] + 3;
else if(STRCMP(argv[i],STRING_LITERAL("-console")) == 0) p->console = true;
else if(STRCMP(argv[i],STRING_LITERAL("-no-stack-traces")) == 0) p->stack_traces = false;
}
}
/* Do some initialization that we do once only */
void do_stage1_init(void)
{
print_string("*** Stage 2 early init... ");
fflush(stdout);
compile_all_words();
userenv[STAGE2_ENV] = T;
print_string("done\n");
fflush(stdout);
}
void init_factor(F_PARAMETERS *p)
{
/* Kilobytes */
p->ds_size = align_page(p->ds_size << 10);
p->rs_size = align_page(p->rs_size << 10);
/* Megabytes */
p->young_size <<= 20;
p->aging_size <<= 20;
p->tenured_size <<= 20;
p->code_size <<= 20;
/* Disable GC during init as a sanity check */
gc_off = true;
/* OS-specific initialization */
early_init();
const F_CHAR *executable_path = vm_executable_path();
if(executable_path)
p->executable_path = executable_path;
if(p->image_path == NULL)
p->image_path = default_image_path();
srand(current_micros());
init_ffi();
init_stacks(p->ds_size,p->rs_size);
load_image(p);
init_c_io();
init_inline_caching(p->max_pic_size);
#ifndef FACTOR_DEBUG
init_signals();
#endif
if(p->console)
open_console();
stack_chain = NULL;
profiling_p = false;
performing_gc = false;
last_code_heap_scan = NURSERY;
collecting_aging_again = false;
userenv[CPU_ENV] = tag_object(from_char_string(FACTOR_CPU_STRING));
userenv[OS_ENV] = tag_object(from_char_string(FACTOR_OS_STRING));
userenv[CELL_SIZE_ENV] = tag_fixnum(sizeof(CELL));
userenv[EXECUTABLE_ENV] = (p->executable_path ? tag_object(from_native_string(p->executable_path)) : F);
userenv[ARGS_ENV] = F;
userenv[EMBEDDED_ENV] = F;
/* We can GC now */
gc_off = false;
if(!stage2)
{
userenv[STACK_TRACES_ENV] = tag_boolean(p->stack_traces);
do_stage1_init();
}
}
/* May allocate memory */
void pass_args_to_factor(int argc, F_CHAR **argv)
{
F_ARRAY *args = allot_array(ARRAY_TYPE,argc,F);
int i;
for(i = 1; i < argc; i++)
{
REGISTER_UNTAGGED(args);
CELL arg = tag_object(from_native_string(argv[i]));
UNREGISTER_UNTAGGED(args);
set_array_nth(args,i,arg);
}
userenv[ARGS_ENV] = tag_array(args);
}
void start_factor(F_PARAMETERS *p)
{
if(p->fep) factorbug();
nest_stacks();
c_to_factor_toplevel(userenv[BOOT_ENV]);
unnest_stacks();
}
void start_embedded_factor(F_PARAMETERS *p)
{
userenv[EMBEDDED_ENV] = T;
start_factor(p);
}
void start_standalone_factor(int argc, F_CHAR **argv)
{
F_PARAMETERS p;
default_parameters(&p);
init_parameters_from_args(&p,argc,argv);
init_factor(&p);
pass_args_to_factor(argc,argv);
start_factor(&p);
}
char *factor_eval_string(char *string)
{
char* (*callback)(char*) = alien_offset(userenv[EVAL_CALLBACK_ENV]);
return callback(string);
}
void factor_eval_free(char *result)
{
free(result);
}
void factor_yield(void)
{
void (*callback)() = alien_offset(userenv[YIELD_CALLBACK_ENV]);
callback();
}
void factor_sleep(long us)
{
void (*callback)() = alien_offset(userenv[SLEEP_CALLBACK_ENV]);
callback(us);
}

0
vmpp/factor.cpp → vm/factor.cpp
View File

11
vm/factor.h
View File

@ -1,11 +0,0 @@
DLLEXPORT void default_parameters(F_PARAMETERS *p);
DLLEXPORT void init_parameters_from_args(F_PARAMETERS *p, int argc, F_CHAR **argv);
DLLEXPORT void init_factor(F_PARAMETERS *p);
DLLEXPORT void pass_args_to_factor(int argc, F_CHAR **argv);
DLLEXPORT void start_embedded_factor(F_PARAMETERS *p);
DLLEXPORT void start_standalone_factor(int argc, F_CHAR **argv);
DLLEXPORT char *factor_eval_string(char *string);
DLLEXPORT void factor_eval_free(char *result);
DLLEXPORT void factor_yield(void);
DLLEXPORT void factor_sleep(long ms);

0
vmpp/factor.hpp → vm/factor.hpp
View File

6
vm/ffi_test.c
View File

@ -1,8 +1,10 @@
/* This file is linked into the runtime for the sole purpose
* of testing FFI code. */
#include "master.h"
#include "ffi_test.h"
#include <assert.h>
#include <string.h>
void ffi_test_0(void)
{
}
@ -259,7 +261,7 @@ unsigned long long ffi_test_38(unsigned long long x, unsigned long long y)
int ffi_test_39(long a, long b, struct test_struct_13 s)
{
if(a != b) abort();
assert(a == b);
return s.x1 + s.x2 + s.x3 + s.x4 + s.x5 + s.x6;
}

2
vm/ffi_test.h
View File

@ -4,6 +4,8 @@
#define F_STDCALL
#endif
#define DLLEXPORT
DLLEXPORT void ffi_test_0(void);
DLLEXPORT int ffi_test_1(void);
DLLEXPORT int ffi_test_2(int x, int y);

40
vm/float_bits.h
View File

@ -1,40 +0,0 @@
/* Some functions for converting floating point numbers to binary
representations and vice versa */
typedef union {
double x;
u64 y;
} F_DOUBLE_BITS;
INLINE u64 double_bits(double x)
{
F_DOUBLE_BITS b;
b.x = x;
return b.y;
}
INLINE double bits_double(u64 y)
{
F_DOUBLE_BITS b;
b.y = y;
return b.x;
}
typedef union {
float x;
u32 y;
} F_FLOAT_BITS;
INLINE u32 float_bits(float x)
{
F_FLOAT_BITS b;
b.x = x;
return b.y;
}
INLINE float bits_float(u32 y)
{
F_FLOAT_BITS b;
b.y = y;
return b.x;
}

0
vmpp/float_bits.hpp → vm/float_bits.hpp
View File

0
vmpp/generic_arrays.hpp → vm/generic_arrays.hpp
View File

323
vm/image.c
View File

@ -1,323 +0,0 @@
#include "master.h"
/* Certain special objects in the image are known to the runtime */
void init_objects(F_HEADER *h)
{
memcpy(userenv,h->userenv,sizeof(userenv));
T = h->t;
bignum_zero = h->bignum_zero;
bignum_pos_one = h->bignum_pos_one;
bignum_neg_one = h->bignum_neg_one;
stage2 = (userenv[STAGE2_ENV] != F);
}
INLINE void load_data_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p)
{
CELL good_size = h->data_size + (1 << 20);
if(good_size > p->tenured_size)
p->tenured_size = good_size;
init_data_heap(p->gen_count,
p->young_size,
p->aging_size,
p->tenured_size,
p->secure_gc);
clear_gc_stats();
F_ZONE *tenured = &data_heap->generations[TENURED];
F_FIXNUM bytes_read = fread((void*)tenured->start,1,h->data_size,file);
if(bytes_read != h->data_size)
{
print_string("truncated image: ");
print_fixnum(bytes_read);
print_string(" bytes read, ");
print_cell(h->data_size);
print_string(" bytes expected\n");
fatal_error("load_data_heap failed",0);
}
tenured->here = tenured->start + h->data_size;
data_relocation_base = h->data_relocation_base;
}
INLINE void load_code_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p)
{
CELL good_size = h->code_size + (1 << 19);
if(good_size > p->code_size)
p->code_size = good_size;
init_code_heap(p->code_size);
if(h->code_size != 0)
{
F_FIXNUM bytes_read = fread(first_block(&code_heap),1,h->code_size,file);
if(bytes_read != h->code_size)
{
print_string("truncated image: ");
print_fixnum(bytes_read);
print_string(" bytes read, ");
print_cell(h->code_size);
print_string(" bytes expected\n");
fatal_error("load_code_heap failed",0);
}
}
code_relocation_base = h->code_relocation_base;
build_free_list(&code_heap,h->code_size);
}
/* Read an image file from disk, only done once during startup */
/* This function also initializes the data and code heaps */
void load_image(F_PARAMETERS *p)
{
FILE *file = OPEN_READ(p->image_path);
if(file == NULL)
{
print_string("Cannot open image file: "); print_native_string(p->image_path); nl();
print_string(strerror(errno)); nl();
exit(1);
}
F_HEADER h;
if(fread(&h,sizeof(F_HEADER),1,file) != 1)
fatal_error("Cannot read image header",0);
if(h.magic != IMAGE_MAGIC)
fatal_error("Bad image: magic number check failed",h.magic);
if(h.version != IMAGE_VERSION)
fatal_error("Bad image: version number check failed",h.version);
load_data_heap(file,&h,p);
load_code_heap(file,&h,p);
fclose(file);
init_objects(&h);
relocate_data();
relocate_code();
/* Store image path name */
userenv[IMAGE_ENV] = tag_object(from_native_string(p->image_path));
}
/* Save the current image to disk */
bool save_image(const F_CHAR *filename)
{
FILE* file;
F_HEADER h;
file = OPEN_WRITE(filename);
if(file == NULL)
{
print_string("Cannot open image file: "); print_native_string(filename); nl();
print_string(strerror(errno)); nl();
return false;
}
F_ZONE *tenured = &data_heap->generations[TENURED];
h.magic = IMAGE_MAGIC;
h.version = IMAGE_VERSION;
h.data_relocation_base = tenured->start;
h.data_size = tenured->here - tenured->start;
h.code_relocation_base = code_heap.segment->start;
h.code_size = heap_size(&code_heap);
h.t = T;
h.bignum_zero = bignum_zero;
h.bignum_pos_one = bignum_pos_one;
h.bignum_neg_one = bignum_neg_one;
CELL i;
for(i = 0; i < USER_ENV; i++)
{
if(i < FIRST_SAVE_ENV)
h.userenv[i] = F;
else
h.userenv[i] = userenv[i];
}
bool ok = true;
if(fwrite(&h,sizeof(F_HEADER),1,file) != 1) ok = false;
if(fwrite((void*)tenured->start,h.data_size,1,file) != 1) ok = false;
if(fwrite(first_block(&code_heap),h.code_size,1,file) != 1) ok = false;
if(fclose(file)) ok = false;
if(!ok)
{
print_string("save-image failed: "); print_string(strerror(errno)); nl();
}
return ok;
}
void primitive_save_image(void)
{
/* do a full GC to push everything into tenured space */
gc();
save_image(unbox_native_string());
}
void primitive_save_image_and_exit(void)
{
/* We unbox this before doing anything else. This is the only point
where we might throw an error, so we have to throw an error here since
later steps destroy the current image. */
F_CHAR *path = unbox_native_string();
REGISTER_C_STRING(path);
/* strip out userenv data which is set on startup anyway */
CELL i;
for(i = 0; i < FIRST_SAVE_ENV; i++)
userenv[i] = F;
for(i = LAST_SAVE_ENV + 1; i < STACK_TRACES_ENV; i++)
userenv[i] = F;
/* do a full GC + code heap compaction */
performing_compaction = true;
compact_code_heap();
performing_compaction = false;
UNREGISTER_C_STRING(path);
/* Save the image */
if(save_image(path))
exit(0);
else
exit(1);
}
void fixup_word(F_WORD *word)
{
if(stage2)
{
code_fixup((CELL)&word->code);
if(word->profiling) code_fixup((CELL)&word->profiling);
code_fixup((CELL)&word->xt);
}
}
void fixup_quotation(F_QUOTATION *quot)
{
if(quot->compiledp == F)
quot->xt = lazy_jit_compile;
else
{
code_fixup((CELL)&quot->xt);
code_fixup((CELL)&quot->code);
}
}
void fixup_alien(F_ALIEN *d)
{
d->expired = T;
}
void fixup_stack_frame(F_STACK_FRAME *frame)
{
code_fixup((CELL)&frame->xt);
code_fixup((CELL)&FRAME_RETURN_ADDRESS(frame));
}
void fixup_callstack_object(F_CALLSTACK *stack)
{
iterate_callstack_object(stack,fixup_stack_frame);
}
/* Initialize an object in a newly-loaded image */
void relocate_object(CELL relocating)
{
/* Tuple relocation is a bit trickier; we have to fix up the
fixup object before we can get the tuple size, so do_slots is
out of the question */
if(untag_header(get(relocating)) == TUPLE_TYPE)
{
data_fixup((CELL *)relocating + 1);
CELL scan = relocating + 2 * CELLS;
CELL size = untagged_object_size(relocating);
CELL end = relocating + size;
while(scan < end)
{
data_fixup((CELL *)scan);
scan += CELLS;
}
}
else
{
do_slots(relocating,data_fixup);
switch(untag_header(get(relocating)))
{
case WORD_TYPE:
fixup_word((F_WORD *)relocating);
break;
case QUOTATION_TYPE:
fixup_quotation((F_QUOTATION *)relocating);
break;
case DLL_TYPE:
ffi_dlopen((F_DLL *)relocating);
break;
case ALIEN_TYPE:
fixup_alien((F_ALIEN *)relocating);
break;
case CALLSTACK_TYPE:
fixup_callstack_object((F_CALLSTACK *)relocating);
break;
}
}
}
/* Since the image might have been saved with a different base address than
where it is loaded, we need to fix up pointers in the image. */
void relocate_data()
{
CELL relocating;
CELL i;
for(i = 0; i < USER_ENV; i++)
data_fixup(&userenv[i]);
data_fixup(&T);
data_fixup(&bignum_zero);
data_fixup(&bignum_pos_one);
data_fixup(&bignum_neg_one);
F_ZONE *tenured = &data_heap->generations[TENURED];
for(relocating = tenured->start;
relocating < tenured->here;
relocating += untagged_object_size(relocating))
{
allot_barrier(relocating);
relocate_object(relocating);
}
}
void fixup_code_block(F_CODE_BLOCK *compiled)
{
/* relocate literal table data */
data_fixup(&compiled->relocation);
data_fixup(&compiled->literals);
relocate_code_block(compiled);
}
void relocate_code()
{
iterate_code_heap(fixup_code_block);
}

0
vmpp/image.cpp → vm/image.cpp
View File

69
vm/image.h
View File

@ -1,69 +0,0 @@
#define IMAGE_MAGIC 0x0f0e0d0c
#define IMAGE_VERSION 4
typedef struct {
CELL magic;
CELL version;
/* all pointers in the image file are relocated from
relocation_base to here when the image is loaded */
CELL data_relocation_base;
/* size of heap */
CELL data_size;
/* code relocation base */
CELL code_relocation_base;
/* size of code heap */
CELL code_size;
/* tagged pointer to t singleton */
CELL t;
/* tagged pointer to bignum 0 */
CELL bignum_zero;
/* tagged pointer to bignum 1 */
CELL bignum_pos_one;
/* tagged pointer to bignum -1 */
CELL bignum_neg_one;
/* Initial user environment */
CELL userenv[USER_ENV];
} F_HEADER;
typedef struct {
const F_CHAR *image_path;
const F_CHAR *executable_path;
CELL ds_size, rs_size;
CELL gen_count, young_size, aging_size, tenured_size;
CELL code_size;
bool secure_gc;
bool fep;
bool console;
bool stack_traces;
CELL max_pic_size;
} F_PARAMETERS;
void load_image(F_PARAMETERS *p);
void init_objects(F_HEADER *h);
bool save_image(const F_CHAR *file);
void primitive_save_image(void);
void primitive_save_image_and_exit(void);
/* relocation base of currently loaded image's data heap */
CELL data_relocation_base;
INLINE void data_fixup(CELL *cell)
{
if(immediate_p(*cell))
return;
F_ZONE *tenured = &data_heap->generations[TENURED];
*cell += (tenured->start - data_relocation_base);
}
CELL code_relocation_base;
INLINE void code_fixup(CELL cell)
{
CELL value = get(cell);
put(cell,value + (code_heap.segment->start - code_relocation_base));
}
void relocate_data();
void relocate_code();

0
vmpp/image.hpp → vm/image.hpp
View File

248
vm/inline_cache.c
View File

@ -1,248 +0,0 @@
#include "master.h"
void init_inline_caching(int max_size)
{
max_pic_size = max_size;
}
void deallocate_inline_cache(CELL return_address)
{
/* Find the call target. */
XT old_xt = (XT)get_call_target(return_address);
F_CODE_BLOCK *old_block = (F_CODE_BLOCK *)old_xt - 1;
CELL old_type = old_block->block.type;
#ifdef FACTOR_DEBUG
/* The call target was either another PIC,
or a compiled quotation (megamorphic stub) */
assert(old_type == PIC_TYPE || old_type == QUOTATION_TYPE);
#endif
if(old_type == PIC_TYPE)
heap_free(&code_heap,&old_block->block);
}
/* Figure out what kind of type check the PIC needs based on the methods
it contains */
static CELL determine_inline_cache_type(CELL cache_entries)
{
F_ARRAY *array = untag_object(cache_entries);
bool seen_hi_tag = false, seen_tuple = false;
CELL i;
for(i = 0; i < array_capacity(array); i += 2)
{
CELL class = array_nth(array,i);
F_FIXNUM type;
/* Is it a tuple layout? */
switch(type_of(class))
{
case FIXNUM_TYPE:
type = untag_fixnum_fast(class);
if(type >= HEADER_TYPE)
seen_hi_tag = true;
break;
case ARRAY_TYPE:
seen_tuple = true;
break;
default:
critical_error("Expected a fixnum or array",class);
break;
}
}
if(seen_hi_tag && seen_tuple) return PIC_HI_TAG_TUPLE;
if(seen_hi_tag && !seen_tuple) return PIC_HI_TAG;
if(!seen_hi_tag && seen_tuple) return PIC_TUPLE;
if(!seen_hi_tag && !seen_tuple) return PIC_TAG;
critical_error("Oops",0);
return -1;
}
static void update_pic_count(CELL type)
{
pic_counts[type - PIC_TAG]++;
}
static void jit_emit_check(F_JIT *jit, CELL class)
{
CELL template;
if(TAG(class) == FIXNUM_TYPE && untag_fixnum_fast(class) < HEADER_TYPE)
template = userenv[PIC_CHECK_TAG];
else
template = userenv[PIC_CHECK];
jit_emit_with(jit,template,class);
}
/* index: 0 = top of stack, 1 = item underneath, etc
cache_entries: array of class/method pairs */
static F_CODE_BLOCK *compile_inline_cache(F_FIXNUM index, CELL generic_word, CELL methods, CELL cache_entries)
{
#ifdef FACTOR_DEBUG
type_check(WORD_TYPE,generic_word);
type_check(ARRAY_TYPE,cache_entries);
#endif
REGISTER_ROOT(generic_word);
REGISTER_ROOT(methods);
REGISTER_ROOT(cache_entries);
CELL inline_cache_type = determine_inline_cache_type(cache_entries);
update_pic_count(inline_cache_type);
F_JIT jit;
jit_init(&jit,PIC_TYPE,generic_word);
/* Generate machine code to determine the object's class. */
jit_emit_class_lookup(&jit,index,inline_cache_type);
/* Generate machine code to check, in turn, if the class is one of the cached entries. */
CELL i;
for(i = 0; i < array_capacity(untag_object(cache_entries)); i += 2)
{
/* Class equal? */
CELL class = array_nth(untag_object(cache_entries),i);
jit_emit_check(&jit,class);
/* Yes? Jump to method */
CELL method = array_nth(untag_object(cache_entries),i + 1);
jit_emit_with(&jit,userenv[PIC_HIT],method);
}
/* Generate machine code to handle a cache miss, which ultimately results in
this function being called again.
The inline-cache-miss primitive call receives enough information to
reconstruct the PIC. */
jit_push(&jit,generic_word);
jit_push(&jit,methods);
jit_push(&jit,tag_fixnum(index));
jit_push(&jit,cache_entries);
jit_word_jump(&jit,userenv[PIC_MISS_WORD]);
F_CODE_BLOCK *code = jit_make_code_block(&jit);
relocate_code_block(code);
jit_dispose(&jit);
UNREGISTER_ROOT(cache_entries);
UNREGISTER_ROOT(methods);
UNREGISTER_ROOT(generic_word);
return code;
}
/* A generic word's definition performs general method lookup. Allocates memory */
static XT megamorphic_call_stub(CELL generic_word)
{
return untag_word(generic_word)->xt;
}
static CELL inline_cache_size(CELL cache_entries)
{
return (cache_entries == F ? 0 : array_capacity(untag_array(cache_entries)) / 2);
}
/* Allocates memory */
static CELL add_inline_cache_entry(CELL cache_entries, CELL class, CELL method)
{
if(cache_entries == F)
return allot_array_2(class,method);
else
{
F_ARRAY *cache_entries_array = untag_object(cache_entries);
CELL pic_size = array_capacity(cache_entries_array);
cache_entries_array = reallot_array(cache_entries_array,pic_size + 2);
set_array_nth(cache_entries_array,pic_size,class);
set_array_nth(cache_entries_array,pic_size + 1,method);
return tag_array(cache_entries_array);
}
}
static void update_pic_transitions(CELL pic_size)
{
if(pic_size == max_pic_size)
pic_to_mega_transitions++;
else if(pic_size == 0)
cold_call_to_ic_transitions++;
else if(pic_size == 1)
ic_to_pic_transitions++;
}
/* The cache_entries parameter is either f (on cold call site) or an array (on cache miss).
Called from assembly with the actual return address */
XT inline_cache_miss(CELL return_address)
{
check_code_pointer(return_address);
/* Since each PIC is only referenced from a single call site,
if the old call target was a PIC, we can deallocate it immediately,
instead of leaving dead PICs around until the next GC. */
deallocate_inline_cache(return_address);
CELL cache_entries = dpop();
F_FIXNUM index = untag_fixnum_fast(dpop());
CELL methods = dpop();
CELL generic_word = dpop();
CELL object = get(ds - index * CELLS);
XT xt;
CELL pic_size = inline_cache_size(cache_entries);
update_pic_transitions(pic_size);
if(pic_size >= max_pic_size)
xt = megamorphic_call_stub(generic_word);
else
{
REGISTER_ROOT(generic_word);
REGISTER_ROOT(cache_entries);
REGISTER_ROOT(methods);
CELL class = object_class(object);
CELL method = lookup_method(object,methods);
cache_entries = add_inline_cache_entry(cache_entries,class,method);
xt = compile_inline_cache(index,generic_word,methods,cache_entries) + 1;
UNREGISTER_ROOT(methods);
UNREGISTER_ROOT(cache_entries);
UNREGISTER_ROOT(generic_word);
}
/* Install the new stub. */
set_call_target(return_address,(CELL)xt);
#ifdef PIC_DEBUG
printf("Updated call site 0x%lx with 0x%lx\n",return_address,(CELL)xt);
#endif
return xt;
}
void primitive_reset_inline_cache_stats(void)
{
cold_call_to_ic_transitions = ic_to_pic_transitions = pic_to_mega_transitions = 0;
CELL i;
for(i = 0; i < 4; i++) pic_counts[i] = 0;
}
void primitive_inline_cache_stats(void)
{
GROWABLE_ARRAY(stats);
GROWABLE_ARRAY_ADD(stats,allot_cell(cold_call_to_ic_transitions));
GROWABLE_ARRAY_ADD(stats,allot_cell(ic_to_pic_transitions));
GROWABLE_ARRAY_ADD(stats,allot_cell(pic_to_mega_transitions));
CELL i;
for(i = 0; i < 4; i++)
GROWABLE_ARRAY_ADD(stats,allot_cell(pic_counts[i]));
GROWABLE_ARRAY_TRIM(stats);
GROWABLE_ARRAY_DONE(stats);
dpush(stats);
}

0
vmpp/inline_cache.cpp → vm/inline_cache.cpp
View File

17
vm/inline_cache.h
View File

@ -1,17 +0,0 @@
CELL max_pic_size;
CELL cold_call_to_ic_transitions;
CELL ic_to_pic_transitions;
CELL pic_to_mega_transitions;
/* PIC_TAG, PIC_HI_TAG, PIC_TUPLE, PIC_HI_TAG_TUPLE */
CELL pic_counts[4];
void init_inline_caching(int max_size);
void primitive_inline_cache_miss(void);
XT inline_cache_miss(CELL return_address);
void primitive_reset_inline_cache_stats(void);
void primitive_inline_cache_stats(void);

0
vmpp/inline_cache.hpp → vm/inline_cache.hpp
View File

226
vm/io.c
View File

@ -1,226 +0,0 @@
#include "master.h"
/* Simple wrappers for ANSI C I/O functions, used for bootstrapping.
Note the ugly loop logic in almost every function; we have to handle EINTR
and restart the operation if the system call was interrupted. Naive
applications don't do this, but then they quickly fail if one enables
itimer()s or other signals.
The Factor library provides platform-specific code for Unix and Windows
with many more capabilities so these words are not usually used in
normal operation. */
void init_c_io(void)
{
userenv[STDIN_ENV] = allot_alien(F,(CELL)stdin);
userenv[STDOUT_ENV] = allot_alien(F,(CELL)stdout);
userenv[STDERR_ENV] = allot_alien(F,(CELL)stderr);
}
void io_error(void)
{
#ifndef WINCE
if(errno == EINTR)
return;
#endif
CELL error = tag_object(from_char_string(strerror(errno)));
general_error(ERROR_IO,error,F,NULL);
}
void primitive_fopen(void)
{
char *mode = unbox_char_string();
REGISTER_C_STRING(mode);
char *path = unbox_char_string();
UNREGISTER_C_STRING(mode);
for(;;)
{
FILE *file = fopen(path,mode);
if(file == NULL)
io_error();
else
{
box_alien(file);
break;
}
}
}
void primitive_fgetc(void)
{
FILE* file = unbox_alien();
for(;;)
{
int c = fgetc(file);
if(c == EOF)
{
if(feof(file))
{
dpush(F);
break;
}
else
io_error();
}
else
{
dpush(tag_fixnum(c));
break;
}
}
}
void primitive_fread(void)
{
FILE* file = unbox_alien();
CELL size = unbox_array_size();
if(size == 0)
{
dpush(tag_object(allot_string(0,0)));
return;
}
F_BYTE_ARRAY *buf = allot_byte_array(size);
for(;;)
{
int c = fread(buf + 1,1,size,file);
if(c <= 0)
{
if(feof(file))
{
dpush(F);
break;
}
else
io_error();
}
else
{
if(c != size)
{
REGISTER_UNTAGGED(buf);
F_BYTE_ARRAY *new_buf = allot_byte_array(c);
UNREGISTER_UNTAGGED(buf);
memcpy(new_buf + 1, buf + 1,c);
buf = new_buf;
}
dpush(tag_object(buf));
break;
}
}
}
void primitive_fputc(void)
{
FILE *file = unbox_alien();
F_FIXNUM ch = to_fixnum(dpop());
for(;;)
{
if(fputc(ch,file) == EOF)
{
io_error();
/* Still here? EINTR */
}
else
break;
}
}
void primitive_fwrite(void)
{
FILE *file = unbox_alien();
F_BYTE_ARRAY *text = untag_byte_array(dpop());
F_FIXNUM length = array_capacity(text);
char *string = (char *)(text + 1);
if(length == 0)
return;
for(;;)
{
size_t written = fwrite(string,1,length,file);
if(written == length)
break;
else
{
if(feof(file))
break;
else
io_error();
/* Still here? EINTR */
length -= written;
string += written;
}
}
}
void primitive_fseek(void)
{
int whence = to_fixnum(dpop());
FILE *file = unbox_alien();
off_t offset = to_signed_8(dpop());
switch(whence)
{
case 0: whence = SEEK_SET; break;
case 1: whence = SEEK_CUR; break;
case 2: whence = SEEK_END; break;
default:
critical_error("Bad value for whence",whence);
break;
}
if(FSEEK(file,offset,whence) == -1)
{
io_error();
/* Still here? EINTR */
critical_error("Don't know what to do; EINTR from fseek()?",0);
}
}
void primitive_fflush(void)
{
FILE *file = unbox_alien();
for(;;)
{
if(fflush(file) == EOF)
io_error();
else
break;
}
}
void primitive_fclose(void)
{
FILE *file = unbox_alien();
for(;;)
{
if(fclose(file) == EOF)
io_error();
else
break;
}
}
/* This function is used by FFI I/O. Accessing the errno global directly is
not portable, since on some libc's errno is not a global but a funky macro that
reads thread-local storage. */
int err_no(void)
{
return errno;
}
void clear_err_no(void)
{
errno = 0;
}

0
vmpp/io.cpp → vm/io.cpp
View File

18
vm/io.h
View File

@ -1,18 +0,0 @@
void init_c_io(void);
void io_error(void);
DLLEXPORT int err_no(void);
DLLEXPORT void clear_err_no(void);
void primitive_fopen(void);
void primitive_fgetc(void);
void primitive_fread(void);
void primitive_fputc(void);
void primitive_fwrite(void);
void primitive_fflush(void);
void primitive_fseek(void);
void primitive_fclose(void);
/* Platform specific primitives */
void primitive_open_file(void);
void primitive_existsp(void);
void primitive_read_dir(void);

0
vmpp/io.hpp → vm/io.hpp
View File

119
vm/jit.c
View File

@ -1,119 +0,0 @@
#include "master.h"
/* Simple code generator used by:
- profiler (profiler.c),
- quotation compiler (quotations.c),
- megamorphic caches (dispatch.c),
- polymorphic inline caches (inline_cache.c) */
/* Allocates memory */
void jit_init(F_JIT *jit, CELL jit_type, CELL owner)
{
jit->owner = owner;
REGISTER_ROOT(jit->owner);
jit->type = jit_type;
jit->code = make_growable_byte_array();
REGISTER_ROOT(jit->code.array);
jit->relocation = make_growable_byte_array();
REGISTER_ROOT(jit->relocation.array);
jit->literals = make_growable_array();
REGISTER_ROOT(jit->literals.array);
if(stack_traces_p())
growable_array_add(&jit->literals,jit->owner);
jit->computing_offset_p = false;
}
/* Facility to convert compiled code offsets to quotation offsets.
Call jit_compute_offset() with the compiled code offset, then emit
code, and at the end jit->position is the quotation position. */
void jit_compute_position(F_JIT *jit, CELL offset)
{
jit->computing_offset_p = true;
jit->position = 0;
jit->offset = offset;
}
/* Allocates memory */
F_CODE_BLOCK *jit_make_code_block(F_JIT *jit)
{
growable_byte_array_trim(&jit->code);
growable_byte_array_trim(&jit->relocation);
growable_array_trim(&jit->literals);
F_CODE_BLOCK *code = add_code_block(
jit->type,
untag_object(jit->code.array),
NULL, /* no labels */
jit->relocation.array,
jit->literals.array);
return code;
}
void jit_dispose(F_JIT *jit)
{
UNREGISTER_ROOT(jit->literals.array);
UNREGISTER_ROOT(jit->relocation.array);
UNREGISTER_ROOT(jit->code.array);
UNREGISTER_ROOT(jit->owner);
}
static F_REL rel_to_emit(F_JIT *jit, CELL template, bool *rel_p)
{
F_ARRAY *quadruple = untag_object(template);
CELL rel_class = array_nth(quadruple,1);
CELL rel_type = array_nth(quadruple,2);
CELL offset = array_nth(quadruple,3);
if(rel_class == F)
{
*rel_p = false;
return 0;
}
else
{
*rel_p = true;
return (untag_fixnum_fast(rel_type) << 28)
| (untag_fixnum_fast(rel_class) << 24)
| ((jit->code.count + untag_fixnum_fast(offset)));
}
}
/* Allocates memory */
void jit_emit(F_JIT *jit, CELL template)
{
REGISTER_ROOT(template);
bool rel_p;
F_REL rel = rel_to_emit(jit,template,&rel_p);
if(rel_p) growable_byte_array_append(&jit->relocation,&rel,sizeof(F_REL));
F_BYTE_ARRAY *code = code_to_emit(template);
if(jit->computing_offset_p)
{
CELL size = array_capacity(code);
if(jit->offset == 0)
{
jit->position--;
jit->computing_offset_p = false;
}
else if(jit->offset < size)
{
jit->position++;
jit->computing_offset_p = false;
}
else
jit->offset -= size;
}
growable_byte_array_append(&jit->code,code + 1,array_capacity(code));
UNREGISTER_ROOT(template);
}

0
vmpp/jit.cpp → vm/jit.cpp
View File

87
vm/jit.h
View File

@ -1,87 +0,0 @@
typedef struct {
CELL type;
CELL owner;
F_GROWABLE_BYTE_ARRAY code;
F_GROWABLE_BYTE_ARRAY relocation;
F_GROWABLE_ARRAY literals;
bool computing_offset_p;
F_FIXNUM position;
CELL offset;
} F_JIT;
void jit_init(F_JIT *jit, CELL jit_type, CELL owner);
void jit_compute_position(F_JIT *jit, CELL offset);
F_CODE_BLOCK *jit_make_code_block(F_JIT *jit);
void jit_dispose(F_JIT *jit);
INLINE F_BYTE_ARRAY *code_to_emit(CELL template)
{
return untag_object(array_nth(untag_object(template),0));
}
void jit_emit(F_JIT *jit, CELL template);
/* Allocates memory */
INLINE void jit_add_literal(F_JIT *jit, CELL literal)
{
growable_array_add(&jit->literals,literal);
}
/* Allocates memory */
INLINE void jit_emit_with(F_JIT *jit, CELL template, CELL argument)
{
REGISTER_ROOT(template);
jit_add_literal(jit,argument);
UNREGISTER_ROOT(template);
jit_emit(jit,template);
}
/* Allocates memory */
INLINE void jit_push(F_JIT *jit, CELL literal)
{
jit_emit_with(jit,userenv[JIT_PUSH_IMMEDIATE],literal);
}
/* Allocates memory */
INLINE void jit_word_jump(F_JIT *jit, CELL word)
{
jit_emit_with(jit,userenv[JIT_WORD_JUMP],word);
}
/* Allocates memory */
INLINE void jit_word_call(F_JIT *jit, CELL word)
{
jit_emit_with(jit,userenv[JIT_WORD_CALL],word);
}
/* Allocates memory */
INLINE void jit_emit_subprimitive(F_JIT *jit, F_WORD *word)
{
REGISTER_UNTAGGED(word);
if(array_nth(untag_object(word->subprimitive),1) != F)
jit_add_literal(jit,T);
UNREGISTER_UNTAGGED(word);
jit_emit(jit,word->subprimitive);
}
INLINE F_FIXNUM jit_get_position(F_JIT *jit)
{
if(jit->computing_offset_p)
{
/* If this is still on, jit_emit() didn't clear it,
so the offset was out of bounds */
return -1;
}
else
return jit->position;
}
INLINE void jit_set_position(F_JIT *jit, F_FIXNUM position)
{
if(jit->computing_offset_p)
jit->position = position;
}

0
vmpp/jit.hpp → vm/jit.hpp
View File

259
vm/layouts.h
View File

@ -1,259 +0,0 @@
#define INLINE inline static
typedef unsigned char u8;
typedef unsigned short u16;
typedef unsigned int u32;
typedef unsigned long long u64;
typedef signed char s8;
typedef signed short s16;
typedef signed int s32;
typedef signed long long s64;
#ifdef _WIN64
typedef long long F_FIXNUM;
typedef unsigned long long CELL;
#else
typedef long F_FIXNUM;
typedef unsigned long CELL;
#endif
#define CELLS ((signed)sizeof(CELL))
#define WORD_SIZE (CELLS*8)
#define HALF_WORD_SIZE (CELLS*4)
#define HALF_WORD_MASK (((unsigned long)1<<HALF_WORD_SIZE)-1)
#define TAG_MASK 7
#define TAG_BITS 3
#define TAG(cell) ((CELL)(cell) & TAG_MASK)
#define UNTAG(cell) ((CELL)(cell) & ~TAG_MASK)
#define RETAG(cell,tag) (UNTAG(cell) | (tag))
/*** Tags ***/
#define FIXNUM_TYPE 0
#define BIGNUM_TYPE 1
#define ARRAY_TYPE 2
#define FLOAT_TYPE 3
#define QUOTATION_TYPE 4
#define F_TYPE 5
#define OBJECT_TYPE 6
#define TUPLE_TYPE 7
#define HI_TAG_OR_TUPLE_P(cell) (((CELL)(cell) & 6) == 6)
#define HI_TAG_HEADER(cell) (((CELL)(cell) & 1) * CELLS + UNTAG(cell))
/* Canonical F object */
#define F F_TYPE
#define HEADER_TYPE 8 /* anything less than this is a tag */
#define GC_COLLECTED 5 /* can be anything other than FIXNUM_TYPE */
/*** Header types ***/
#define WRAPPER_TYPE 8
#define BYTE_ARRAY_TYPE 9
#define CALLSTACK_TYPE 10
#define STRING_TYPE 11
#define WORD_TYPE 12
#define DLL_TYPE 13
#define ALIEN_TYPE 14
#define TYPE_COUNT 15
/* Not a real type, but F_CODE_BLOCK's type field can be set to this */
#define PIC_TYPE 69
INLINE bool immediate_p(CELL obj)
{
return (obj == F || TAG(obj) == FIXNUM_TYPE);
}
INLINE F_FIXNUM untag_fixnum_fast(CELL tagged)
{
return ((F_FIXNUM)tagged) >> TAG_BITS;
}
INLINE CELL tag_fixnum(F_FIXNUM untagged)
{
return RETAG(untagged << TAG_BITS,FIXNUM_TYPE);
}
INLINE void *untag_object(CELL tagged)
{
return (void *)UNTAG(tagged);
}
typedef void *XT;
/* Assembly code makes assumptions about the layout of this struct */
typedef struct {
CELL header;
/* tagged */
CELL capacity;
} F_ARRAY;
typedef F_ARRAY F_BYTE_ARRAY;
/* Assembly code makes assumptions about the layout of this struct */
typedef struct {
CELL header;
/* tagged num of chars */
CELL length;
/* tagged */
CELL aux;
/* tagged */
CELL hashcode;
} F_STRING;
/* The compiled code heap is structured into blocks. */
typedef enum
{
B_FREE,
B_ALLOCATED,
B_MARKED
} F_BLOCK_STATUS;
typedef struct _F_BLOCK
{
char status; /* free or allocated? */
char type; /* this is WORD_TYPE or QUOTATION_TYPE */
char last_scan; /* the youngest generation in which this block's literals may live */
char needs_fixup; /* is this a new block that needs full fixup? */
/* In bytes, includes this header */
CELL size;
/* Used during compaction */
struct _F_BLOCK *forwarding;
} F_BLOCK;
typedef struct _F_FREE_BLOCK
{
F_BLOCK block;
/* Filled in on image load */
struct _F_FREE_BLOCK *next_free;
} F_FREE_BLOCK;
typedef struct
{
F_BLOCK block;
CELL literals; /* # bytes */
CELL relocation; /* tagged pointer to byte-array or f */
} F_CODE_BLOCK;
/* Assembly code makes assumptions about the layout of this struct */
typedef struct {
/* TAGGED header */
CELL header;
/* TAGGED hashcode */
CELL hashcode;
/* TAGGED word name */
CELL name;
/* TAGGED word vocabulary */
CELL vocabulary;
/* TAGGED definition */
CELL def;
/* TAGGED property assoc for library code */
CELL props;
/* TAGGED alternative entry point for direct non-tail calls. Used for inline caching */
CELL direct_entry_def;
/* TAGGED call count for profiling */
CELL counter;
/* TAGGED machine code for sub-primitive */
CELL subprimitive;
/* UNTAGGED execution token: jump here to execute word */
XT xt;
/* UNTAGGED compiled code block */
F_CODE_BLOCK *code;
/* UNTAGGED profiler stub */
F_CODE_BLOCK *profiling;
} F_WORD;
/* Assembly code makes assumptions about the layout of this struct */
typedef struct {
CELL header;
CELL object;
} F_WRAPPER;
/* Assembly code makes assumptions about the layout of this struct */
typedef struct {
/* We use a union here to force the float value to be aligned on an
8-byte boundary. */
union {
CELL header;
long long padding;
};
double n;
} F_FLOAT;
/* Assembly code makes assumptions about the layout of this struct */
typedef struct {
CELL header;
/* tagged */
CELL array;
/* tagged */
CELL compiledp;
/* tagged */
CELL cached_effect;
/* tagged */
CELL cache_counter;
/* UNTAGGED */
XT xt;
/* UNTAGGED compiled code block */
F_CODE_BLOCK *code;
} F_QUOTATION;
/* Assembly code makes assumptions about the layout of this struct */
typedef struct {
CELL header;
/* tagged */
CELL alien;
/* tagged */
CELL expired;
/* untagged */
CELL displacement;
} F_ALIEN;
typedef struct {
CELL header;
/* tagged byte array holding a C string */
CELL path;
/* OS-specific handle */
void *dll;
} F_DLL;
typedef struct {
CELL header;
/* tagged */
CELL length;
} F_CALLSTACK;
typedef struct
{
XT xt;
/* Frame size in bytes */
CELL size;
} F_STACK_FRAME;
/* These are really just arrays, but certain elements have special
significance */
typedef struct
{
CELL header;
/* tagged */
CELL capacity;
/* tagged */
CELL class;
/* tagged fixnum */
CELL size;
/* tagged fixnum */
CELL echelon;
} F_TUPLE_LAYOUT;
typedef struct
{
CELL header;
/* tagged layout */
CELL layout;
} F_TUPLE;

0
vmpp/layouts.hpp → vm/layouts.hpp
View File

0
vmpp/local_roots.cpp → vm/local_roots.cpp
View File

Some files were not shown because too many files have changed in this diff Show More