CC = gcc
+CPP = g++
AR = ar
LD = ld
BUNDLE = Factor.app
LIBPATH = -L/usr/X11R6/lib
-CFLAGS = -Wall -Werror
+CFLAGS = -Wall
ifdef DEBUG
CFLAGS += -g -DFACTOR_DEBUG
endif
DLL_OBJS = $(PLAF_DLL_OBJS) \
- 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/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
+ 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
EXE_OBJS = $(PLAF_EXE_OBJS)
-TEST_OBJS = vm/ffi_test.o
+TEST_OBJS = vmpp/ffi_test.o
default:
$(MAKE) `./build-support/factor.sh make-target`
@echo "X11=1 force link with X11 libraries instead of Cocoa (only on Mac OS X)"
openbsd-x86-32:
- $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.openbsd.x86.32
+ $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.openbsd.x86.32
openbsd-x86-64:
- $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.openbsd.x86.64
+ $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.openbsd.x86.64
freebsd-x86-32:
- $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.freebsd.x86.32
+ $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.freebsd.x86.32
freebsd-x86-64:
- $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.freebsd.x86.64
+ $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.freebsd.x86.64
netbsd-x86-32:
- $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.netbsd.x86.32
+ $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.netbsd.x86.32
netbsd-x86-64:
- $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.netbsd.x86.64
+ $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.netbsd.x86.64
macosx-ppc:
- $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) macosx.app CONFIG=vm/Config.macosx.ppc
+ $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) macosx.app CONFIG=vmpp/Config.macosx.ppc
macosx-x86-32:
- $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) macosx.app CONFIG=vm/Config.macosx.x86.32
+ $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) macosx.app CONFIG=vmpp/Config.macosx.x86.32
macosx-x86-64:
- $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) macosx.app CONFIG=vm/Config.macosx.x86.64
+ $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) macosx.app CONFIG=vmpp/Config.macosx.x86.64
linux-x86-32:
- $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.linux.x86.32
+ $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.linux.x86.32
linux-x86-64:
- $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.linux.x86.64
+ $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.linux.x86.64
linux-ppc:
- $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.linux.ppc
+ $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.linux.ppc
linux-arm:
- $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.linux.arm
+ $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.linux.arm
solaris-x86-32:
- $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.solaris.x86.32
+ $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.solaris.x86.32
solaris-x86-64:
- $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.solaris.x86.64
+ $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.solaris.x86.64
winnt-x86-32:
- $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.windows.nt.x86.32
- $(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32
+ $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.windows.nt.x86.32
+ $(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vmpp/Config.windows.nt.x86.32
winnt-x86-64:
- $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.windows.nt.x86.64
- $(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64
+ $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.windows.nt.x86.64
+ $(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vmpp/Config.windows.nt.x86.64
wince-arm:
- $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.windows.ce.arm
+ $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.windows.ce.arm
macosx.app: factor
mkdir -p $(BUNDLE)/Contents/MacOS
$(EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS)
$(LINKER) $(ENGINE) $(DLL_OBJS)
- $(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
+ $(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
$(CONSOLE_EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS)
$(LINKER) $(ENGINE) $(DLL_OBJS)
- $(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
+ $(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) $(CFLAGS_CONSOLE) -o factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION) $(EXE_OBJS)
-$(TEST_LIBRARY): vm/ffi_test.o
+$(TEST_LIBRARY): vmpp/ffi_test.o
$(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o libfactor-ffi-test$(SHARED_DLL_EXTENSION) $(TEST_OBJS)
clean:
- rm -f vm/*.o
+ rm -f vmpp/*.o
rm -f factor*.dll libfactor.{a,so,dylib} libfactor-ffi-test.{a,so,dylib} Factor.app/Contents/Frameworks/libfactor.dylib
-vm/resources.o:
- $(WINDRES) vm/factor.rs vm/resources.o
+vmpp/resources.o:
+ $(WINDRES) vmpp/factor.rs vmpp/resources.o
-vm/ffi_test.o: vm/ffi_test.c
+vmpp/ffi_test.o: vmpp/ffi_test.c
$(CC) -c $(CFLAGS) $(FFI_TEST_CFLAGS) -o $@ $<
.c.o:
$(CC) -c $(CFLAGS) -o $@ $<
+.cpp.o:
+ $(CPP) -c $(CFLAGS) -o $@ $<
+
.S.o:
$(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $<
-.m.o:
- $(CC) -c $(CFLAGS) -o $@ $<
+.mm.o:
+ $(CPP) -c $(CFLAGS) -o $@ $<
.PHONY: factor
+
+.SUFFIXES: .mm
--- /dev/null
+PLAF_DLL_OBJS += vmpppp/cpu-arm.o
--- /dev/null
+include vmpppp/Config.unix
+PLAF_DLL_OBJS += vmpppp/os-genunix.o vmpp/os-freebsd.o
+CFLAGS += -export-dynamic
+LIBS = -L/usr/local/lib/ -lm $(X11_UI_LIBS)
--- /dev/null
+include vmpp/Config.freebsd
+include vmpp/Config.x86.32
--- /dev/null
+include vmpp/Config.freebsd
+include vmpp/Config.x86.64
+LIBS += -lpthread
--- /dev/null
+include vmpp/Config.unix
+PLAF_DLL_OBJS += vmpp/os-genunix.o vm/os-linux.o
+CFLAGS += -export-dynamic
+LIBS = -ldl -lm -lpthread $(X11_UI_LIBS)
--- /dev/null
+include vmpp/Config.linux
+include vmpp/Config.arm
+PLAF_DLL_OBJS += vmpp/os-linux-arm.o
--- /dev/null
+include vmpp/Config.linux
+include vmpp/Config.ppc
+CFLAGS += -mregnames
--- /dev/null
+include vmpp/Config.linux
+include vmpp/Config.x86.32
--- /dev/null
+include vmpp/Config.linux
+include vmpp/Config.x86.64
+LIBPATH = -L/usr/X11R6/lib64 -L/usr/X11R6/lib
--- /dev/null
+include vmpp/Config.unix
+CFLAGS += -fPIC
+
+PLAF_DLL_OBJS += vmpp/os-macosx.o vmpp/mach_signal.o
+
+DLL_EXTENSION = .dylib
+SHARED_DLL_EXTENSION = .dylib
+
+SHARED_FLAG = -dynamiclib
+
+ifdef X11
+ LIBS = -lm -framework Cocoa -L/opt/local/lib $(X11_UI_LIBS) -Wl,-dylib_file,/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib:/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib
+else
+ LIBS = -lm -framework Cocoa -framework AppKit
+endif
+
+LINKER = $(CPP) $(CFLAGS) -dynamiclib -single_module -std=gnu99 \
+ -current_version $(VERSION) \
+ -compatibility_version $(VERSION) \
+ -fvisibility=hidden \
+ $(LIBS) $(LIBPATH) -o
+
+LINK_WITH_ENGINE = -lfactor
--- /dev/null
+include vmpp/Config.macosx
+include vmpp/Config.ppc
+CFLAGS += -arch ppc
--- /dev/null
+include vmpp/Config.macosx
+include vmpp/Config.x86.32
--- /dev/null
+include vmpp/Config.macosx
+include vmpp/Config.x86.64
+CFLAGS += -m64
--- /dev/null
+include vmpp/Config.unix
+PLAF_DLL_OBJS += vmpp/os-genunix.o vm/os-netbsd.o
+CFLAGS += -export-dynamic
+LIBPATH = -L/usr/X11R6/lib -Wl,-rpath,/usr/X11R6/lib -L/usr/pkg/lib -Wl,-rpath,/usr/pkg/lib
+LIBS = -lm -lopenal -lalut $(X11_UI_LIBS)
--- /dev/null
+include vmpp/Config.netbsd
+include vmpp/Config.x86.32
--- /dev/null
+include vmpp/Config.netbsd
+include vmpp/Config.x86.64
--- /dev/null
+include vmpp/Config.unix
+PLAF_DLL_OBJS += vmpp/os-genunix.o vm/os-openbsd.o
+CC = egcc
+CFLAGS += -export-dynamic
+LIBS = -L/usr/local/lib/ -lm $(X11_UI_LIBS) -lz -lssl -lcrypto -lpthread
--- /dev/null
+include vmpp/Config.openbsd
+include vmpp/Config.x86.32
--- /dev/null
+include vmpp/Config.openbsd
+include vmpp/Config.x86.64
--- /dev/null
+PLAF_DLL_OBJS += vmpp/cpu-ppc.o
--- /dev/null
+include vmpp/Config.unix
+PLAF_DLL_OBJS += vmpp/os-genunix.o vm/os-solaris.o
+CFLAGS += -D_STDC_C99 -Drestrict="" -export-dynamic
+LIBS += -ldl -lsocket -lnsl -lm -R/opt/PM/lib -R/opt/csw/lib \
+ -R/usr/local/lib -R/usr/sfw/lib -R/usr/X11R6/lib \
+ -R/opt/sfw/lib $(X11_UI_LIBS)
--- /dev/null
+include vmpp/Config.solaris
+include vmpp/Config.x86.32
--- /dev/null
+include vmpp/Config.solaris
+include vmpp/Config.x86.64
--- /dev/null
+ifndef DEBUG
+ CFLAGS += -fomit-frame-pointer
+endif
+
+EXE_SUFFIX =
+DLL_PREFIX = lib
+DLL_EXTENSION = .a
+SHARED_DLL_EXTENSION = .so
+SHARED_FLAG = -shared
+
+PLAF_DLL_OBJS = vmpp/os-unix.o
+PLAF_EXE_OBJS += vmpp/main-unix.o
+
+ifdef NO_UI
+ X11_UI_LIBS =
+else
+ X11_UI_LIBS = -lpango-1.0 -lpangocairo-1.0 -lcairo -lglib-2.0 -lgobject-2.0 -lGL -lX11
+endif
+
+# CFLAGS += -fPIC
+FFI_TEST_CFLAGS = -fPIC
+
+# LINKER = gcc -shared -o
+# LINK_WITH_ENGINE = '-Wl,-rpath,$$ORIGIN' -lfactor
+
+LINKER = $(AR) rcs
+LINK_WITH_ENGINE = -Wl,--whole-archive -lfactor -Wl,-no-whole-archive
--- /dev/null
+CFLAGS += -DWINDOWS -mno-cygwin
+LIBS = -lm
+PLAF_DLL_OBJS += vmpp/os-windows.o
+SHARED_FLAG = -shared
+EXE_EXTENSION=.exe
+CONSOLE_EXTENSION=.com
+DLL_EXTENSION=.dll
+SHARED_DLL_EXTENSION=.dll
+LINKER = $(CC) -shared -mno-cygwin -o
+LINK_WITH_ENGINE = -l$(DLL_PREFIX)factor$(DLL_SUFFIX)
--- /dev/null
+CFLAGS += -DWINCE
+LIBS = -lm
+PLAF_DLL_OBJS += vmpp/os-windows-ce.o
+PLAF_EXE_OBJS += vmpp/main-windows-ce.o
+include vmpp/Config.windows
--- /dev/null
+CC = arm-wince-mingw32ce-gcc
+DLL_SUFFIX=-ce
+EXE_SUFFIX=-ce
+include vmpp/Config.windows.ce vm/Config.arm
--- /dev/null
+LIBS = -lm
+EXE_SUFFIX=
+DLL_SUFFIX=
+PLAF_DLL_OBJS += vmpp/os-windows-nt.o
+PLAF_EXE_OBJS += vmpp/resources.o
+PLAF_EXE_OBJS += vmpp/main-windows-nt.o
+CFLAGS += -mwindows
+CFLAGS_CONSOLE += -mconsole
+CONSOLE_EXTENSION = .com
+include vmpp/Config.windows
--- /dev/null
+DLL_PATH=http://factorcode.org/dlls
+WINDRES=windres
+include vmpp/Config.windows.nt
+include vmpp/Config.x86.32
--- /dev/null
+#error "lol"
+DLL_PATH=http://factorcode.org/dlls/64
+CC=$(WIN64_PATH)-gcc.exe
+WINDRES=$(WIN64_PATH)-windres.exe
+include vmpp/Config.windows.nt
+include vmpp/Config.x86.64
--- /dev/null
+BOOT_ARCH = x86
+PLAF_DLL_OBJS += vmpp/cpu-x86.32.o
+
+# gcc bug workaround
+CFLAGS += -fno-builtin-strlen -fno-builtin-strcat
--- /dev/null
+PLAF_DLL_OBJS += vmpp/cpu-x86.64.o
+CFLAGS += -DFACTOR_64
--- /dev/null
+#include "master.hpp"
+
+/* gets the address of an object representing a C pointer */
+char *alien_offset(CELL object)
+{
+ F_ALIEN *alien;
+ F_BYTE_ARRAY *byte_array;
+
+ switch(type_of(object))
+ {
+ case BYTE_ARRAY_TYPE:
+ byte_array = untag_byte_array_fast(object);
+ return (char *)(byte_array + 1);
+ case ALIEN_TYPE:
+ alien = untag_alien_fast(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. */
+char *pinned_alien_offset(CELL object)
+{
+ F_ALIEN *alien;
+
+ switch(type_of(object))
+ {
+ case ALIEN_TYPE:
+ alien = untag_alien_fast(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 */
+char *unbox_alien(void)
+{
+ return alien_offset(dpop());
+}
+
+/* make an alien */
+CELL allot_alien(CELL delegate, CELL displacement)
+{
+ REGISTER_ROOT(delegate);
+ F_ALIEN *alien = (F_ALIEN *)allot_object(ALIEN_TYPE,sizeof(F_ALIEN));
+ UNREGISTER_ROOT(delegate);
+
+ if(type_of(delegate) == ALIEN_TYPE)
+ {
+ F_ALIEN *delegate_alien = untag_alien_fast(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 = (type *)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 = (F_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);
+ }
+}
--- /dev/null
+DEFINE_UNTAG(F_ALIEN,ALIEN_TYPE,alien)
+
+CELL allot_alien(CELL delegate, CELL displacement);
+
+void primitive_displaced_alien(void);
+void primitive_alien_address(void);
+
+DLLEXPORT char *alien_offset(CELL object);
+
+DLLEXPORT char *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);
--- /dev/null
+#include "master.hpp"
+
+/* 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 = (F_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)
+{
+ 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. */
+ CELL i;
+ 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(F_ARRAY,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_array_fast(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_array_fast(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(F_ARRAY,elts);
+
+ write_barrier(array->array);
+
+ memcpy((void *)AREF(underlying,array->count),
+ (void *)AREF(elts,0),
+ elts_size * CELLS);
+
+ array->count += elts_size;
+}
--- /dev/null
+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;
+}
+
+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,2,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_array_fast(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;
--- /dev/null
+#if defined(__APPLE__) || (defined(WINDOWS) && !defined(__arm__))
+ #define MANGLE(sym) _##sym
+#else
+ #define MANGLE(sym) sym
+#endif
+
+/* Apple's PPC assembler is out of date? */
+#if defined(__APPLE__) && defined(__ppc__)
+ #define XX @
+#else
+ #define XX ;
+#endif
+
+/* The returns and args are just for documentation */
+#define DEF(returns,symbol,args) .globl MANGLE(symbol) XX \
+MANGLE(symbol)
--- /dev/null
+/* :tabSize=2:indentSize=2:noTabs=true:
+
+Copyright (C) 1989-94 Massachusetts Institute of Technology
+Portions copyright (C) 2004-2008 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. */
+
+/* Changes for Scheme 48:
+ * - Converted to ANSI.
+ * - Added bitwise operations.
+ * - Added s48 to the beginning of all externally visible names.
+ * - Cached the bignum representations of -1, 0, and 1.
+ */
+
+/* Changes for Factor:
+ * - Adapt bignumint.h for Factor memory manager
+ * - Add more bignum <-> C type conversions
+ * - Remove unused functions
+ * - Add local variable GC root recording
+ * - Remove s48 prefix from function names
+ * - Various fixes for Win64
+ */
+
+#include "master.hpp"
+
+#include <limits>
+
+#include <stdio.h>
+#include <math.h>
+
+/* Exports */
+
+int
+bignum_equal_p(bignum_type x, bignum_type y)
+{
+ return
+ ((BIGNUM_ZERO_P (x))
+ ? (BIGNUM_ZERO_P (y))
+ : ((! (BIGNUM_ZERO_P (y)))
+ && ((BIGNUM_NEGATIVE_P (x))
+ ? (BIGNUM_NEGATIVE_P (y))
+ : (! (BIGNUM_NEGATIVE_P (y))))
+ && (bignum_equal_p_unsigned (x, y))));
+}
+
+enum bignum_comparison
+bignum_compare(bignum_type x, bignum_type y)
+{
+ return
+ ((BIGNUM_ZERO_P (x))
+ ? ((BIGNUM_ZERO_P (y))
+ ? bignum_comparison_equal
+ : (BIGNUM_NEGATIVE_P (y))
+ ? bignum_comparison_greater
+ : bignum_comparison_less)
+ : (BIGNUM_ZERO_P (y))
+ ? ((BIGNUM_NEGATIVE_P (x))
+ ? bignum_comparison_less
+ : bignum_comparison_greater)
+ : (BIGNUM_NEGATIVE_P (x))
+ ? ((BIGNUM_NEGATIVE_P (y))
+ ? (bignum_compare_unsigned (y, x))
+ : (bignum_comparison_less))
+ : ((BIGNUM_NEGATIVE_P (y))
+ ? (bignum_comparison_greater)
+ : (bignum_compare_unsigned (x, y))));
+}
+
+/* allocates memory */
+bignum_type
+bignum_add(bignum_type x, bignum_type y)
+{
+ return
+ ((BIGNUM_ZERO_P (x))
+ ? (y)
+ : (BIGNUM_ZERO_P (y))
+ ? (x)
+ : ((BIGNUM_NEGATIVE_P (x))
+ ? ((BIGNUM_NEGATIVE_P (y))
+ ? (bignum_add_unsigned (x, y, 1))
+ : (bignum_subtract_unsigned (y, x)))
+ : ((BIGNUM_NEGATIVE_P (y))
+ ? (bignum_subtract_unsigned (x, y))
+ : (bignum_add_unsigned (x, y, 0)))));
+}
+
+/* allocates memory */
+bignum_type
+bignum_subtract(bignum_type x, bignum_type y)
+{
+ return
+ ((BIGNUM_ZERO_P (x))
+ ? ((BIGNUM_ZERO_P (y))
+ ? (y)
+ : (bignum_new_sign (y, (! (BIGNUM_NEGATIVE_P (y))))))
+ : ((BIGNUM_ZERO_P (y))
+ ? (x)
+ : ((BIGNUM_NEGATIVE_P (x))
+ ? ((BIGNUM_NEGATIVE_P (y))
+ ? (bignum_subtract_unsigned (y, x))
+ : (bignum_add_unsigned (x, y, 1)))
+ : ((BIGNUM_NEGATIVE_P (y))
+ ? (bignum_add_unsigned (x, y, 0))
+ : (bignum_subtract_unsigned (x, y))))));
+}
+
+/* allocates memory */
+bignum_type
+bignum_multiply(bignum_type x, bignum_type y)
+{
+ bignum_length_type x_length = (BIGNUM_LENGTH (x));
+ bignum_length_type y_length = (BIGNUM_LENGTH (y));
+ int negative_p =
+ ((BIGNUM_NEGATIVE_P (x))
+ ? (! (BIGNUM_NEGATIVE_P (y)))
+ : (BIGNUM_NEGATIVE_P (y)));
+ if (BIGNUM_ZERO_P (x))
+ return (x);
+ if (BIGNUM_ZERO_P (y))
+ return (y);
+ if (x_length == 1)
+ {
+ bignum_digit_type digit = (BIGNUM_REF (x, 0));
+ if (digit == 1)
+ return (bignum_maybe_new_sign (y, negative_p));
+ if (digit < BIGNUM_RADIX_ROOT)
+ return (bignum_multiply_unsigned_small_factor (y, digit, negative_p));
+ }
+ if (y_length == 1)
+ {
+ bignum_digit_type digit = (BIGNUM_REF (y, 0));
+ if (digit == 1)
+ return (bignum_maybe_new_sign (x, negative_p));
+ if (digit < BIGNUM_RADIX_ROOT)
+ return (bignum_multiply_unsigned_small_factor (x, digit, negative_p));
+ }
+ return (bignum_multiply_unsigned (x, y, negative_p));
+}
+
+/* allocates memory */
+void
+bignum_divide(bignum_type numerator, bignum_type denominator,
+ bignum_type * quotient, bignum_type * remainder)
+{
+ if (BIGNUM_ZERO_P (denominator))
+ {
+ divide_by_zero_error();
+ return;
+ }
+ if (BIGNUM_ZERO_P (numerator))
+ {
+ (*quotient) = numerator;
+ (*remainder) = numerator;
+ }
+ else
+ {
+ int r_negative_p = (BIGNUM_NEGATIVE_P (numerator));
+ int q_negative_p =
+ ((BIGNUM_NEGATIVE_P (denominator)) ? (! r_negative_p) : r_negative_p);
+ switch (bignum_compare_unsigned (numerator, denominator))
+ {
+ case bignum_comparison_equal:
+ {
+ (*quotient) = (BIGNUM_ONE (q_negative_p));
+ (*remainder) = (BIGNUM_ZERO ());
+ break;
+ }
+ case bignum_comparison_less:
+ {
+ (*quotient) = (BIGNUM_ZERO ());
+ (*remainder) = numerator;
+ break;
+ }
+ case bignum_comparison_greater:
+ {
+ if ((BIGNUM_LENGTH (denominator)) == 1)
+ {
+ bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
+ if (digit == 1)
+ {
+ (*quotient) =
+ (bignum_maybe_new_sign (numerator, q_negative_p));
+ (*remainder) = (BIGNUM_ZERO ());
+ break;
+ }
+ else if (digit < BIGNUM_RADIX_ROOT)
+ {
+ bignum_divide_unsigned_small_denominator
+ (numerator, digit,
+ quotient, remainder,
+ q_negative_p, r_negative_p);
+ break;
+ }
+ else
+ {
+ bignum_divide_unsigned_medium_denominator
+ (numerator, digit,
+ quotient, remainder,
+ q_negative_p, r_negative_p);
+ break;
+ }
+ }
+ bignum_divide_unsigned_large_denominator
+ (numerator, denominator,
+ quotient, remainder,
+ q_negative_p, r_negative_p);
+ break;
+ }
+ }
+ }
+}
+
+/* allocates memory */
+bignum_type
+bignum_quotient(bignum_type numerator, bignum_type denominator)
+{
+ if (BIGNUM_ZERO_P (denominator))
+ {
+ divide_by_zero_error();
+ return (BIGNUM_OUT_OF_BAND);
+ }
+ if (BIGNUM_ZERO_P (numerator))
+ return numerator;
+ {
+ int q_negative_p =
+ ((BIGNUM_NEGATIVE_P (denominator))
+ ? (! (BIGNUM_NEGATIVE_P (numerator)))
+ : (BIGNUM_NEGATIVE_P (numerator)));
+ switch (bignum_compare_unsigned (numerator, denominator))
+ {
+ case bignum_comparison_equal:
+ return (BIGNUM_ONE (q_negative_p));
+ case bignum_comparison_less:
+ return (BIGNUM_ZERO ());
+ case bignum_comparison_greater:
+ default: /* to appease gcc -Wall */
+ {
+ bignum_type quotient;
+ if ((BIGNUM_LENGTH (denominator)) == 1)
+ {
+ bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
+ if (digit == 1)
+ return (bignum_maybe_new_sign (numerator, q_negative_p));
+ if (digit < BIGNUM_RADIX_ROOT)
+ bignum_divide_unsigned_small_denominator
+ (numerator, digit,
+ ("ient), ((bignum_type *) 0),
+ q_negative_p, 0);
+ else
+ bignum_divide_unsigned_medium_denominator
+ (numerator, digit,
+ ("ient), ((bignum_type *) 0),
+ q_negative_p, 0);
+ }
+ else
+ bignum_divide_unsigned_large_denominator
+ (numerator, denominator,
+ ("ient), ((bignum_type *) 0),
+ q_negative_p, 0);
+ return (quotient);
+ }
+ }
+ }
+}
+
+/* allocates memory */
+bignum_type
+bignum_remainder(bignum_type numerator, bignum_type denominator)
+{
+ if (BIGNUM_ZERO_P (denominator))
+ {
+ divide_by_zero_error();
+ return (BIGNUM_OUT_OF_BAND);
+ }
+ if (BIGNUM_ZERO_P (numerator))
+ return numerator;
+ switch (bignum_compare_unsigned (numerator, denominator))
+ {
+ case bignum_comparison_equal:
+ return (BIGNUM_ZERO ());
+ case bignum_comparison_less:
+ return numerator;
+ case bignum_comparison_greater:
+ default: /* to appease gcc -Wall */
+ {
+ bignum_type remainder;
+ if ((BIGNUM_LENGTH (denominator)) == 1)
+ {
+ bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
+ if (digit == 1)
+ return (BIGNUM_ZERO ());
+ if (digit < BIGNUM_RADIX_ROOT)
+ return
+ (bignum_remainder_unsigned_small_denominator
+ (numerator, digit, (BIGNUM_NEGATIVE_P (numerator))));
+ bignum_divide_unsigned_medium_denominator
+ (numerator, digit,
+ ((bignum_type *) 0), (&remainder),
+ 0, (BIGNUM_NEGATIVE_P (numerator)));
+ }
+ else
+ bignum_divide_unsigned_large_denominator
+ (numerator, denominator,
+ ((bignum_type *) 0), (&remainder),
+ 0, (BIGNUM_NEGATIVE_P (numerator)));
+ return (remainder);
+ }
+ }
+}
+
+#define FOO_TO_BIGNUM(name,type,utype) \
+ bignum_type name##_to_bignum(type n) \
+ { \
+ int negative_p; \
+ bignum_digit_type result_digits [BIGNUM_DIGITS_FOR(type)]; \
+ bignum_digit_type * end_digits = result_digits; \
+ /* Special cases win when these small constants are cached. */ \
+ if (n == 0) return (BIGNUM_ZERO ()); \
+ if (n == 1) return (BIGNUM_ONE (0)); \
+ if (n < (type)0 && n == (type)-1) return (BIGNUM_ONE (1)); \
+ { \
+ utype accumulator = ((negative_p = (n < (utype)0)) ? (-n) : n); \
+ do \
+ { \
+ (*end_digits++) = (accumulator & BIGNUM_DIGIT_MASK); \
+ accumulator >>= BIGNUM_DIGIT_LENGTH; \
+ } \
+ while (accumulator != 0); \
+ } \
+ { \
+ bignum_type result = \
+ (allot_bignum ((end_digits - result_digits), negative_p)); \
+ bignum_digit_type * scan_digits = result_digits; \
+ bignum_digit_type * scan_result = (BIGNUM_START_PTR (result)); \
+ while (scan_digits < end_digits) \
+ (*scan_result++) = (*scan_digits++); \
+ return (result); \
+ } \
+ }
+
+/* all below allocate memory */
+FOO_TO_BIGNUM(cell,CELL,CELL)
+FOO_TO_BIGNUM(fixnum,F_FIXNUM,CELL)
+FOO_TO_BIGNUM(long_long,s64,u64)
+FOO_TO_BIGNUM(ulong_long,u64,u64)
+
+#define BIGNUM_TO_FOO(name,type,utype) \
+ type bignum_to_##name(bignum_type bignum) \
+ { \
+ if (BIGNUM_ZERO_P (bignum)) \
+ return (0); \
+ { \
+ utype accumulator = 0; \
+ bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); \
+ bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); \
+ while (start < scan) \
+ accumulator = ((accumulator << BIGNUM_DIGIT_LENGTH) + (*--scan)); \
+ return ((BIGNUM_NEGATIVE_P (bignum)) ? (-((type)accumulator)) : accumulator); \
+ } \
+ }
+
+/* all of the below allocate memory */
+BIGNUM_TO_FOO(cell,CELL,CELL);
+BIGNUM_TO_FOO(fixnum,F_FIXNUM,CELL);
+BIGNUM_TO_FOO(long_long,s64,u64)
+BIGNUM_TO_FOO(ulong_long,u64,u64)
+
+double
+bignum_to_double(bignum_type bignum)
+{
+ if (BIGNUM_ZERO_P (bignum))
+ return (0);
+ {
+ double accumulator = 0;
+ bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
+ while (start < scan)
+ accumulator = ((accumulator * BIGNUM_RADIX) + (*--scan));
+ return ((BIGNUM_NEGATIVE_P (bignum)) ? (-accumulator) : accumulator);
+ }
+}
+
+#define DTB_WRITE_DIGIT(factor) \
+{ \
+ significand *= (factor); \
+ digit = ((bignum_digit_type) significand); \
+ (*--scan) = digit; \
+ significand -= ((double) digit); \
+}
+
+/* allocates memory */
+#define inf std::numeric_limits<double>::infinity()
+
+bignum_type
+double_to_bignum(double x)
+{
+ if (x == inf || x == -inf || x != x) return (BIGNUM_ZERO ());
+ int exponent;
+ double significand = (frexp (x, (&exponent)));
+ if (exponent <= 0) return (BIGNUM_ZERO ());
+ if (exponent == 1) return (BIGNUM_ONE (x < 0));
+ if (significand < 0) significand = (-significand);
+ {
+ bignum_length_type length = (BIGNUM_BITS_TO_DIGITS (exponent));
+ bignum_type result = (allot_bignum (length, (x < 0)));
+ bignum_digit_type * start = (BIGNUM_START_PTR (result));
+ bignum_digit_type * scan = (start + length);
+ bignum_digit_type digit;
+ int odd_bits = (exponent % BIGNUM_DIGIT_LENGTH);
+ if (odd_bits > 0)
+ DTB_WRITE_DIGIT ((F_FIXNUM)1 << odd_bits);
+ while (start < scan)
+ {
+ if (significand == 0)
+ {
+ while (start < scan)
+ (*--scan) = 0;
+ break;
+ }
+ DTB_WRITE_DIGIT (BIGNUM_RADIX);
+ }
+ return (result);
+ }
+}
+
+#undef DTB_WRITE_DIGIT
+
+/* Comparisons */
+
+int
+bignum_equal_p_unsigned(bignum_type x, bignum_type y)
+{
+ bignum_length_type length = (BIGNUM_LENGTH (x));
+ if (length != (BIGNUM_LENGTH (y)))
+ return (0);
+ else
+ {
+ bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
+ bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
+ bignum_digit_type * end_x = (scan_x + length);
+ while (scan_x < end_x)
+ if ((*scan_x++) != (*scan_y++))
+ return (0);
+ return (1);
+ }
+}
+
+enum bignum_comparison
+bignum_compare_unsigned(bignum_type x, bignum_type y)
+{
+ bignum_length_type x_length = (BIGNUM_LENGTH (x));
+ bignum_length_type y_length = (BIGNUM_LENGTH (y));
+ if (x_length < y_length)
+ return (bignum_comparison_less);
+ if (x_length > y_length)
+ return (bignum_comparison_greater);
+ {
+ bignum_digit_type * start_x = (BIGNUM_START_PTR (x));
+ bignum_digit_type * scan_x = (start_x + x_length);
+ bignum_digit_type * scan_y = ((BIGNUM_START_PTR (y)) + y_length);
+ while (start_x < scan_x)
+ {
+ bignum_digit_type digit_x = (*--scan_x);
+ bignum_digit_type digit_y = (*--scan_y);
+ if (digit_x < digit_y)
+ return (bignum_comparison_less);
+ if (digit_x > digit_y)
+ return (bignum_comparison_greater);
+ }
+ }
+ return (bignum_comparison_equal);
+}
+
+/* Addition */
+
+/* allocates memory */
+bignum_type
+bignum_add_unsigned(bignum_type x, bignum_type y, int negative_p)
+{
+ if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x)))
+ {
+ bignum_type z = x;
+ x = y;
+ y = z;
+ }
+ {
+ bignum_length_type x_length = (BIGNUM_LENGTH (x));
+
+ REGISTER_BIGNUM(x);
+ REGISTER_BIGNUM(y);
+ bignum_type r = (allot_bignum ((x_length + 1), negative_p));
+ UNREGISTER_BIGNUM(y);
+ UNREGISTER_BIGNUM(x);
+
+ bignum_digit_type sum;
+ bignum_digit_type carry = 0;
+ bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
+ bignum_digit_type * scan_r = (BIGNUM_START_PTR (r));
+ {
+ bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
+ bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y)));
+ while (scan_y < end_y)
+ {
+ sum = ((*scan_x++) + (*scan_y++) + carry);
+ if (sum < BIGNUM_RADIX)
+ {
+ (*scan_r++) = sum;
+ carry = 0;
+ }
+ else
+ {
+ (*scan_r++) = (sum - BIGNUM_RADIX);
+ carry = 1;
+ }
+ }
+ }
+ {
+ bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length);
+ if (carry != 0)
+ while (scan_x < end_x)
+ {
+ sum = ((*scan_x++) + 1);
+ if (sum < BIGNUM_RADIX)
+ {
+ (*scan_r++) = sum;
+ carry = 0;
+ break;
+ }
+ else
+ (*scan_r++) = (sum - BIGNUM_RADIX);
+ }
+ while (scan_x < end_x)
+ (*scan_r++) = (*scan_x++);
+ }
+ if (carry != 0)
+ {
+ (*scan_r) = 1;
+ return (r);
+ }
+ return (bignum_shorten_length (r, x_length));
+ }
+}
+
+/* Subtraction */
+
+/* allocates memory */
+bignum_type
+bignum_subtract_unsigned(bignum_type x, bignum_type y)
+{
+ int negative_p = 0;
+ switch (bignum_compare_unsigned (x, y))
+ {
+ case bignum_comparison_equal:
+ return (BIGNUM_ZERO ());
+ case bignum_comparison_less:
+ {
+ bignum_type z = x;
+ x = y;
+ y = z;
+ }
+ negative_p = 1;
+ break;
+ case bignum_comparison_greater:
+ negative_p = 0;
+ break;
+ }
+ {
+ bignum_length_type x_length = (BIGNUM_LENGTH (x));
+
+ REGISTER_BIGNUM(x);
+ REGISTER_BIGNUM(y);
+ bignum_type r = (allot_bignum (x_length, negative_p));
+ UNREGISTER_BIGNUM(y);
+ UNREGISTER_BIGNUM(x);
+
+ bignum_digit_type difference;
+ bignum_digit_type borrow = 0;
+ bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
+ bignum_digit_type * scan_r = (BIGNUM_START_PTR (r));
+ {
+ bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
+ bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y)));
+ while (scan_y < end_y)
+ {
+ difference = (((*scan_x++) - (*scan_y++)) - borrow);
+ if (difference < 0)
+ {
+ (*scan_r++) = (difference + BIGNUM_RADIX);
+ borrow = 1;
+ }
+ else
+ {
+ (*scan_r++) = difference;
+ borrow = 0;
+ }
+ }
+ }
+ {
+ bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length);
+ if (borrow != 0)
+ while (scan_x < end_x)
+ {
+ difference = ((*scan_x++) - borrow);
+ if (difference < 0)
+ (*scan_r++) = (difference + BIGNUM_RADIX);
+ else
+ {
+ (*scan_r++) = difference;
+ borrow = 0;
+ break;
+ }
+ }
+ BIGNUM_ASSERT (borrow == 0);
+ while (scan_x < end_x)
+ (*scan_r++) = (*scan_x++);
+ }
+ return (bignum_trim (r));
+ }
+}
+
+/* Multiplication
+ Maximum value for product_low or product_high:
+ ((R * R) + (R * (R - 2)) + (R - 1))
+ Maximum value for carry: ((R * (R - 1)) + (R - 1))
+ where R == BIGNUM_RADIX_ROOT */
+
+/* allocates memory */
+bignum_type
+bignum_multiply_unsigned(bignum_type x, bignum_type y, int negative_p)
+{
+ if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x)))
+ {
+ bignum_type z = x;
+ x = y;
+ y = z;
+ }
+ {
+ bignum_digit_type carry;
+ bignum_digit_type y_digit_low;
+ bignum_digit_type y_digit_high;
+ bignum_digit_type x_digit_low;
+ bignum_digit_type x_digit_high;
+ bignum_digit_type product_low;
+ bignum_digit_type * scan_r;
+ bignum_digit_type * scan_y;
+ bignum_length_type x_length = (BIGNUM_LENGTH (x));
+ bignum_length_type y_length = (BIGNUM_LENGTH (y));
+
+ REGISTER_BIGNUM(x);
+ REGISTER_BIGNUM(y);
+ bignum_type r =
+ (allot_bignum_zeroed ((x_length + y_length), negative_p));
+ UNREGISTER_BIGNUM(y);
+ UNREGISTER_BIGNUM(x);
+
+ bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
+ bignum_digit_type * end_x = (scan_x + x_length);
+ bignum_digit_type * start_y = (BIGNUM_START_PTR (y));
+ bignum_digit_type * end_y = (start_y + y_length);
+ bignum_digit_type * start_r = (BIGNUM_START_PTR (r));
+#define x_digit x_digit_high
+#define y_digit y_digit_high
+#define product_high carry
+ while (scan_x < end_x)
+ {
+ x_digit = (*scan_x++);
+ x_digit_low = (HD_LOW (x_digit));
+ x_digit_high = (HD_HIGH (x_digit));
+ carry = 0;
+ scan_y = start_y;
+ scan_r = (start_r++);
+ while (scan_y < end_y)
+ {
+ y_digit = (*scan_y++);
+ y_digit_low = (HD_LOW (y_digit));
+ y_digit_high = (HD_HIGH (y_digit));
+ product_low =
+ ((*scan_r) +
+ (x_digit_low * y_digit_low) +
+ (HD_LOW (carry)));
+ product_high =
+ ((x_digit_high * y_digit_low) +
+ (x_digit_low * y_digit_high) +
+ (HD_HIGH (product_low)) +
+ (HD_HIGH (carry)));
+ (*scan_r++) =
+ (HD_CONS ((HD_LOW (product_high)), (HD_LOW (product_low))));
+ carry =
+ ((x_digit_high * y_digit_high) +
+ (HD_HIGH (product_high)));
+ }
+ (*scan_r) += carry;
+ }
+ return (bignum_trim (r));
+#undef x_digit
+#undef y_digit
+#undef product_high
+ }
+}
+
+/* allocates memory */
+bignum_type
+bignum_multiply_unsigned_small_factor(bignum_type x, bignum_digit_type y,
+ int negative_p)
+{
+ bignum_length_type length_x = (BIGNUM_LENGTH (x));
+
+ REGISTER_BIGNUM(x);
+ bignum_type p = (allot_bignum ((length_x + 1), negative_p));
+ UNREGISTER_BIGNUM(x);
+
+ bignum_destructive_copy (x, p);
+ (BIGNUM_REF (p, length_x)) = 0;
+ bignum_destructive_scale_up (p, y);
+ return (bignum_trim (p));
+}
+
+void
+bignum_destructive_add(bignum_type bignum, bignum_digit_type n)
+{
+ bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type digit;
+ digit = ((*scan) + n);
+ if (digit < BIGNUM_RADIX)
+ {
+ (*scan) = digit;
+ return;
+ }
+ (*scan++) = (digit - BIGNUM_RADIX);
+ while (1)
+ {
+ digit = ((*scan) + 1);
+ if (digit < BIGNUM_RADIX)
+ {
+ (*scan) = digit;
+ return;
+ }
+ (*scan++) = (digit - BIGNUM_RADIX);
+ }
+}
+
+void
+bignum_destructive_scale_up(bignum_type bignum, bignum_digit_type factor)
+{
+ bignum_digit_type carry = 0;
+ bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type two_digits;
+ bignum_digit_type product_low;
+#define product_high carry
+ bignum_digit_type * end = (scan + (BIGNUM_LENGTH (bignum)));
+ BIGNUM_ASSERT ((factor > 1) && (factor < BIGNUM_RADIX_ROOT));
+ while (scan < end)
+ {
+ two_digits = (*scan);
+ product_low = ((factor * (HD_LOW (two_digits))) + (HD_LOW (carry)));
+ product_high =
+ ((factor * (HD_HIGH (two_digits))) +
+ (HD_HIGH (product_low)) +
+ (HD_HIGH (carry)));
+ (*scan++) = (HD_CONS ((HD_LOW (product_high)), (HD_LOW (product_low))));
+ carry = (HD_HIGH (product_high));
+ }
+ /* A carry here would be an overflow, i.e. it would not fit.
+ Hopefully the callers allocate enough space that this will
+ never happen.
+ */
+ BIGNUM_ASSERT (carry == 0);
+ return;
+#undef product_high
+}
+
+/* Division */
+
+/* For help understanding this algorithm, see:
+ Knuth, Donald E., "The Art of Computer Programming",
+ volume 2, "Seminumerical Algorithms"
+ section 4.3.1, "Multiple-Precision Arithmetic". */
+
+/* allocates memory */
+void
+bignum_divide_unsigned_large_denominator(bignum_type numerator,
+ bignum_type denominator,
+ bignum_type * quotient,
+ bignum_type * remainder,
+ int q_negative_p,
+ int r_negative_p)
+{
+ bignum_length_type length_n = ((BIGNUM_LENGTH (numerator)) + 1);
+ bignum_length_type length_d = (BIGNUM_LENGTH (denominator));
+
+ REGISTER_BIGNUM(numerator);
+ REGISTER_BIGNUM(denominator);
+
+ bignum_type q =
+ ((quotient != ((bignum_type *) 0))
+ ? (allot_bignum ((length_n - length_d), q_negative_p))
+ : BIGNUM_OUT_OF_BAND);
+
+ REGISTER_BIGNUM(q);
+ bignum_type u = (allot_bignum (length_n, r_negative_p));
+ UNREGISTER_BIGNUM(q);
+
+ UNREGISTER_BIGNUM(denominator);
+ UNREGISTER_BIGNUM(numerator);
+
+ int shift = 0;
+ BIGNUM_ASSERT (length_d > 1);
+ {
+ bignum_digit_type v1 = (BIGNUM_REF ((denominator), (length_d - 1)));
+ while (v1 < (BIGNUM_RADIX / 2))
+ {
+ v1 <<= 1;
+ shift += 1;
+ }
+ }
+ if (shift == 0)
+ {
+ bignum_destructive_copy (numerator, u);
+ (BIGNUM_REF (u, (length_n - 1))) = 0;
+ bignum_divide_unsigned_normalized (u, denominator, q);
+ }
+ else
+ {
+ REGISTER_BIGNUM(numerator);
+ REGISTER_BIGNUM(denominator);
+ REGISTER_BIGNUM(u);
+ REGISTER_BIGNUM(q);
+ bignum_type v = (allot_bignum (length_d, 0));
+ UNREGISTER_BIGNUM(q);
+ UNREGISTER_BIGNUM(u);
+ UNREGISTER_BIGNUM(denominator);
+ UNREGISTER_BIGNUM(numerator);
+
+ bignum_destructive_normalization (numerator, u, shift);
+ bignum_destructive_normalization (denominator, v, shift);
+ bignum_divide_unsigned_normalized (u, v, q);
+ if (remainder != ((bignum_type *) 0))
+ bignum_destructive_unnormalization (u, shift);
+ }
+
+ REGISTER_BIGNUM(u);
+ if(q)
+ q = bignum_trim (q);
+ UNREGISTER_BIGNUM(u);
+
+ REGISTER_BIGNUM(q);
+ u = bignum_trim (u);
+ UNREGISTER_BIGNUM(q);
+
+ if (quotient != ((bignum_type *) 0))
+ (*quotient) = q;
+
+ if (remainder != ((bignum_type *) 0))
+ (*remainder) = u;
+
+ return;
+}
+
+void
+bignum_divide_unsigned_normalized(bignum_type u, bignum_type v, bignum_type q)
+{
+ bignum_length_type u_length = (BIGNUM_LENGTH (u));
+ bignum_length_type v_length = (BIGNUM_LENGTH (v));
+ bignum_digit_type * u_start = (BIGNUM_START_PTR (u));
+ bignum_digit_type * u_scan = (u_start + u_length);
+ bignum_digit_type * u_scan_limit = (u_start + v_length);
+ bignum_digit_type * u_scan_start = (u_scan - v_length);
+ bignum_digit_type * v_start = (BIGNUM_START_PTR (v));
+ bignum_digit_type * v_end = (v_start + v_length);
+ bignum_digit_type * q_scan = NULL;
+ bignum_digit_type v1 = (v_end[-1]);
+ bignum_digit_type v2 = (v_end[-2]);
+ bignum_digit_type ph; /* high half of double-digit product */
+ bignum_digit_type pl; /* low half of double-digit product */
+ bignum_digit_type guess;
+ bignum_digit_type gh; /* high half-digit of guess */
+ bignum_digit_type ch; /* high half of double-digit comparand */
+ bignum_digit_type v2l = (HD_LOW (v2));
+ bignum_digit_type v2h = (HD_HIGH (v2));
+ bignum_digit_type cl; /* low half of double-digit comparand */
+#define gl ph /* low half-digit of guess */
+#define uj pl
+#define qj ph
+ bignum_digit_type gm; /* memory loc for reference parameter */
+ if (q != BIGNUM_OUT_OF_BAND)
+ q_scan = ((BIGNUM_START_PTR (q)) + (BIGNUM_LENGTH (q)));
+ while (u_scan_limit < u_scan)
+ {
+ uj = (*--u_scan);
+ if (uj != v1)
+ {
+ /* comparand =
+ (((((uj * BIGNUM_RADIX) + uj1) % v1) * BIGNUM_RADIX) + uj2);
+ guess = (((uj * BIGNUM_RADIX) + uj1) / v1); */
+ cl = (u_scan[-2]);
+ ch = (bignum_digit_divide (uj, (u_scan[-1]), v1, (&gm)));
+ guess = gm;
+ }
+ else
+ {
+ cl = (u_scan[-2]);
+ ch = ((u_scan[-1]) + v1);
+ guess = (BIGNUM_RADIX - 1);
+ }
+ while (1)
+ {
+ /* product = (guess * v2); */
+ gl = (HD_LOW (guess));
+ gh = (HD_HIGH (guess));
+ pl = (v2l * gl);
+ ph = ((v2l * gh) + (v2h * gl) + (HD_HIGH (pl)));
+ pl = (HD_CONS ((HD_LOW (ph)), (HD_LOW (pl))));
+ ph = ((v2h * gh) + (HD_HIGH (ph)));
+ /* if (comparand >= product) */
+ if ((ch > ph) || ((ch == ph) && (cl >= pl)))
+ break;
+ guess -= 1;
+ /* comparand += (v1 << BIGNUM_DIGIT_LENGTH) */
+ ch += v1;
+ /* if (comparand >= (BIGNUM_RADIX * BIGNUM_RADIX)) */
+ if (ch >= BIGNUM_RADIX)
+ break;
+ }
+ qj = (bignum_divide_subtract (v_start, v_end, guess, (--u_scan_start)));
+ if (q != BIGNUM_OUT_OF_BAND)
+ (*--q_scan) = qj;
+ }
+ return;
+#undef gl
+#undef uj
+#undef qj
+}
+
+bignum_digit_type
+bignum_divide_subtract(bignum_digit_type * v_start,
+ bignum_digit_type * v_end,
+ bignum_digit_type guess,
+ bignum_digit_type * u_start)
+{
+ bignum_digit_type * v_scan = v_start;
+ bignum_digit_type * u_scan = u_start;
+ bignum_digit_type carry = 0;
+ if (guess == 0) return (0);
+ {
+ bignum_digit_type gl = (HD_LOW (guess));
+ bignum_digit_type gh = (HD_HIGH (guess));
+ bignum_digit_type v;
+ bignum_digit_type pl;
+ bignum_digit_type vl;
+#define vh v
+#define ph carry
+#define diff pl
+ while (v_scan < v_end)
+ {
+ v = (*v_scan++);
+ vl = (HD_LOW (v));
+ vh = (HD_HIGH (v));
+ pl = ((vl * gl) + (HD_LOW (carry)));
+ ph = ((vl * gh) + (vh * gl) + (HD_HIGH (pl)) + (HD_HIGH (carry)));
+ diff = ((*u_scan) - (HD_CONS ((HD_LOW (ph)), (HD_LOW (pl)))));
+ if (diff < 0)
+ {
+ (*u_scan++) = (diff + BIGNUM_RADIX);
+ carry = ((vh * gh) + (HD_HIGH (ph)) + 1);
+ }
+ else
+ {
+ (*u_scan++) = diff;
+ carry = ((vh * gh) + (HD_HIGH (ph)));
+ }
+ }
+ if (carry == 0)
+ return (guess);
+ diff = ((*u_scan) - carry);
+ if (diff < 0)
+ (*u_scan) = (diff + BIGNUM_RADIX);
+ else
+ {
+ (*u_scan) = diff;
+ return (guess);
+ }
+#undef vh
+#undef ph
+#undef diff
+ }
+ /* Subtraction generated carry, implying guess is one too large.
+ Add v back in to bring it back down. */
+ v_scan = v_start;
+ u_scan = u_start;
+ carry = 0;
+ while (v_scan < v_end)
+ {
+ bignum_digit_type sum = ((*v_scan++) + (*u_scan) + carry);
+ if (sum < BIGNUM_RADIX)
+ {
+ (*u_scan++) = sum;
+ carry = 0;
+ }
+ else
+ {
+ (*u_scan++) = (sum - BIGNUM_RADIX);
+ carry = 1;
+ }
+ }
+ if (carry == 1)
+ {
+ bignum_digit_type sum = ((*u_scan) + carry);
+ (*u_scan) = ((sum < BIGNUM_RADIX) ? sum : (sum - BIGNUM_RADIX));
+ }
+ return (guess - 1);
+}
+
+/* allocates memory */
+void
+bignum_divide_unsigned_medium_denominator(bignum_type numerator,
+ bignum_digit_type denominator,
+ bignum_type * quotient,
+ bignum_type * remainder,
+ int q_negative_p,
+ int r_negative_p)
+{
+ bignum_length_type length_n = (BIGNUM_LENGTH (numerator));
+ bignum_length_type length_q;
+ bignum_type q;
+ int shift = 0;
+ /* Because `bignum_digit_divide' requires a normalized denominator. */
+ while (denominator < (BIGNUM_RADIX / 2))
+ {
+ denominator <<= 1;
+ shift += 1;
+ }
+ if (shift == 0)
+ {
+ length_q = length_n;
+
+ REGISTER_BIGNUM(numerator);
+ q = (allot_bignum (length_q, q_negative_p));
+ UNREGISTER_BIGNUM(numerator);
+
+ bignum_destructive_copy (numerator, q);
+ }
+ else
+ {
+ length_q = (length_n + 1);
+
+ REGISTER_BIGNUM(numerator);
+ q = (allot_bignum (length_q, q_negative_p));
+ UNREGISTER_BIGNUM(numerator);
+
+ bignum_destructive_normalization (numerator, q, shift);
+ }
+ {
+ bignum_digit_type r = 0;
+ bignum_digit_type * start = (BIGNUM_START_PTR (q));
+ bignum_digit_type * scan = (start + length_q);
+ bignum_digit_type qj;
+
+ while (start < scan)
+ {
+ r = (bignum_digit_divide (r, (*--scan), denominator, (&qj)));
+ (*scan) = qj;
+ }
+
+ q = bignum_trim (q);
+
+ if (remainder != ((bignum_type *) 0))
+ {
+ if (shift != 0)
+ r >>= shift;
+
+ REGISTER_BIGNUM(q);
+ (*remainder) = (bignum_digit_to_bignum (r, r_negative_p));
+ UNREGISTER_BIGNUM(q);
+ }
+
+ if (quotient != ((bignum_type *) 0))
+ (*quotient) = q;
+ }
+ return;
+}
+
+void
+bignum_destructive_normalization(bignum_type source, bignum_type target,
+ int shift_left)
+{
+ bignum_digit_type digit;
+ bignum_digit_type * scan_source = (BIGNUM_START_PTR (source));
+ bignum_digit_type carry = 0;
+ bignum_digit_type * scan_target = (BIGNUM_START_PTR (target));
+ bignum_digit_type * end_source = (scan_source + (BIGNUM_LENGTH (source)));
+ bignum_digit_type * end_target = (scan_target + (BIGNUM_LENGTH (target)));
+ int shift_right = (BIGNUM_DIGIT_LENGTH - shift_left);
+ bignum_digit_type mask = (((CELL)1 << shift_right) - 1);
+ while (scan_source < end_source)
+ {
+ digit = (*scan_source++);
+ (*scan_target++) = (((digit & mask) << shift_left) | carry);
+ carry = (digit >> shift_right);
+ }
+ if (scan_target < end_target)
+ (*scan_target) = carry;
+ else
+ BIGNUM_ASSERT (carry == 0);
+ return;
+}
+
+void
+bignum_destructive_unnormalization(bignum_type bignum, int shift_right)
+{
+ bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
+ bignum_digit_type digit;
+ bignum_digit_type carry = 0;
+ int shift_left = (BIGNUM_DIGIT_LENGTH - shift_right);
+ bignum_digit_type mask = (((F_FIXNUM)1 << shift_right) - 1);
+ while (start < scan)
+ {
+ digit = (*--scan);
+ (*scan) = ((digit >> shift_right) | carry);
+ carry = ((digit & mask) << shift_left);
+ }
+ BIGNUM_ASSERT (carry == 0);
+ return;
+}
+
+/* This is a reduced version of the division algorithm, applied to the
+ case of dividing two bignum digits by one bignum digit. It is
+ assumed that the numerator, denominator are normalized. */
+
+#define BDD_STEP(qn, j) \
+{ \
+ uj = (u[j]); \
+ if (uj != v1) \
+ { \
+ uj_uj1 = (HD_CONS (uj, (u[j + 1]))); \
+ guess = (uj_uj1 / v1); \
+ comparand = (HD_CONS ((uj_uj1 % v1), (u[j + 2]))); \
+ } \
+ else \
+ { \
+ guess = (BIGNUM_RADIX_ROOT - 1); \
+ comparand = (HD_CONS (((u[j + 1]) + v1), (u[j + 2]))); \
+ } \
+ while ((guess * v2) > comparand) \
+ { \
+ guess -= 1; \
+ comparand += (v1 << BIGNUM_HALF_DIGIT_LENGTH); \
+ if (comparand >= BIGNUM_RADIX) \
+ break; \
+ } \
+ qn = (bignum_digit_divide_subtract (v1, v2, guess, (&u[j]))); \
+}
+
+bignum_digit_type
+bignum_digit_divide(bignum_digit_type uh, bignum_digit_type ul,
+ bignum_digit_type v,
+ bignum_digit_type * q) /* return value */
+{
+ bignum_digit_type guess;
+ bignum_digit_type comparand;
+ bignum_digit_type v1 = (HD_HIGH (v));
+ bignum_digit_type v2 = (HD_LOW (v));
+ bignum_digit_type uj;
+ bignum_digit_type uj_uj1;
+ bignum_digit_type q1;
+ bignum_digit_type q2;
+ bignum_digit_type u [4];
+ if (uh == 0)
+ {
+ if (ul < v)
+ {
+ (*q) = 0;
+ return (ul);
+ }
+ else if (ul == v)
+ {
+ (*q) = 1;
+ return (0);
+ }
+ }
+ (u[0]) = (HD_HIGH (uh));
+ (u[1]) = (HD_LOW (uh));
+ (u[2]) = (HD_HIGH (ul));
+ (u[3]) = (HD_LOW (ul));
+ v1 = (HD_HIGH (v));
+ v2 = (HD_LOW (v));
+ BDD_STEP (q1, 0);
+ BDD_STEP (q2, 1);
+ (*q) = (HD_CONS (q1, q2));
+ return (HD_CONS ((u[2]), (u[3])));
+}
+
+#undef BDD_STEP
+
+#define BDDS_MULSUB(vn, un, carry_in) \
+{ \
+ product = ((vn * guess) + carry_in); \
+ diff = (un - (HD_LOW (product))); \
+ if (diff < 0) \
+ { \
+ un = (diff + BIGNUM_RADIX_ROOT); \
+ carry = ((HD_HIGH (product)) + 1); \
+ } \
+ else \
+ { \
+ un = diff; \
+ carry = (HD_HIGH (product)); \
+ } \
+}
+
+#define BDDS_ADD(vn, un, carry_in) \
+{ \
+ sum = (vn + un + carry_in); \
+ if (sum < BIGNUM_RADIX_ROOT) \
+ { \
+ un = sum; \
+ carry = 0; \
+ } \
+ else \
+ { \
+ un = (sum - BIGNUM_RADIX_ROOT); \
+ carry = 1; \
+ } \
+}
+
+bignum_digit_type
+bignum_digit_divide_subtract(bignum_digit_type v1, bignum_digit_type v2,
+ bignum_digit_type guess, bignum_digit_type * u)
+{
+ {
+ bignum_digit_type product;
+ bignum_digit_type diff;
+ bignum_digit_type carry;
+ BDDS_MULSUB (v2, (u[2]), 0);
+ BDDS_MULSUB (v1, (u[1]), carry);
+ if (carry == 0)
+ return (guess);
+ diff = ((u[0]) - carry);
+ if (diff < 0)
+ (u[0]) = (diff + BIGNUM_RADIX);
+ else
+ {
+ (u[0]) = diff;
+ return (guess);
+ }
+ }
+ {
+ bignum_digit_type sum;
+ bignum_digit_type carry;
+ BDDS_ADD(v2, (u[2]), 0);
+ BDDS_ADD(v1, (u[1]), carry);
+ if (carry == 1)
+ (u[0]) += 1;
+ }
+ return (guess - 1);
+}
+
+#undef BDDS_MULSUB
+#undef BDDS_ADD
+
+/* allocates memory */
+void
+bignum_divide_unsigned_small_denominator(bignum_type numerator,
+ bignum_digit_type denominator,
+ bignum_type * quotient,
+ bignum_type * remainder,
+ int q_negative_p,
+ int r_negative_p)
+{
+ REGISTER_BIGNUM(numerator);
+ bignum_type q = (bignum_new_sign (numerator, q_negative_p));
+ UNREGISTER_BIGNUM(numerator);
+
+ bignum_digit_type r = (bignum_destructive_scale_down (q, denominator));
+
+ q = (bignum_trim (q));
+
+ if (remainder != ((bignum_type *) 0))
+ {
+ REGISTER_BIGNUM(q);
+ (*remainder) = (bignum_digit_to_bignum (r, r_negative_p));
+ UNREGISTER_BIGNUM(q);
+ }
+
+ (*quotient) = q;
+
+ return;
+}
+
+/* Given (denominator > 1), it is fairly easy to show that
+ (quotient_high < BIGNUM_RADIX_ROOT), after which it is easy to see
+ that all digits are < BIGNUM_RADIX. */
+
+bignum_digit_type
+bignum_destructive_scale_down(bignum_type bignum, bignum_digit_type denominator)
+{
+ bignum_digit_type numerator;
+ bignum_digit_type remainder = 0;
+ bignum_digit_type two_digits;
+#define quotient_high remainder
+ bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
+ BIGNUM_ASSERT ((denominator > 1) && (denominator < BIGNUM_RADIX_ROOT));
+ while (start < scan)
+ {
+ two_digits = (*--scan);
+ numerator = (HD_CONS (remainder, (HD_HIGH (two_digits))));
+ quotient_high = (numerator / denominator);
+ numerator = (HD_CONS ((numerator % denominator), (HD_LOW (two_digits))));
+ (*scan) = (HD_CONS (quotient_high, (numerator / denominator)));
+ remainder = (numerator % denominator);
+ }
+ return (remainder);
+#undef quotient_high
+}
+
+/* allocates memory */
+bignum_type
+bignum_remainder_unsigned_small_denominator(
+ bignum_type n, bignum_digit_type d, int negative_p)
+{
+ bignum_digit_type two_digits;
+ bignum_digit_type * start = (BIGNUM_START_PTR (n));
+ bignum_digit_type * scan = (start + (BIGNUM_LENGTH (n)));
+ bignum_digit_type r = 0;
+ BIGNUM_ASSERT ((d > 1) && (d < BIGNUM_RADIX_ROOT));
+ while (start < scan)
+ {
+ two_digits = (*--scan);
+ r =
+ ((HD_CONS (((HD_CONS (r, (HD_HIGH (two_digits)))) % d),
+ (HD_LOW (two_digits))))
+ % d);
+ }
+ return (bignum_digit_to_bignum (r, negative_p));
+}
+
+/* allocates memory */
+bignum_type
+bignum_digit_to_bignum(bignum_digit_type digit, int negative_p)
+{
+ if (digit == 0)
+ return (BIGNUM_ZERO ());
+ else
+ {
+ bignum_type result = (allot_bignum (1, negative_p));
+ (BIGNUM_REF (result, 0)) = digit;
+ return (result);
+ }
+}
+
+/* allocates memory */
+bignum_type
+allot_bignum(bignum_length_type length, int negative_p)
+{
+ BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX));
+ bignum_type result = allot_array_internal(BIGNUM_TYPE,length + 1);
+ BIGNUM_SET_NEGATIVE_P (result, negative_p);
+ return (result);
+}
+
+/* allocates memory */
+bignum_type
+allot_bignum_zeroed(bignum_length_type length, int negative_p)
+{
+ bignum_type result = allot_bignum(length,negative_p);
+ bignum_digit_type * scan = (BIGNUM_START_PTR (result));
+ bignum_digit_type * end = (scan + length);
+ while (scan < end)
+ (*scan++) = 0;
+ return (result);
+}
+
+#define BIGNUM_REDUCE_LENGTH(source, length) \
+ source = reallot_array(source,length + 1)
+
+/* allocates memory */
+bignum_type
+bignum_shorten_length(bignum_type bignum, bignum_length_type length)
+{
+ bignum_length_type current_length = (BIGNUM_LENGTH (bignum));
+ BIGNUM_ASSERT ((length >= 0) || (length <= current_length));
+ if (length < current_length)
+ {
+ BIGNUM_REDUCE_LENGTH (bignum, length);
+ BIGNUM_SET_NEGATIVE_P (bignum, (length != 0) && (BIGNUM_NEGATIVE_P (bignum)));
+ }
+ return (bignum);
+}
+
+/* allocates memory */
+bignum_type
+bignum_trim(bignum_type bignum)
+{
+ bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type * end = (start + (BIGNUM_LENGTH (bignum)));
+ bignum_digit_type * scan = end;
+ while ((start <= scan) && ((*--scan) == 0))
+ ;
+ scan += 1;
+ if (scan < end)
+ {
+ bignum_length_type length = (scan - start);
+ BIGNUM_REDUCE_LENGTH (bignum, length);
+ BIGNUM_SET_NEGATIVE_P (bignum, (length != 0) && (BIGNUM_NEGATIVE_P (bignum)));
+ }
+ return (bignum);
+}
+
+/* Copying */
+
+/* allocates memory */
+bignum_type
+bignum_new_sign(bignum_type bignum, int negative_p)
+{
+ REGISTER_BIGNUM(bignum);
+ bignum_type result =
+ (allot_bignum ((BIGNUM_LENGTH (bignum)), negative_p));
+ UNREGISTER_BIGNUM(bignum);
+
+ bignum_destructive_copy (bignum, result);
+ return (result);
+}
+
+/* allocates memory */
+bignum_type
+bignum_maybe_new_sign(bignum_type bignum, int negative_p)
+{
+ if ((BIGNUM_NEGATIVE_P (bignum)) ? negative_p : (! negative_p))
+ return (bignum);
+ else
+ {
+ bignum_type result =
+ (allot_bignum ((BIGNUM_LENGTH (bignum)), negative_p));
+ bignum_destructive_copy (bignum, result);
+ return (result);
+ }
+}
+
+void
+bignum_destructive_copy(bignum_type source, bignum_type target)
+{
+ bignum_digit_type * scan_source = (BIGNUM_START_PTR (source));
+ bignum_digit_type * end_source =
+ (scan_source + (BIGNUM_LENGTH (source)));
+ bignum_digit_type * scan_target = (BIGNUM_START_PTR (target));
+ while (scan_source < end_source)
+ (*scan_target++) = (*scan_source++);
+ return;
+}
+
+/*
+ * Added bitwise operations (and oddp).
+ */
+
+/* allocates memory */
+bignum_type
+bignum_bitwise_not(bignum_type x)
+{
+ return bignum_subtract(BIGNUM_ONE(1), x);
+}
+
+/* allocates memory */
+bignum_type
+bignum_arithmetic_shift(bignum_type arg1, F_FIXNUM n)
+{
+ if (BIGNUM_NEGATIVE_P(arg1) && n < 0)
+ return bignum_bitwise_not(bignum_magnitude_ash(bignum_bitwise_not(arg1), n));
+ else
+ return bignum_magnitude_ash(arg1, n);
+}
+
+#define AND_OP 0
+#define IOR_OP 1
+#define XOR_OP 2
+
+/* allocates memory */
+bignum_type
+bignum_bitwise_and(bignum_type arg1, bignum_type arg2)
+{
+ return(
+ (BIGNUM_NEGATIVE_P (arg1))
+ ? (BIGNUM_NEGATIVE_P (arg2))
+ ? bignum_negneg_bitwise_op(AND_OP, arg1, arg2)
+ : bignum_posneg_bitwise_op(AND_OP, arg2, arg1)
+ : (BIGNUM_NEGATIVE_P (arg2))
+ ? bignum_posneg_bitwise_op(AND_OP, arg1, arg2)
+ : bignum_pospos_bitwise_op(AND_OP, arg1, arg2)
+ );
+}
+
+/* allocates memory */
+bignum_type
+bignum_bitwise_ior(bignum_type arg1, bignum_type arg2)
+{
+ return(
+ (BIGNUM_NEGATIVE_P (arg1))
+ ? (BIGNUM_NEGATIVE_P (arg2))
+ ? bignum_negneg_bitwise_op(IOR_OP, arg1, arg2)
+ : bignum_posneg_bitwise_op(IOR_OP, arg2, arg1)
+ : (BIGNUM_NEGATIVE_P (arg2))
+ ? bignum_posneg_bitwise_op(IOR_OP, arg1, arg2)
+ : bignum_pospos_bitwise_op(IOR_OP, arg1, arg2)
+ );
+}
+
+/* allocates memory */
+bignum_type
+bignum_bitwise_xor(bignum_type arg1, bignum_type arg2)
+{
+ return(
+ (BIGNUM_NEGATIVE_P (arg1))
+ ? (BIGNUM_NEGATIVE_P (arg2))
+ ? bignum_negneg_bitwise_op(XOR_OP, arg1, arg2)
+ : bignum_posneg_bitwise_op(XOR_OP, arg2, arg1)
+ : (BIGNUM_NEGATIVE_P (arg2))
+ ? bignum_posneg_bitwise_op(XOR_OP, arg1, arg2)
+ : bignum_pospos_bitwise_op(XOR_OP, arg1, arg2)
+ );
+}
+
+/* allocates memory */
+/* ash for the magnitude */
+/* assume arg1 is a big number, n is a long */
+bignum_type
+bignum_magnitude_ash(bignum_type arg1, F_FIXNUM n)
+{
+ bignum_type result = NULL;
+ bignum_digit_type *scan1;
+ bignum_digit_type *scanr;
+ bignum_digit_type *end;
+
+ F_FIXNUM digit_offset,bit_offset;
+
+ if (BIGNUM_ZERO_P (arg1)) return (arg1);
+
+ if (n > 0) {
+ digit_offset = n / BIGNUM_DIGIT_LENGTH;
+ bit_offset = n % BIGNUM_DIGIT_LENGTH;
+
+ REGISTER_BIGNUM(arg1);
+ result = allot_bignum_zeroed (BIGNUM_LENGTH (arg1) + digit_offset + 1,
+ BIGNUM_NEGATIVE_P(arg1));
+ UNREGISTER_BIGNUM(arg1);
+
+ scanr = BIGNUM_START_PTR (result) + digit_offset;
+ scan1 = BIGNUM_START_PTR (arg1);
+ end = scan1 + BIGNUM_LENGTH (arg1);
+
+ while (scan1 < end) {
+ *scanr = *scanr | (*scan1 & BIGNUM_DIGIT_MASK) << bit_offset;
+ *scanr = *scanr & BIGNUM_DIGIT_MASK;
+ scanr++;
+ *scanr = *scan1++ >> (BIGNUM_DIGIT_LENGTH - bit_offset);
+ *scanr = *scanr & BIGNUM_DIGIT_MASK;
+ }
+ }
+ else if (n < 0
+ && (-n >= (BIGNUM_LENGTH (arg1) * (bignum_length_type) BIGNUM_DIGIT_LENGTH)))
+ result = BIGNUM_ZERO ();
+
+ else if (n < 0) {
+ digit_offset = -n / BIGNUM_DIGIT_LENGTH;
+ bit_offset = -n % BIGNUM_DIGIT_LENGTH;
+
+ REGISTER_BIGNUM(arg1);
+ result = allot_bignum_zeroed (BIGNUM_LENGTH (arg1) - digit_offset,
+ BIGNUM_NEGATIVE_P(arg1));
+ UNREGISTER_BIGNUM(arg1);
+
+ scanr = BIGNUM_START_PTR (result);
+ scan1 = BIGNUM_START_PTR (arg1) + digit_offset;
+ end = scanr + BIGNUM_LENGTH (result) - 1;
+
+ while (scanr < end) {
+ *scanr = (*scan1++ & BIGNUM_DIGIT_MASK) >> bit_offset ;
+ *scanr = (*scanr |
+ *scan1 << (BIGNUM_DIGIT_LENGTH - bit_offset)) & BIGNUM_DIGIT_MASK;
+ scanr++;
+ }
+ *scanr = (*scan1++ & BIGNUM_DIGIT_MASK) >> bit_offset ;
+ }
+ else if (n == 0) result = arg1;
+
+ return (bignum_trim (result));
+}
+
+/* allocates memory */
+bignum_type
+bignum_pospos_bitwise_op(int op, bignum_type arg1, bignum_type arg2)
+{
+ bignum_type result;
+ bignum_length_type max_length;
+
+ bignum_digit_type *scan1, *end1, digit1;
+ bignum_digit_type *scan2, *end2, digit2;
+ bignum_digit_type *scanr, *endr;
+
+ max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2))
+ ? BIGNUM_LENGTH(arg1) : BIGNUM_LENGTH(arg2);
+
+ REGISTER_BIGNUM(arg1);
+ REGISTER_BIGNUM(arg2);
+ result = allot_bignum(max_length, 0);
+ UNREGISTER_BIGNUM(arg2);
+ UNREGISTER_BIGNUM(arg1);
+
+ scanr = BIGNUM_START_PTR(result);
+ scan1 = BIGNUM_START_PTR(arg1);
+ scan2 = BIGNUM_START_PTR(arg2);
+ endr = scanr + max_length;
+ end1 = scan1 + BIGNUM_LENGTH(arg1);
+ end2 = scan2 + BIGNUM_LENGTH(arg2);
+
+ while (scanr < endr) {
+ digit1 = (scan1 < end1) ? *scan1++ : 0;
+ digit2 = (scan2 < end2) ? *scan2++ : 0;
+ *scanr++ = (op == AND_OP) ? digit1 & digit2 :
+ (op == IOR_OP) ? digit1 | digit2 :
+ digit1 ^ digit2;
+ }
+ return bignum_trim(result);
+}
+
+/* allocates memory */
+bignum_type
+bignum_posneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2)
+{
+ bignum_type result;
+ bignum_length_type max_length;
+
+ bignum_digit_type *scan1, *end1, digit1;
+ bignum_digit_type *scan2, *end2, digit2, carry2;
+ bignum_digit_type *scanr, *endr;
+
+ char neg_p = op == IOR_OP || op == XOR_OP;
+
+ max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2) + 1)
+ ? BIGNUM_LENGTH(arg1) : BIGNUM_LENGTH(arg2) + 1;
+
+ REGISTER_BIGNUM(arg1);
+ REGISTER_BIGNUM(arg2);
+ result = allot_bignum(max_length, neg_p);
+ UNREGISTER_BIGNUM(arg2);
+ UNREGISTER_BIGNUM(arg1);
+
+ scanr = BIGNUM_START_PTR(result);
+ scan1 = BIGNUM_START_PTR(arg1);
+ scan2 = BIGNUM_START_PTR(arg2);
+ endr = scanr + max_length;
+ end1 = scan1 + BIGNUM_LENGTH(arg1);
+ end2 = scan2 + BIGNUM_LENGTH(arg2);
+
+ carry2 = 1;
+
+ while (scanr < endr) {
+ digit1 = (scan1 < end1) ? *scan1++ : 0;
+ digit2 = (~((scan2 < end2) ? *scan2++ : 0) & BIGNUM_DIGIT_MASK)
+ + carry2;
+
+ if (digit2 < BIGNUM_RADIX)
+ carry2 = 0;
+ else
+ {
+ digit2 = (digit2 - BIGNUM_RADIX);
+ carry2 = 1;
+ }
+
+ *scanr++ = (op == AND_OP) ? digit1 & digit2 :
+ (op == IOR_OP) ? digit1 | digit2 :
+ digit1 ^ digit2;
+ }
+
+ if (neg_p)
+ bignum_negate_magnitude(result);
+
+ return bignum_trim(result);
+}
+
+/* allocates memory */
+bignum_type
+bignum_negneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2)
+{
+ bignum_type result;
+ bignum_length_type max_length;
+
+ bignum_digit_type *scan1, *end1, digit1, carry1;
+ bignum_digit_type *scan2, *end2, digit2, carry2;
+ bignum_digit_type *scanr, *endr;
+
+ char neg_p = op == AND_OP || op == IOR_OP;
+
+ max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2))
+ ? BIGNUM_LENGTH(arg1) + 1 : BIGNUM_LENGTH(arg2) + 1;
+
+ REGISTER_BIGNUM(arg1);
+ REGISTER_BIGNUM(arg2);
+ result = allot_bignum(max_length, neg_p);
+ UNREGISTER_BIGNUM(arg2);
+ UNREGISTER_BIGNUM(arg1);
+
+ scanr = BIGNUM_START_PTR(result);
+ scan1 = BIGNUM_START_PTR(arg1);
+ scan2 = BIGNUM_START_PTR(arg2);
+ endr = scanr + max_length;
+ end1 = scan1 + BIGNUM_LENGTH(arg1);
+ end2 = scan2 + BIGNUM_LENGTH(arg2);
+
+ carry1 = 1;
+ carry2 = 1;
+
+ while (scanr < endr) {
+ digit1 = (~((scan1 < end1) ? *scan1++ : 0) & BIGNUM_DIGIT_MASK) + carry1;
+ digit2 = (~((scan2 < end2) ? *scan2++ : 0) & BIGNUM_DIGIT_MASK) + carry2;
+
+ if (digit1 < BIGNUM_RADIX)
+ carry1 = 0;
+ else
+ {
+ digit1 = (digit1 - BIGNUM_RADIX);
+ carry1 = 1;
+ }
+
+ if (digit2 < BIGNUM_RADIX)
+ carry2 = 0;
+ else
+ {
+ digit2 = (digit2 - BIGNUM_RADIX);
+ carry2 = 1;
+ }
+
+ *scanr++ = (op == AND_OP) ? digit1 & digit2 :
+ (op == IOR_OP) ? digit1 | digit2 :
+ digit1 ^ digit2;
+ }
+
+ if (neg_p)
+ bignum_negate_magnitude(result);
+
+ return bignum_trim(result);
+}
+
+void
+bignum_negate_magnitude(bignum_type arg)
+{
+ bignum_digit_type *scan;
+ bignum_digit_type *end;
+ bignum_digit_type digit;
+ bignum_digit_type carry;
+
+ scan = BIGNUM_START_PTR(arg);
+ end = scan + BIGNUM_LENGTH(arg);
+
+ carry = 1;
+
+ while (scan < end) {
+ digit = (~*scan & BIGNUM_DIGIT_MASK) + carry;
+
+ if (digit < BIGNUM_RADIX)
+ carry = 0;
+ else
+ {
+ digit = (digit - BIGNUM_RADIX);
+ carry = 1;
+ }
+
+ *scan++ = digit;
+ }
+}
+
+/* Allocates memory */
+bignum_type
+bignum_integer_length(bignum_type bignum)
+{
+ bignum_length_type index = ((BIGNUM_LENGTH (bignum)) - 1);
+ bignum_digit_type digit = (BIGNUM_REF (bignum, index));
+
+ REGISTER_BIGNUM(bignum);
+ bignum_type result = (allot_bignum (2, 0));
+ UNREGISTER_BIGNUM(bignum);
+
+ (BIGNUM_REF (result, 0)) = index;
+ (BIGNUM_REF (result, 1)) = 0;
+ bignum_destructive_scale_up (result, BIGNUM_DIGIT_LENGTH);
+ while (digit > 1)
+ {
+ bignum_destructive_add (result, ((bignum_digit_type) 1));
+ digit >>= 1;
+ }
+ return (bignum_trim (result));
+}
+
+/* Allocates memory */
+int
+bignum_logbitp(int shift, bignum_type arg)
+{
+ return((BIGNUM_NEGATIVE_P (arg))
+ ? !bignum_unsigned_logbitp (shift, bignum_bitwise_not (arg))
+ : bignum_unsigned_logbitp (shift,arg));
+}
+
+int
+bignum_unsigned_logbitp(int shift, bignum_type bignum)
+{
+ bignum_length_type len = (BIGNUM_LENGTH (bignum));
+ int index = shift / BIGNUM_DIGIT_LENGTH;
+ if (index >= len)
+ return 0;
+ bignum_digit_type digit = (BIGNUM_REF (bignum, index));
+ int p = shift % BIGNUM_DIGIT_LENGTH;
+ bignum_digit_type mask = ((F_FIXNUM)1) << p;
+ return (digit & mask) ? 1 : 0;
+}
+
+/* Allocates memory */
+bignum_type
+digit_stream_to_bignum(unsigned int n_digits,
+ unsigned int (*producer)(unsigned int),
+ unsigned int radix,
+ int negative_p)
+{
+ BIGNUM_ASSERT ((radix > 1) && (radix <= BIGNUM_RADIX_ROOT));
+ if (n_digits == 0)
+ return (BIGNUM_ZERO ());
+ if (n_digits == 1)
+ {
+ F_FIXNUM digit = ((F_FIXNUM) ((*producer) (0)));
+ return (fixnum_to_bignum (negative_p ? (- digit) : digit));
+ }
+ {
+ bignum_length_type length;
+ {
+ unsigned int radix_copy = radix;
+ unsigned int log_radix = 0;
+ while (radix_copy > 0)
+ {
+ radix_copy >>= 1;
+ log_radix += 1;
+ }
+ /* This length will be at least as large as needed. */
+ length = (BIGNUM_BITS_TO_DIGITS (n_digits * log_radix));
+ }
+ {
+ bignum_type result = (allot_bignum_zeroed (length, negative_p));
+ while ((n_digits--) > 0)
+ {
+ bignum_destructive_scale_up (result, ((bignum_digit_type) radix));
+ bignum_destructive_add
+ (result, ((bignum_digit_type) ((*producer) (n_digits))));
+ }
+ return (bignum_trim (result));
+ }
+ }
+}
--- /dev/null
+/* :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);
--- /dev/null
+/* -*-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 (bignum_digit_type)(((CELL) 1) << BIGNUM_DIGIT_LENGTH)
+#define BIGNUM_RADIX_ROOT (((bignum_digit_type) 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_bignum_fast(bignum_zero)
+#define BIGNUM_ONE(neg_p) \
+ untag_bignum_fast(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 */
--- /dev/null
+#include "master.hpp"
+
+/* FFI calls this */
+void box_boolean(bool value)
+{
+ dpush(value ? T : F);
+}
+
+/* FFI calls this */
+bool to_boolean(CELL value)
+{
+ return value != F;
+}
--- /dev/null
+INLINE CELL tag_boolean(CELL untagged)
+{
+ return (untagged == false ? F : T);
+}
+
+DLLEXPORT void box_boolean(bool value);
+DLLEXPORT bool to_boolean(CELL value);
--- /dev/null
+#include "master.hpp"
+
+/* must fill out array before next GC */
+F_BYTE_ARRAY *allot_byte_array_internal(CELL size)
+{
+ F_BYTE_ARRAY *array = (F_BYTE_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(F_BYTE_ARRAY,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_byte_array_fast(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;
+}
--- /dev/null
+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(2));
+ 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_byte_array_fast(byte_array->array),byte_array->count));
+}
--- /dev/null
+#include "master.hpp"
+
+/* 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 = (F_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_array_fast(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
+ {
+ char *return_addr = (char *)FRAME_RETURN_ADDRESS(frame);
+ char *quot_xt = (char *)(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(F_CALLSTACK,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(F_QUOTATION,quot);
+ UNREGISTER_UNTAGGED(F_CALLSTACK,callstack);
+
+ F_STACK_FRAME *inner = innermost_stack_frame(callstack);
+ type_check(QUOTATION_TYPE,frame_executing(inner));
+
+ CELL offset = (char *)FRAME_RETURN_ADDRESS(inner) - (char *)inner->xt;
+
+ inner->xt = quot->xt;
+
+ FRAME_RETURN_ADDRESS(inner) = (char *)quot->xt + offset;
+}
--- /dev/null
+INLINE CELL callstack_size(CELL size)
+{
+ return sizeof(F_CALLSTACK) + size;
+}
+
+DEFINE_UNTAG(F_CALLSTACK,CALLSTACK_TYPE,callstack)
+
+#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);
+
+F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom);
--- /dev/null
+#include "master.hpp"
+
+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_byte_array_fast(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 klass, CELL offset, F_FIXNUM absolute_value)
+{
+ F_FIXNUM relative_value = absolute_value - offset;
+
+ switch(klass)
+ {
+ 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",klass);
+ 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_array_fast(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_quotation_fast(obj);
+ return (CELL)quot->xt;
+ }
+ else
+ {
+ F_WORD *word = untag_word_fast(obj);
+ return (CELL)word->xt;
+ }
+}
+
+CELL word_direct_xt(CELL obj)
+{
+ F_WORD *word = untag_word_fast(obj);
+ CELL quot = word->direct_entry_def;
+ if(quot == F || max_pic_size == 0)
+ return (CELL)word->xt;
+ else
+ {
+ F_QUOTATION *untagged = untag_quotation_fast(quot);
+ 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_array_fast(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 (void *)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_array_fast(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;
+ }
+ }
+
+#ifdef FACTOR_DEBUG
+ print_obj(symbol); nl(); fflush(stdout);
+#endif
+
+ return (void *)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_array_fast(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 klass = 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(klass,
+ 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(F_ARRAY,labels);
+ UNREGISTER_UNTAGGED(F_BYTE_ARRAY,code);
+ UNREGISTER_ROOT(relocation);
+ UNREGISTER_ROOT(literals);
+
+ /* slight space optimization */
+ if(type_of(literals) == ARRAY_TYPE && array_capacity(untag_array_fast(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;
+}
--- /dev/null
+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) (F_RELTYPE)(((r) & 0xf0000000) >> 28)
+#define REL_CLASS(r) (F_RELCLASS)(((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 klass, 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);
--- /dev/null
+#include "master.hpp"
+
+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;
+ }
+}
--- /dev/null
+#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;
+}
--- /dev/null
+#include "master.hpp"
+
+F_HEAP code_heap;
+
+/* 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(F_WORD,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(F_WORD,word);
+ UNREGISTER_UNTAGGED(F_ARRAY,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(F_WORD,word);
+ UNREGISTER_UNTAGGED(F_ARRAY,alist);
+
+ word->code = compiled;
+ }
+ else
+ critical_error("Expected a quotation or an array",data);
+
+ REGISTER_UNTAGGED(alist);
+ update_word_xt(word);
+ UNREGISTER_UNTAGGED(F_ARRAY,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_word_fast(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_quotation_fast(obj);
+
+ if(quot->compiledp != F)
+ quot->code = forward_xt(quot->code);
+ }
+ else if(type_of(obj) == CALLSTACK_TYPE)
+ {
+ F_CALLSTACK *stack = untag_callstack_fast(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_word_fast(obj);
+ update_word_xt(word);
+ }
+ else if(type_of(obj) == QUOTATION_TYPE)
+ {
+ F_QUOTATION *quot = untag_quotation_fast(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);
+}
--- /dev/null
+/* compiled code */
+extern 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
+}
--- /dev/null
+#include "asm.h"
+
+/* Note that the XT is passed to the quotation in r12 */
+#define CALL_QUOT \
+ ldr r12,[r0, #9] /* load quotation-xt slot */ ; \
+ mov lr,pc ; \
+ mov pc,r12
+
+#define JUMP_QUOT \
+ ldr r12,[r0, #9] /* load quotation-xt slot */ ; \
+ mov pc,r12
+
+#define SAVED_REGS_SIZE 32
+
+#define FRAME (RESERVED_SIZE + SAVED_REGS_SIZE + 8)
+
+#define LR_SAVE [sp, #-4]
+#define RESERVED_SIZE 8
+
+#define SAVE_LR str lr,LR_SAVE
+
+#define LOAD_LR ldr lr,LR_SAVE
+
+#define SAVE_AT(offset) (RESERVED_SIZE + 4 * offset)
+
+#define SAVE(register,offset) str register,[sp, #SAVE_AT(offset)]
+
+#define RESTORE(register,offset) ldr register,[sp, #SAVE_AT(offset)]
+
+#define PROLOGUE \
+ SAVE_LR ; \
+ sub sp,sp,#FRAME
+
+#define EPILOGUE \
+ add sp,sp,#FRAME ; \
+ LOAD_LR
+
+DEF(void,c_to_factor,(CELL quot)):
+ PROLOGUE
+
+ SAVE(r4,0) /* save GPRs */
+ /* don't save ds pointer */
+ /* don't save rs pointer */
+ SAVE(r7,3)
+ SAVE(r8,4)
+ SAVE(r9,5)
+ SAVE(r10,6)
+ SAVE(r11,7)
+ SAVE(r0,8) /* save quotation since we're about to mangle it */
+
+ sub r0,sp,#4 /* pass call stack pointer as an argument */
+ bl MANGLE(save_callstack_bottom)
+
+ RESTORE(r0,8) /* restore quotation */
+ CALL_QUOT
+
+ RESTORE(r11,7) /* restore GPRs */
+ RESTORE(r10,6)
+ RESTORE(r9,5)
+ RESTORE(r8,4)
+ RESTORE(r7,3)
+ /* don't restore rs pointer */
+ /* don't restore ds pointer */
+ RESTORE(r4,0)
+
+ EPILOGUE
+ mov pc,lr
+
+/* The JIT compiles an 'mov r1',sp in front of every primitive call, since a
+word which was defined as a primitive will not change its definition for the
+lifetime of the image -- adding new primitives requires a bootstrap. However,
+an undefined word can certainly become defined,
+
+DEFER: foo
+...
+: foo ... ;
+
+And calls to non-primitives do not have this one-instruction prologue, so we
+set the XT of undefined words to this symbol. */
+DEF(void,undefined,(CELL word)):
+ sub r1,sp,#4
+ b MANGLE(undefined_error)
+
+/* Here we have two entry points. The first one is taken when profiling is
+enabled */
+DEF(void,docol_profiling,(CELL word)):
+ ldr r1,[r0, #25] /* load profile-count slot */
+ add r1,r1,#8 /* increment count */
+ str r1,[r0, #25] /* store profile-count slot */
+DEF(void,docol,(CELL word)):
+ ldr r0,[r0, #13] /* load word-def slot */
+ JUMP_QUOT
+
+/* We must pass the XT to the quotation in r12. */
+DEF(void,primitive_call,(void)):
+ ldr r0,[r5], #-4 /* load quotation from data stack */
+ JUMP_QUOT
+
+/* We must preserve r1 here in case we're calling a primitive */
+DEF(void,primitive_execute,(void)):
+ ldr r0,[r5], #-4 /* load word from data stack */
+ ldr pc,[r0, #29] /* jump to word-xt */
+
+DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length)):
+ sub sp,r0,r2 /* compute new stack pointer */
+ mov r0,sp /* start of destination of memcpy() */
+ sub sp,sp,#12 /* alignment */
+ bl MANGLE(memcpy) /* go */
+ add sp,sp,#16 /* point SP at innermost frame */
+ ldr pc,LR_SAVE /* return */
+
+DEF(void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
+ add sp,r1,#4 /* compute new stack pointer */
+ ldr lr,LR_SAVE /* we have rewound the stack; load return address */
+ JUMP_QUOT /* call the quotation */
+
+DEF(void,lazy_jit_compile,(CELL quot)):
+ mov r1,sp /* save stack pointer */
+ PROLOGUE
+ bl MANGLE(lazy_jit_compile_impl)
+ EPILOGUE
+ JUMP_QUOT /* call the quotation */
+
+#ifdef WINCE
+ .section .drectve
+ .ascii " -export:c_to_factor"
+#endif
--- /dev/null
+#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);
--- /dev/null
+/* Parts of this file were snarfed from SBCL src/runtime/ppc-assem.S, which is
+in the public domain. */
+#include "asm.h"
+
+#define DS_REG r29
+
+DEF(void,primitive_fixnum_add,(void)):
+ lwz r3,0(DS_REG)
+ lwz r4,-4(DS_REG)
+ subi DS_REG,DS_REG,4
+ li r0,0
+ mtxer r0
+ addo. r5,r3,r4
+ bso add_overflow
+ stw r5,0(DS_REG)
+ blr
+add_overflow:
+ b MANGLE(overflow_fixnum_add)
+
+DEF(void,primitive_fixnum_subtract,(void)):
+ lwz r3,-4(DS_REG)
+ lwz r4,0(DS_REG)
+ subi DS_REG,DS_REG,4
+ li r0,0
+ mtxer r0
+ subfo. r5,r4,r3
+ bso sub_overflow
+ stw r5,0(DS_REG)
+ blr
+sub_overflow:
+ b MANGLE(overflow_fixnum_subtract)
+
+DEF(void,primitive_fixnum_multiply,(void)):
+ lwz r3,0(DS_REG)
+ lwz r4,-4(DS_REG)
+ subi DS_REG,DS_REG,4
+ srawi r3,r3,3
+ mullwo. r5,r3,r4
+ bso multiply_overflow
+ stw r5,0(DS_REG)
+ blr
+multiply_overflow:
+ srawi r4,r4,3
+ b MANGLE(overflow_fixnum_multiply)
+
+/* Note that the XT is passed to the quotation in r11 */
+#define CALL_OR_JUMP_QUOT \
+ lwz r11,14(r3) /* load quotation-xt slot */ XX \
+
+#define CALL_QUOT \
+ CALL_OR_JUMP_QUOT XX \
+ mtlr r11 /* prepare to call XT with quotation in r3 */ XX \
+ blrl /* go */
+
+#define JUMP_QUOT \
+ CALL_OR_JUMP_QUOT XX \
+ mtctr r11 /* prepare to call XT with quotation in r3 */ XX \
+ bctr /* go */
+
+#define PARAM_SIZE 32
+
+#define SAVED_INT_REGS_SIZE 96
+
+#define SAVED_FP_REGS_SIZE 144
+
+#define FRAME (RESERVED_SIZE + PARAM_SIZE + SAVED_INT_REGS_SIZE + SAVED_FP_REGS_SIZE + 8)
+
+#if defined( __APPLE__)
+ #define LR_SAVE 8
+ #define RESERVED_SIZE 24
+#else
+ #define LR_SAVE 4
+ #define RESERVED_SIZE 8
+#endif
+
+#define SAVE_LR(reg) stw reg,(LR_SAVE + FRAME)(r1)
+
+#define LOAD_LR(reg) lwz reg,(LR_SAVE + FRAME)(r1)
+
+#define SAVE_AT(offset) (RESERVED_SIZE + PARAM_SIZE + 4 * offset)
+
+#define SAVE_INT(register,offset) stw register,SAVE_AT(offset)(r1)
+#define RESTORE_INT(register,offset) lwz register,SAVE_AT(offset)(r1)
+
+#define SAVE_FP(register,offset) stfd register,SAVE_AT(offset)(r1)
+#define RESTORE_FP(register,offset) lfd register,SAVE_AT(offset)(r1)
+
+#define PROLOGUE \
+ mflr r0 XX /* get caller's return address */ \
+ stwu r1,-FRAME(r1) XX /* create a stack frame to hold non-volatile registers */ \
+ SAVE_LR(r0)
+
+#define EPILOGUE \
+ LOAD_LR(r0) XX \
+ lwz r1,0(r1) XX /* destroy the stack frame */ \
+ mtlr r0 /* get ready to return */
+
+/* We have to save and restore nonvolatile registers because
+the Factor compiler treats the entire register file as volatile. */
+DEF(void,c_to_factor,(CELL quot)):
+ PROLOGUE
+
+ SAVE_INT(r13,0) /* save GPRs */
+ SAVE_INT(r14,1)
+ SAVE_INT(r15,2)
+ SAVE_INT(r16,3)
+ SAVE_INT(r17,4)
+ SAVE_INT(r18,5)
+ SAVE_INT(r19,6)
+ SAVE_INT(r20,7)
+ SAVE_INT(r21,8)
+ SAVE_INT(r22,9)
+ SAVE_INT(r23,10)
+ SAVE_INT(r24,11)
+ SAVE_INT(r25,12)
+ SAVE_INT(r26,13)
+ SAVE_INT(r27,14)
+ SAVE_INT(r28,15)
+ SAVE_INT(r31,16)
+
+ SAVE_FP(f14,20) /* save FPRs */
+ SAVE_FP(f15,22)
+ SAVE_FP(f16,24)
+ SAVE_FP(f17,26)
+ SAVE_FP(f18,28)
+ SAVE_FP(f19,30)
+ SAVE_FP(f20,32)
+ SAVE_FP(f21,34)
+ SAVE_FP(f22,36)
+ SAVE_FP(f23,38)
+ SAVE_FP(f24,40)
+ SAVE_FP(f25,42)
+ SAVE_FP(f26,44)
+ SAVE_FP(f27,46)
+ SAVE_FP(f28,48)
+ SAVE_FP(f29,50)
+ SAVE_FP(f30,52)
+ SAVE_FP(f31,54)
+
+ SAVE_INT(r3,19) /* save quotation since we're about to mangle it */
+
+ mr r3,r1 /* pass call stack pointer as an argument */
+ bl MANGLE(save_callstack_bottom)
+
+ RESTORE_INT(r3,19) /* restore quotation */
+ CALL_QUOT
+
+ RESTORE_FP(f31,54)
+ RESTORE_FP(f30,52)
+ RESTORE_FP(f29,50)
+ RESTORE_FP(f28,48)
+ RESTORE_FP(f27,46)
+ RESTORE_FP(f26,44)
+ RESTORE_FP(f25,42)
+ RESTORE_FP(f24,40)
+ RESTORE_FP(f23,38)
+ RESTORE_FP(f22,36)
+ RESTORE_FP(f21,34)
+ RESTORE_FP(f20,32)
+ RESTORE_FP(f19,30)
+ RESTORE_FP(f18,28)
+ RESTORE_FP(f17,26)
+ RESTORE_FP(f16,24)
+ RESTORE_FP(f15,22)
+ RESTORE_FP(f14,20) /* save FPRs */
+
+ RESTORE_INT(r31,16) /* restore GPRs */
+ RESTORE_INT(r28,15)
+ RESTORE_INT(r27,14)
+ RESTORE_INT(r26,13)
+ RESTORE_INT(r25,12)
+ RESTORE_INT(r24,11)
+ RESTORE_INT(r23,10)
+ RESTORE_INT(r22,9)
+ RESTORE_INT(r21,8)
+ RESTORE_INT(r20,7)
+ RESTORE_INT(r19,6)
+ RESTORE_INT(r18,5)
+ RESTORE_INT(r17,4)
+ RESTORE_INT(r16,3)
+ RESTORE_INT(r15,2)
+ RESTORE_INT(r14,1)
+ RESTORE_INT(r13,0)
+
+ EPILOGUE
+ blr
+
+/* We pass a function pointer to memcpy in r6 to work around a Mac OS X ABI
+limitation which would otherwise require us to do a bizzaro PC-relative
+trampoline to retrieve the function address */
+DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy)):
+ sub r1,r3,r5 /* compute new stack pointer */
+ mr r3,r1 /* start of destination of memcpy() */
+ stwu r1,-64(r1) /* setup fake stack frame for memcpy() */
+ mtlr r6 /* prepare to call memcpy() */
+ blrl /* go */
+ lwz r1,0(r1) /* tear down fake stack frame */
+ lwz r0,LR_SAVE(r1) /* we have restored the stack; load return address */
+ mtlr r0 /* prepare to return to restored callstack */
+ blr /* go */
+
+DEF(void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
+ mr r1,r4 /* compute new stack pointer */
+ lwz r0,LR_SAVE(r1) /* we have rewound the stack; load return address */
+ mtlr r0
+ JUMP_QUOT /* call the quotation */
+
+DEF(void,lazy_jit_compile,(CELL quot)):
+ mr r4,r1 /* save stack pointer */
+ PROLOGUE
+ bl MANGLE(lazy_jit_compile_impl)
+ EPILOGUE
+ JUMP_QUOT /* call the quotation */
+
+/* Thanks to Joshua Grams for this code.
+
+On PowerPC processors, we must flush the instruction cache manually
+after writing to the code heap. */
+
+DEF(void,flush_icache,(void *start, int len)):
+ /* compute number of cache lines to flush */
+ add r4,r4,r3
+ clrrwi r3,r3,5 /* align addr to next lower cache line boundary */
+ sub r4,r4,r3 /* then n_lines = (len + 0x1f) / 0x20 */
+ addi r4,r4,0x1f
+ srwi. r4,r4,5 /* note '.' suffix */
+ beqlr /* if n_lines == 0, just return. */
+ mtctr r4 /* flush cache lines */
+0: dcbf 0,r3 /* for each line... */
+ sync
+ icbi 0,r3
+ addi r3,r3,0x20
+ bdnz 0b
+ sync /* finish up */
+ isync
+ blr
--- /dev/null
+#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);
--- /dev/null
+#include "asm.h"
+
+/* Note that primitive word definitions are compiled with
+__attribute__((regparm 2), so the pointer to the word object is passed in EAX,
+and the callstack top is passed in EDX */
+
+#define ARG0 %eax
+#define ARG1 %edx
+#define STACK_REG %esp
+#define DS_REG %esi
+#define RETURN_REG %eax
+
+#define NV_TEMP_REG %ebx
+
+#define ARITH_TEMP_1 %ebp
+#define ARITH_TEMP_2 %ebx
+#define DIV_RESULT %eax
+
+#define CELL_SIZE 4
+#define STACK_PADDING 12
+
+#define PUSH_NONVOLATILE \
+ push %ebx ; \
+ push %ebp ; \
+ push %ebp
+
+#define POP_NONVOLATILE \
+ pop %ebp ; \
+ pop %ebp ; \
+ pop %ebx
+
+#define QUOT_XT_OFFSET 16
+#define WORD_XT_OFFSET 30
+
+/* We pass a function pointer to memcpy to work around a Mac OS X
+ABI limitation which would otherwise require us to do a bizzaro PC-relative
+trampoline to retrieve the function address */
+DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy)):
+ mov 4(%esp),%ebp /* to */
+ mov 8(%esp),%edx /* from */
+ mov 12(%esp),%ecx /* length */
+ mov 16(%esp),%eax /* memcpy */
+ sub %ecx,%ebp /* compute new stack pointer */
+ mov %ebp,%esp
+ push %ecx /* pass length */
+ push %edx /* pass src */
+ push %ebp /* pass dst */
+ call *%eax /* call memcpy */
+ add $12,%esp /* pop args from the stack */
+ ret /* return _with new stack_ */
+
+/* cpu.x86.32 calls this */
+DEF(bool,check_sse2,(void)):
+ push %ebx
+ mov $1,%eax
+ cpuid
+ shr $26,%edx
+ and $1,%edx
+ pop %ebx
+ mov %edx,%eax
+ ret
+
+DEF(F_FASTCALL void,primitive_inline_cache_miss,(void)):
+ mov (%esp),%eax
+ sub $8,%esp
+ push %eax
+ call MANGLE(inline_cache_miss)
+ add $12,%esp
+ jmp *%eax
+
+#include "cpu-x86.S"
+
+#ifdef WINDOWS
+ .section .drectve
+ .ascii " -export:check_sse2"
+#endif
--- /dev/null
+#define FACTOR_CPU_STRING "x86.32"
+
+register CELL ds asm("esi");
+register CELL rs asm("edi");
+
+#define F_FASTCALL extern "C" __attribute__ ((regparm (2)))
--- /dev/null
+#include "asm.h"
+
+#define STACK_REG %rsp
+#define DS_REG %r14
+#define RETURN_REG %rax
+
+#define CELL_SIZE 8
+#define STACK_PADDING 56
+
+#define NV_TEMP_REG %rbp
+
+#define ARITH_TEMP_1 %r8
+#define ARITH_TEMP_2 %r9
+#define DIV_RESULT %rax
+
+#ifdef WINDOWS
+
+ #define ARG0 %rcx
+ #define ARG1 %rdx
+ #define ARG2 %r8
+ #define ARG3 %r9
+
+ #define PUSH_NONVOLATILE \
+ push %r12 ; \
+ push %r13 ; \
+ push %rdi ; \
+ push %rsi ; \
+ push %rbx ; \
+ push %rbp ; \
+ push %rbp
+
+ #define POP_NONVOLATILE \
+ pop %rbp ; \
+ pop %rbp ; \
+ pop %rbx ; \
+ pop %rsi ; \
+ pop %rdi ; \
+ pop %r13 ; \
+ pop %r12
+
+#else
+
+ #define ARG0 %rdi
+ #define ARG1 %rsi
+ #define ARG2 %rdx
+ #define ARG3 %rcx
+
+ #define PUSH_NONVOLATILE \
+ push %rbx ; \
+ push %rbp ; \
+ push %r12 ; \
+ push %r13 ; \
+ push %r13
+
+ #define POP_NONVOLATILE \
+ pop %r13 ; \
+ pop %r13 ; \
+ pop %r12 ; \
+ pop %rbp ; \
+ pop %rbx
+
+#endif
+
+#define QUOT_XT_OFFSET 36
+#define WORD_XT_OFFSET 66
+
+/* We pass a function pointer to memcpy to work around a Mac OS X
+ABI limitation which would otherwise require us to do a bizzaro PC-relative
+trampoline to retrieve the function address */
+DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy)):
+ sub ARG2,ARG0 /* compute new stack pointer */
+ mov ARG0,%rsp
+ call *ARG3 /* call memcpy */
+ ret /* return _with new stack_ */
+
+DEF(F_FASTCALL void,primitive_inline_cache_miss,(void)):
+ mov (%rsp),ARG0
+ sub $STACK_PADDING,%rsp
+ call MANGLE(inline_cache_miss)
+ add $STACK_PADDING,%rsp
+ jmp *%rax
+
+#include "cpu-x86.S"
--- /dev/null
+#define FACTOR_CPU_STRING "x86.64"
+
+register CELL ds asm("r14");
+register CELL rs asm("r15");
+
+#define F_FASTCALL extern "C"
--- /dev/null
+DEF(void,primitive_fixnum_add,(void)):
+ mov (DS_REG),ARG0
+ mov -CELL_SIZE(DS_REG),ARG1
+ sub $CELL_SIZE,DS_REG
+ mov ARG1,ARITH_TEMP_1
+ add ARG0,ARITH_TEMP_1
+ jo MANGLE(overflow_fixnum_add)
+ mov ARITH_TEMP_1,(DS_REG)
+ ret
+
+DEF(void,primitive_fixnum_subtract,(void)):
+ mov (DS_REG),ARG1
+ mov -CELL_SIZE(DS_REG),ARG0
+ sub $CELL_SIZE,DS_REG
+ mov ARG0,ARITH_TEMP_1
+ sub ARG1,ARITH_TEMP_1
+ jo MANGLE(overflow_fixnum_subtract)
+ mov ARITH_TEMP_1,(DS_REG)
+ ret
+
+DEF(void,primitive_fixnum_multiply,(void)):
+ mov (DS_REG),ARITH_TEMP_1
+ mov ARITH_TEMP_1,DIV_RESULT
+ mov -CELL_SIZE(DS_REG),ARITH_TEMP_2
+ sar $3,ARITH_TEMP_2
+ sub $CELL_SIZE,DS_REG
+ imul ARITH_TEMP_2
+ jo multiply_overflow
+ mov DIV_RESULT,(DS_REG)
+ ret
+multiply_overflow:
+ sar $3,ARITH_TEMP_1
+ mov ARITH_TEMP_1,ARG0
+ mov ARITH_TEMP_2,ARG1
+ jmp MANGLE(overflow_fixnum_multiply)
+
+DEF(F_FASTCALL void,c_to_factor,(CELL quot)):
+ PUSH_NONVOLATILE
+ mov ARG0,NV_TEMP_REG
+
+ /* Create register shadow area for Win64 */
+ sub $32,STACK_REG
+
+ /* Save stack pointer */
+ lea -CELL_SIZE(STACK_REG),ARG0
+ call MANGLE(save_callstack_bottom)
+
+ /* Call quot-xt */
+ mov NV_TEMP_REG,ARG0
+ call *QUOT_XT_OFFSET(ARG0)
+
+ /* Tear down register shadow area */
+ add $32,STACK_REG
+
+ POP_NONVOLATILE
+ ret
+
+DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
+ /* rewind_to */
+ mov ARG1,STACK_REG
+ jmp *QUOT_XT_OFFSET(ARG0)
+
+DEF(F_FASTCALL void,lazy_jit_compile,(CELL quot)):
+ mov STACK_REG,ARG1 /* Save stack pointer */
+ sub $STACK_PADDING,STACK_REG
+ call MANGLE(lazy_jit_compile_impl)
+ mov RETURN_REG,ARG0 /* No-op on 32-bit */
+ add $STACK_PADDING,STACK_REG
+ jmp *QUOT_XT_OFFSET(ARG0) /* Call the quotation */
+
+#ifdef WINDOWS
+ .section .drectve
+ .ascii " -export:c_to_factor"
+#endif
--- /dev/null
+#include <assert.h>
+
+#define FRAME_RETURN_ADDRESS(frame) *(XT *)(frame_successor(frame) + 1)
+
+INLINE void flush_icache(CELL start, CELL len) {}
+
+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);
+}
+
+/* Defined in assembly */
+extern "C" void primitive_fixnum_add(void);
+extern "C" void primitive_fixnum_subtract(void);
+extern "C" void primitive_fixnum_multiply(void);
+
+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);
+
+extern "C" void set_callstack(F_STACK_FRAME *to,
+ F_STACK_FRAME *from,
+ CELL length,
+ void *(*memcpy)(void*,const void*, size_t));
+
+extern "C" void primitive_inline_cache_miss(void);
--- /dev/null
+#include "master.hpp"
+
+/* used during garbage collection only */
+F_ZONE *newspace;
+bool performing_gc;
+bool performing_compaction;
+CELL collecting_gen;
+
+/* if true, we collecting AGING space for the second time, so if it is still
+full, we go on to collect TENURED */
+bool collecting_aging_again;
+
+/* in case a generation fills up in the middle of a gc, we jump back
+up to try collecting the next generation. */
+jmp_buf gc_jmp;
+
+F_GC_STATS gc_stats[MAX_GEN_COUNT];
+u64 cards_scanned;
+u64 decks_scanned;
+u64 card_scan_time;
+CELL code_heap_scans;
+
+/* What generation was being collected when copy_code_heap_roots() was last
+called? Until the next call to add_code_block(), future
+collections of younger generations don't have to touch the code
+heap. */
+CELL last_code_heap_scan;
+
+/* sometimes we grow the heap */
+bool growing_data_heap;
+F_DATA_HEAP *old_data_heap;
+
+void init_data_gc(void)
+{
+ performing_gc = false;
+ last_code_heap_scan = NURSERY;
+ collecting_aging_again = false;
+}
+
+/* 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();
+
+ CELL 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;
+}
+
+bool should_copy_p(CELL untagged)
+{
+ if(in_zone(newspace,untagged))
+ return false;
+ if(collecting_gen == TENURED)
+ return true;
+ else if(HAVE_AGING_P && collecting_gen == AGING)
+ return !in_zone(&data_heap->generations[TENURED],untagged);
+ else if(collecting_gen == NURSERY)
+ return in_zone(&nursery,untagged);
+ else
+ {
+ critical_error("Bug in should_copy_p",untagged);
+ return false;
+ }
+}
+
+/* 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_p(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_p(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();
+}
--- /dev/null
+void gc(void);
+DLLEXPORT void minor_gc(void);
+
+/* used during garbage collection only */
+
+F_ZONE *newspace;
+bool performing_gc;
+bool performing_compaction;
+CELL collecting_gen;
+
+/* if true, we collecting AGING space for the second time, so if it is still
+full, we go on to collect TENURED */
+bool collecting_aging_again;
+
+/* in case a generation fills up in the middle of a gc, we jump back
+up to try collecting the next generation. */
+jmp_buf gc_jmp;
+
+/* statistics */
+typedef struct {
+ CELL collections;
+ u64 gc_time;
+ u64 max_gc_time;
+ CELL object_count;
+ u64 bytes_copied;
+} F_GC_STATS;
+
+F_GC_STATS gc_stats[MAX_GEN_COUNT];
+u64 cards_scanned;
+u64 decks_scanned;
+u64 card_scan_time;
+CELL code_heap_scans;
+
+/* What generation was being collected when copy_code_heap_roots() was last
+called? Until the next call to add_code_block(), future
+collections of younger generations don't have to touch the code
+heap. */
+CELL last_code_heap_scan;
+
+/* sometimes we grow the heap */
+bool growing_data_heap;
+F_DATA_HEAP *old_data_heap;
+
+INLINE bool collecting_accumulation_gen_p(void)
+{
+ return ((HAVE_AGING_P
+ && collecting_gen == AGING
+ && !collecting_aging_again)
+ || collecting_gen == TENURED);
+}
+
+/* test if the pointer is in generation being collected, or a younger one. */
+INLINE bool should_copy(CELL untagged)
+{
+ if(in_zone(newspace,untagged))
+ return false;
+ if(collecting_gen == TENURED)
+ return true;
+ else if(HAVE_AGING_P && collecting_gen == AGING)
+ return !in_zone(&data_heap->generations[TENURED],untagged);
+ else if(collecting_gen == NURSERY)
+ return in_zone(&nursery,untagged);
+ else
+ {
+ critical_error("Bug in should_copy",untagged);
+ return false;
+ }
+}
+
+void copy_handle(CELL *handle);
+
+void garbage_collection(volatile CELL gen,
+ bool growing_data_heap_,
+ CELL requested_bytes);
+
+/* We leave this many bytes free at the top of the nursery so that inline
+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 allocation. This catches missing local roots */
+
+/*
+ * It is up to the caller to fill in the object's fields in a meaningful
+ * fashion!
+ */
+
+INLINE void *allot_object(CELL type, CELL a)
+{
+#ifdef GC_DEBUG
+ if(!gc_off)
+ gc();
+#endif
+
+ CELL *object;
+
+ if(nursery.size - ALLOT_BUFFER_ZONE > a)
+ {
+ /* If there is insufficient room, collect the nursery */
+ if(nursery.here + ALLOT_BUFFER_ZONE + a > nursery.end)
+ garbage_collection(NURSERY,false,0);
+
+ CELL h = nursery.here;
+ nursery.here = h + align8(a);
+ object = (CELL*)h;
+ }
+ /* If the object is bigger than the nursery, allocate it in
+ tenured space */
+ else
+ {
+ F_ZONE *tenured = &data_heap->generations[TENURED];
+
+ /* If tenured space does not have enough room, collect */
+ if(tenured->here + a > tenured->end)
+ {
+ gc();
+ tenured = &data_heap->generations[TENURED];
+ }
+
+ /* If it still won't fit, grow the heap */
+ if(tenured->here + a > tenured->end)
+ {
+ garbage_collection(TENURED,true,a);
+ tenured = &data_heap->generations[TENURED];
+ }
+
+ object = (CELL *)allot_zone(tenured,a);
+
+ /* We have to do this */
+ allot_barrier((CELL)object);
+
+ /* Allows initialization code to store old->new pointers
+ without hitting the write barrier in the common case of
+ a nursery allocation */
+ write_barrier((CELL)object);
+ }
+
+ *object = tag_header(type);
+ return object;
+}
+
+void copy_reachable_objects(CELL scan, CELL *end);
+
+void primitive_gc(void);
+void primitive_gc_stats(void);
+void clear_gc_stats(void);
+void primitive_clear_gc_stats(void);
+void primitive_become(void);
+
+INLINE void check_data_pointer(CELL pointer)
+{
+#ifdef FACTOR_DEBUG
+ if(!growing_data_heap)
+ {
+ assert(pointer >= data_heap->segment->start
+ && pointer < data_heap->segment->end);
+ }
+#endif
+}
--- /dev/null
+void init_data_gc(void);
+
+void gc(void);
+DLLEXPORT void minor_gc(void);
+
+/* statistics */
+typedef struct {
+ CELL collections;
+ u64 gc_time;
+ u64 max_gc_time;
+ CELL object_count;
+ u64 bytes_copied;
+} F_GC_STATS;
+
+extern F_ZONE *newspace;
+
+extern bool performing_compaction;
+extern CELL collecting_gen;
+extern bool collecting_aging_again;
+
+INLINE bool collecting_accumulation_gen_p(void)
+{
+ return ((HAVE_AGING_P
+ && collecting_gen == AGING
+ && !collecting_aging_again)
+ || collecting_gen == TENURED);
+}
+
+extern CELL last_code_heap_scan;
+
+/* test if the pointer is in generation being collected, or a younger one. */
+bool should_copy_p(CELL untagged);
+
+void copy_handle(CELL *handle);
+
+void garbage_collection(volatile CELL gen,
+ bool growing_data_heap_,
+ CELL requested_bytes);
+
+/* We leave this many bytes free at the top of the nursery so that inline
+allocation (which does not call GC because of possible roots in volatile
+registers) does not run out of memory */
+#define ALLOT_BUFFER_ZONE 1024
+
+/*
+ * It is up to the caller to fill in the object's fields in a meaningful
+ * fashion!
+ */
+INLINE void *allot_object(CELL type, CELL a)
+{
+#ifdef GC_DEBUG
+ if(!gc_off)
+ gc();
+#endif
+
+ CELL *object;
+
+ if(nursery.size - ALLOT_BUFFER_ZONE > a)
+ {
+ /* If there is insufficient room, collect the nursery */
+ if(nursery.here + ALLOT_BUFFER_ZONE + a > nursery.end)
+ garbage_collection(NURSERY,false,0);
+
+ CELL h = nursery.here;
+ nursery.here = h + align8(a);
+ object = (CELL*)h;
+ }
+ /* If the object is bigger than the nursery, allocate it in
+ tenured space */
+ else
+ {
+ F_ZONE *tenured = &data_heap->generations[TENURED];
+
+ /* If tenured space does not have enough room, collect */
+ if(tenured->here + a > tenured->end)
+ {
+ gc();
+ tenured = &data_heap->generations[TENURED];
+ }
+
+ /* If it still won't fit, grow the heap */
+ if(tenured->here + a > tenured->end)
+ {
+ garbage_collection(TENURED,true,a);
+ tenured = &data_heap->generations[TENURED];
+ }
+
+ object = (CELL *)allot_zone(tenured,a);
+
+ /* We have to do this */
+ allot_barrier((CELL)object);
+
+ /* Allows initialization code to store old->new pointers
+ without hitting the write barrier in the common case of
+ a nursery allocation */
+ write_barrier((CELL)object);
+ }
+
+ *object = tag_header(type);
+ return object;
+}
+
+void copy_reachable_objects(CELL scan, CELL *end);
+
+void primitive_gc(void);
+void primitive_gc_stats(void);
+void clear_gc_stats(void);
+void primitive_clear_gc_stats(void);
+void primitive_become(void);
+
+extern bool growing_data_heap;
+
+INLINE void check_data_pointer(CELL pointer)
+{
+#ifdef FACTOR_DEBUG
+ if(!growing_data_heap)
+ {
+ assert(pointer >= data_heap->segment->start
+ && pointer < data_heap->segment->end);
+ }
+#endif
+}
--- /dev/null
+#include "master.hpp"
+
+/* Set by the -securegc command line argument */
+bool secure_gc;
+
+/* new objects are allocated here */
+DLLEXPORT F_ZONE nursery;
+
+/* GC is off during heap walking */
+bool gc_off;
+
+F_DATA_HEAP *data_heap;
+
+F_ZONE nursery;
+
+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 = (F_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 = (F_ZONE *)safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
+ data_heap->semispaces = (F_ZONE *)safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
+
+ CELL cards_size = total_size >> CARD_BITS;
+ data_heap->allot_markers = (CELL *)safe_malloc(cards_size);
+ data_heap->allot_markers_end = data_heap->allot_markers + cards_size;
+
+ data_heap->cards = (CELL *)safe_malloc(cards_size);
+ data_heap->cards_end = data_heap->cards + cards_size;
+
+ CELL decks_size = total_size >> DECK_BITS;
+ data_heap->decks = (CELL *)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_;
+
+ init_data_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_tuple_fast(pointer);
+ layout = untag_tuple_layout(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_tuple_fast(pointer);
+ layout = untag_tuple_layout(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);
+
+ CELL 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);
+}
+
+/* A heap walk allows useful things to be done, like finding all
+references to an object for debugging purposes. */
+CELL heap_scan_ptr;
+
+/* 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;
+}
--- /dev/null
+/* Set by the -securegc command line argument */
+extern 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;
+
+extern 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 */
+extern 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);
+
+/* GC is off during heap walking */
+extern 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;
+ }
+}
+
--- /dev/null
+#include "master.hpp"
+
+static bool fep_disabled;
+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_tuple_layout(tuple->layout);
+ CELL length = to_fixnum(layout->size);
+
+ print_string(" ");
+ print_nested_obj(layout->klass,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_tuple_fast(obj),nesting - 1);
+ print_string(" }");
+ break;
+ case ARRAY_TYPE:
+ print_string("{");
+ print_array(untag_array_fast(obj),nesting - 1);
+ print_string(" }");
+ break;
+ case QUOTATION_TYPE:
+ print_string("[");
+ quot = untag_quotation_fast(obj);
+ print_array(untag_array_fast(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(CELL type)
+{
+ gc();
+ begin_scan();
+
+ CELL obj;
+ while((obj = next_object()) != F)
+ {
+ if(type == TYPE_COUNT || 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(TYPE_COUNT);
+ 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();
+}
--- /dev/null
+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);
+
+void primitive_die(void);
--- /dev/null
+#include "master.hpp"
+
+CELL megamorphic_cache_hits;
+CELL megamorphic_cache_misses;
+
+static CELL search_lookup_alist(CELL table, CELL klass)
+{
+ F_ARRAY *pairs = untag_array_fast(table);
+ F_FIXNUM index = array_capacity(pairs) - 1;
+ while(index >= 0)
+ {
+ F_ARRAY *pair = untag_array_fast(array_nth(pairs,index));
+ if(array_nth(pair,0) == klass)
+ return array_nth(pair,1);
+ else
+ index--;
+ }
+
+ return F;
+}
+
+static CELL search_lookup_hash(CELL table, CELL klass, CELL hashcode)
+{
+ F_ARRAY *buckets = untag_array_fast(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,klass);
+}
+
+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_tuple_fast(object);
+ F_TUPLE_LAYOUT *layout = untag_tuple_layout(tuple->layout);
+
+ F_ARRAY *echelons = untag_array_fast(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 klass = nth_superclass(layout,echelon);
+ CELL hashcode = untag_fixnum_fast(nth_hashcode(layout,echelon));
+ CELL result = search_lookup_hash(echelon_methods,klass,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_array_fast(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_array_fast(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_array_fast(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 klass, F_ARRAY *array)
+{
+ CELL capacity = (array_capacity(array) >> 1) - 1;
+ return ((klass >> TAG_BITS) & capacity) << 1;
+}
+
+static void update_method_cache(CELL cache, CELL klass, CELL method)
+{
+ F_ARRAY *array = untag_array_fast(cache);
+ CELL hashcode = method_cache_hashcode(klass,array);
+ set_array_nth(array,hashcode,klass);
+ 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 klass = object_class(object);
+ CELL method = lookup_method(object,methods);
+
+ update_method_cache(cache,klass,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]);
+}
--- /dev/null
+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);
--- /dev/null
+#include "master.hpp"
+
+/* Global variables used to pass fault handler state from signal handler to
+user-space */
+CELL signal_number;
+CELL signal_fault_addr;
+F_STACK_FRAME *signal_callstack_top;
+
+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();
+}
--- /dev/null
+/* 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##_fast(CELL obj) \
+ { \
+ return (type *)UNTAG(obj); \
+ } \
+ INLINE type *untag_##name(CELL obj) \
+ { \
+ type_check(check,obj); \
+ return untag_##name##_fast(obj); \
+ } \
+
+/* Global variables used to pass fault handler state from signal handler to
+user-space */
+extern CELL signal_number;
+extern CELL signal_fault_addr;
+extern F_STACK_FRAME *signal_callstack_top;
+
+void memory_signal_handler_impl(void);
+void misc_signal_handler_impl(void);
+
+void primitive_unimplemented(void);
--- /dev/null
+#include "master.hpp"
+
+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();
+
+ init_profiler();
+
+ 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(userenv[STAGE2_ENV] == F)
+ {
+ 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(F_ARRAY,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 *) = (char *(*)(char *))alien_offset(userenv[EVAL_CALLBACK_ENV]);
+ return callback(string);
+}
+
+void factor_eval_free(char *result)
+{
+ free(result);
+}
+
+void factor_yield(void)
+{
+ void (*callback)(void) = (void (*)(void))alien_offset(userenv[YIELD_CALLBACK_ENV]);
+ callback();
+}
+
+void factor_sleep(long us)
+{
+ void (*callback)(long) = (void (*)(long))alien_offset(userenv[SLEEP_CALLBACK_ENV]);
+ callback(us);
+}
--- /dev/null
+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);
--- /dev/null
+fraptor ICON "misc/icons/Factor.ico"
+
--- /dev/null
+/* This file is linked into the runtime for the sole purpose
+ * of testing FFI code. */
+#include "ffi_test.h"
+
+#include <assert.h>
+#include <string.h>
+
+void ffi_test_0(void)
+{
+}
+
+int ffi_test_1(void)
+{
+ return 3;
+}
+
+int ffi_test_2(int x, int y)
+{
+ return x + y;
+}
+
+int ffi_test_3(int x, int y, int z, int t)
+{
+ return x + y + z * t;
+}
+
+float ffi_test_4(void)
+{
+ return 1.5;
+}
+
+double ffi_test_5(void)
+{
+ return 1.5;
+}
+
+double ffi_test_6(float x, float y)
+{
+ return x * y;
+}
+
+double ffi_test_7(double x, double y)
+{
+ return x * y;
+}
+
+double ffi_test_8(double x, float y, double z, float t, int w)
+{
+ return x * y + z * t + w;
+}
+
+int ffi_test_9(int a, int b, int c, int d, int e, int f, int g)
+{
+ return a + b + c + d + e + f + g;
+}
+
+int ffi_test_10(int a, int b, double c, int d, float e, int f, int g, int h)
+{
+ return a - b - c - d - e - f - g - h;
+}
+
+int ffi_test_11(int a, struct foo b, int c)
+{
+ return a * b.x + c * b.y;
+}
+
+int ffi_test_12(int a, int b, struct rect c, int d, int e, int f)
+{
+ return a + b + c.x + c.y + c.w + c.h + d + e + f;
+}
+
+int ffi_test_13(int a, int b, int c, int d, int e, int f, int g, int h, int i, int j, int k)
+{
+ return a + b + c + d + e + f + g + h + i + j + k;
+}
+
+struct foo ffi_test_14(int x, int y)
+{
+ struct foo r;
+ r.x = x; r.y = y;
+ return r;
+}
+
+char *ffi_test_15(char *x, char *y)
+{
+ if(strcmp(x,y))
+ return "foo";
+ else
+ return "bar";
+}
+
+struct bar ffi_test_16(long x, long y, long z)
+{
+ struct bar r;
+ r.x = x; r.y = y; r.z = z;
+ return r;
+}
+
+struct tiny ffi_test_17(int x)
+{
+ struct tiny r;
+ r.x = x;
+ return r;
+}
+
+F_STDCALL int ffi_test_18(int x, int y, int z, int t)
+{
+ return x + y + z * t;
+}
+
+F_STDCALL struct bar ffi_test_19(long x, long y, long z)
+{
+ struct bar r;
+ r.x = x; r.y = y; r.z = z;
+ return r;
+}
+
+void ffi_test_20(double x1, double x2, double x3,
+ double y1, double y2, double y3,
+ double z1, double z2, double z3)
+{
+}
+
+long long ffi_test_21(long x, long y)
+{
+ return (long long)x * (long long)y;
+}
+
+long ffi_test_22(long x, long long y, long long z)
+{
+ return x + y / z;
+}
+
+float ffi_test_23(float x[3], float y[3])
+{
+ return x[0] * y[0] + x[1] * y[1] + x[2] * y[2];
+}
+
+struct test_struct_1 ffi_test_24(void)
+{
+ struct test_struct_1 s;
+ s.x = 1;
+ return s;
+}
+
+struct test_struct_2 ffi_test_25(void)
+{
+ struct test_struct_2 s;
+ s.x = 1;
+ s.y = 2;
+ return s;
+}
+
+struct test_struct_3 ffi_test_26(void)
+{
+ struct test_struct_3 s;
+ s.x = 1;
+ s.y = 2;
+ s.z = 3;
+ return s;
+}
+
+struct test_struct_4 ffi_test_27(void)
+{
+ struct test_struct_4 s;
+ s.x = 1;
+ s.y = 2;
+ s.z = 3;
+ s.a = 4;
+ return s;
+}
+
+struct test_struct_5 ffi_test_28(void)
+{
+ struct test_struct_5 s;
+ s.x = 1;
+ s.y = 2;
+ s.z = 3;
+ s.a = 4;
+ s.b = 5;
+ return s;
+}
+
+struct test_struct_6 ffi_test_29(void)
+{
+ struct test_struct_6 s;
+ s.x = 1;
+ s.y = 2;
+ s.z = 3;
+ s.a = 4;
+ s.b = 5;
+ s.c = 6;
+ return s;
+}
+
+struct test_struct_7 ffi_test_30(void)
+{
+ struct test_struct_7 s;
+ s.x = 1;
+ s.y = 2;
+ s.z = 3;
+ s.a = 4;
+ s.b = 5;
+ s.c = 6;
+ s.d = 7;
+ return s;
+}
+
+int ffi_test_31(int x0, int x1, int x2, int x3, int x4, int x5, int x6, int x7, int x8, int x9, int x10, int x11, int x12, int x13, int x14, int x15, int x16, int x17, int x18, int x19, int x20, int x21, int x22, int x23, int x24, int x25, int x26, int x27, int x28, int x29, int x30, int x31, int x32, int x33, int x34, int x35, int x36, int x37, int x38, int x39, int x40, int x41)
+{
+ return x0 + x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 + x11 + x12 + x13 + x14 + x15 + x16 + x17 + x18 + x19 + x20 + x21 + x22 + x23 + x24 + x25 + x26 + x27 + x28 + x29 + x30 + x31 + x32 + x33 + x34 + x35 + x36 + x37 + x38 + x39 + x40 + x41;
+}
+
+float ffi_test_31_point_5(float x0, float x1, float x2, float x3, float x4, float x5, float x6, float x7, float x8, float x9, float x10, float x11, float x12, float x13, float x14, float x15, float x16, float x17, float x18, float x19, float x20, float x21, float x22, float x23, float x24, float x25, float x26, float x27, float x28, float x29, float x30, float x31, float x32, float x33, float x34, float x35, float x36, float x37, float x38, float x39, float x40, float x41)
+{
+ return x0 + x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 + x11 + x12 + x13 + x14 + x15 + x16 + x17 + x18 + x19 + x20 + x21 + x22 + x23 + x24 + x25 + x26 + x27 + x28 + x29 + x30 + x31 + x32 + x33 + x34 + x35 + x36 + x37 + x38 + x39 + x40 + x41;
+}
+
+double ffi_test_32(struct test_struct_8 x, int y)
+{
+ return (x.x + x.y) * y;
+}
+
+double ffi_test_33(struct test_struct_9 x, int y)
+{
+ return (x.x + x.y) * y;
+}
+
+double ffi_test_34(struct test_struct_10 x, int y)
+{
+ return (x.x + x.y) * y;
+}
+
+double ffi_test_35(struct test_struct_11 x, int y)
+{
+ return (x.x + x.y) * y;
+}
+
+double ffi_test_36(struct test_struct_12 x)
+{
+ return x.x;
+}
+
+static int global_var;
+
+void ffi_test_36_point_5(void)
+{
+ global_var = 0;
+}
+
+int ffi_test_37(int (*f)(int, int, int))
+{
+ global_var = f(global_var,global_var * 2,global_var * 3);
+ return global_var;
+}
+
+unsigned long long ffi_test_38(unsigned long long x, unsigned long long y)
+{
+ return x * y;
+}
+
+int ffi_test_39(long a, long b, struct test_struct_13 s)
+{
+ assert(a == b);
+ return s.x1 + s.x2 + s.x3 + s.x4 + s.x5 + s.x6;
+}
+
+struct test_struct_14 ffi_test_40(double x1, double x2)
+{
+ struct test_struct_14 retval;
+ retval.x1 = x1;
+ retval.x2 = x2;
+ return retval;
+}
+
+struct test_struct_12 ffi_test_41(int a, double x)
+{
+ struct test_struct_12 retval;
+ retval.a = a;
+ retval.x = x;
+ return retval;
+}
+
+struct test_struct_15 ffi_test_42(float x, float y)
+{
+ struct test_struct_15 retval;
+ retval.x = x;
+ retval.y = y;
+ return retval;
+}
+
+struct test_struct_16 ffi_test_43(float x, int a)
+{
+ struct test_struct_16 retval;
+ retval.x = x;
+ retval.a = a;
+ return retval;
+}
+
+struct test_struct_14 ffi_test_44(void)
+{
+ struct test_struct_14 retval;
+ retval.x1 = 1.0;
+ retval.x2 = 2.0;
+ return retval;
+}
+
+_Complex float ffi_test_45(int x)
+{
+ return x;
+}
+
+_Complex double ffi_test_46(int x)
+{
+ return x;
+}
+
+_Complex float ffi_test_47(_Complex float x, _Complex double y)
+{
+ return x + 2 * y;
+}
--- /dev/null
+#if defined(FACTOR_X86)
+ #define F_STDCALL __attribute__((stdcall))
+#else
+ #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);
+DLLEXPORT int ffi_test_3(int x, int y, int z, int t);
+DLLEXPORT float ffi_test_4(void);
+DLLEXPORT double ffi_test_5(void);
+DLLEXPORT double ffi_test_6(float x, float y);
+DLLEXPORT double ffi_test_7(double x, double y);
+DLLEXPORT double ffi_test_8(double x, float y, double z, float t, int w);
+DLLEXPORT int ffi_test_9(int a, int b, int c, int d, int e, int f, int g);
+DLLEXPORT int ffi_test_10(int a, int b, double c, int d, float e, int f, int g, int h);
+struct foo { int x, y; };
+DLLEXPORT int ffi_test_11(int a, struct foo b, int c);
+struct rect { float x, y, w, h; };
+DLLEXPORT int ffi_test_12(int a, int b, struct rect c, int d, int e, int f);
+DLLEXPORT int ffi_test_13(int a, int b, int c, int d, int e, int f, int g, int h, int i, int j, int k);
+DLLEXPORT struct foo ffi_test_14(int x, int y);
+DLLEXPORT char *ffi_test_15(char *x, char *y);
+struct bar { long x, y, z; };
+DLLEXPORT struct bar ffi_test_16(long x, long y, long z);
+struct tiny { int x; };
+DLLEXPORT struct tiny ffi_test_17(int x);
+DLLEXPORT F_STDCALL int ffi_test_18(int x, int y, int z, int t);
+DLLEXPORT F_STDCALL struct bar ffi_test_19(long x, long y, long z);
+DLLEXPORT void ffi_test_20(double x1, double x2, double x3,
+ double y1, double y2, double y3,
+ double z1, double z2, double z3);
+DLLEXPORT long long ffi_test_21(long x, long y);
+DLLEXPORT long ffi_test_22(long x, long long y, long long z);
+DLLEXPORT float ffi_test_23(float x[3], float y[3]);
+struct test_struct_1 { char x; };
+DLLEXPORT struct test_struct_1 ffi_test_24(void);
+struct test_struct_2 { char x, y; };
+DLLEXPORT struct test_struct_2 ffi_test_25(void);
+struct test_struct_3 { char x, y, z; };
+DLLEXPORT struct test_struct_3 ffi_test_26(void);
+struct test_struct_4 { char x, y, z, a; };
+DLLEXPORT struct test_struct_4 ffi_test_27(void);
+struct test_struct_5 { char x, y, z, a, b; };
+DLLEXPORT struct test_struct_5 ffi_test_28(void);
+struct test_struct_6 { char x, y, z, a, b, c; };
+DLLEXPORT struct test_struct_6 ffi_test_29(void);
+struct test_struct_7 { char x, y, z, a, b, c, d; };
+DLLEXPORT struct test_struct_7 ffi_test_30(void);
+DLLEXPORT int ffi_test_31(int x0, int x1, int x2, int x3, int x4, int x5, int x6, int x7, int x8, int x9, int x10, int x11, int x12, int x13, int x14, int x15, int x16, int x17, int x18, int x19, int x20, int x21, int x22, int x23, int x24, int x25, int x26, int x27, int x28, int x29, int x30, int x31, int x32, int x33, int x34, int x35, int x36, int x37, int x38, int x39, int x40, int x41);
+DLLEXPORT float ffi_test_31_point_5(float x0, float x1, float x2, float x3, float x4, float x5, float x6, float x7, float x8, float x9, float x10, float x11, float x12, float x13, float x14, float x15, float x16, float x17, float x18, float x19, float x20, float x21, float x22, float x23, float x24, float x25, float x26, float x27, float x28, float x29, float x30, float x31, float x32, float x33, float x34, float x35, float x36, float x37, float x38, float x39, float x40, float x41);
+struct test_struct_8 { double x; double y; };
+DLLEXPORT double ffi_test_32(struct test_struct_8 x, int y);
+struct test_struct_9 { float x; float y; };
+DLLEXPORT double ffi_test_33(struct test_struct_9 x, int y);
+struct test_struct_10 { float x; int y; };
+DLLEXPORT double ffi_test_34(struct test_struct_10 x, int y);
+struct test_struct_11 { int x; int y; };
+DLLEXPORT double ffi_test_35(struct test_struct_11 x, int y);
+
+struct test_struct_12 { int a; double x; };
+
+DLLEXPORT double ffi_test_36(struct test_struct_12 x);
+
+DLLEXPORT void ffi_test_36_point_5(void);
+
+DLLEXPORT int ffi_test_37(int (*f)(int, int, int));
+
+DLLEXPORT unsigned long long ffi_test_38(unsigned long long x, unsigned long long y);
+
+struct test_struct_13 { float x1, x2, x3, x4, x5, x6; };
+
+DLLEXPORT int ffi_test_39(long a, long b, struct test_struct_13 s);
+
+struct test_struct_14 { double x1, x2; };
+
+DLLEXPORT struct test_struct_14 ffi_test_40(double x1, double x2);
+
+DLLEXPORT struct test_struct_12 ffi_test_41(int a, double x);
+
+struct test_struct_15 { float x, y; };
+
+DLLEXPORT struct test_struct_15 ffi_test_42(float x, float y);
+
+struct test_struct_16 { float x; int a; };
+
+DLLEXPORT struct test_struct_16 ffi_test_43(float x, int a);
+
+DLLEXPORT struct test_struct_14 ffi_test_44();
+
+DLLEXPORT _Complex float ffi_test_45(int x);
+
+DLLEXPORT _Complex double ffi_test_46(int x);
+
+DLLEXPORT _Complex float ffi_test_47(_Complex float x, _Complex double y);
--- /dev/null
+/* 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;
+}
--- /dev/null
+#include "master.hpp"
+
+/* Certain special objects in the image are known to the runtime */
+static 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;
+}
+
+CELL data_relocation_base;
+
+static 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((CELL)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;
+}
+
+CELL code_relocation_base;
+
+static 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)
+ {
+ size_t 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);
+}
+
+/* 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(F_CHAR,path);
+
+ /* Save the image */
+ if(save_image(path))
+ exit(0);
+ else
+ exit(1);
+}
+
+static void data_fixup(CELL *cell)
+{
+ if(immediate_p(*cell))
+ return;
+
+ F_ZONE *tenured = &data_heap->generations[TENURED];
+ *cell += (tenured->start - data_relocation_base);
+}
+
+static void code_fixup(CELL cell)
+{
+ CELL value = get(cell);
+ put(cell,value + (code_heap.segment->start - code_relocation_base));
+}
+
+static void fixup_word(F_WORD *word)
+{
+ if(word->code)
+ code_fixup((CELL)&word->code);
+ if(word->profiling)
+ code_fixup((CELL)&word->profiling);
+ code_fixup((CELL)&word->xt);
+}
+
+static void fixup_quotation(F_QUOTATION *quot)
+{
+ if(quot->compiledp == F)
+ quot->xt = (void *)lazy_jit_compile;
+ else
+ {
+ code_fixup((CELL)"->xt);
+ code_fixup((CELL)"->code);
+ }
+}
+
+static void fixup_alien(F_ALIEN *d)
+{
+ d->expired = T;
+}
+
+static void fixup_stack_frame(F_STACK_FRAME *frame)
+{
+ code_fixup((CELL)&frame->xt);
+ code_fixup((CELL)&FRAME_RETURN_ADDRESS(frame));
+}
+
+static void fixup_callstack_object(F_CALLSTACK *stack)
+{
+ iterate_callstack_object(stack,fixup_stack_frame);
+}
+
+/* Initialize an object in a newly-loaded image */
+static 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);
+ }
+}
+
+static 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);
+}
+
+/* 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));
+}
--- /dev/null
+#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);
+bool save_image(const F_CHAR *file);
+
+void primitive_save_image(void);
+void primitive_save_image_and_exit(void);
--- /dev/null
+#include "master.hpp"
+
+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)
+{
+ 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_array_fast(cache_entries);
+
+ bool seen_hi_tag = false, seen_tuple = false;
+
+ CELL i;
+ for(i = 0; i < array_capacity(array); i += 2)
+ {
+ CELL klass = array_nth(array,i);
+ F_FIXNUM type;
+
+ /* Is it a tuple layout? */
+ switch(type_of(klass))
+ {
+ case FIXNUM_TYPE:
+ type = untag_fixnum_fast(klass);
+ if(type >= HEADER_TYPE)
+ seen_hi_tag = true;
+ break;
+ case ARRAY_TYPE:
+ seen_tuple = true;
+ break;
+ default:
+ critical_error("Expected a fixnum or array",klass);
+ 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 klass)
+{
+ CELL code_template;
+ if(TAG(klass) == FIXNUM_TYPE && untag_fixnum_fast(klass) < HEADER_TYPE)
+ code_template = userenv[PIC_CHECK_TAG];
+ else
+ code_template = userenv[PIC_CHECK];
+
+ jit_emit_with(jit,code_template,klass);
+}
+
+/* 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_array_fast(cache_entries)); i += 2)
+ {
+ /* Class equal? */
+ CELL klass = array_nth(untag_array_fast(cache_entries),i);
+ jit_emit_check(&jit,klass);
+
+ /* Yes? Jump to method */
+ CELL method = array_nth(untag_array_fast(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 klass, CELL method)
+{
+ if(cache_entries == F)
+ return allot_array_2(klass,method);
+ else
+ {
+ F_ARRAY *cache_entries_array = untag_array_fast(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,klass);
+ 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 klass = object_class(object);
+ CELL method = lookup_method(object,methods);
+
+ cache_entries = add_inline_cache_entry(cache_entries,klass,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);
+}
--- /dev/null
+extern CELL max_pic_size;
+
+void init_inline_caching(int max_size);
+
+void primitive_reset_inline_cache_stats(void);
+void primitive_inline_cache_stats(void);
+
+extern "C" XT inline_cache_miss(CELL return_address);
--- /dev/null
+#include "master.hpp"
+
+/* 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(char,mode);
+
+ for(;;)
+ {
+ FILE *file = fopen(path,mode);
+ if(file == NULL)
+ io_error();
+ else
+ {
+ box_alien(file);
+ break;
+ }
+ }
+}
+
+void primitive_fgetc(void)
+{
+ FILE *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 = (FILE *)unbox_alien();
+ F_FIXNUM 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(F_BYTE_ARRAY,buf);
+ memcpy(new_buf + 1, buf + 1,c);
+ buf = new_buf;
+ }
+ dpush(tag_object(buf));
+ break;
+ }
+ }
+}
+
+void primitive_fputc(void)
+{
+ FILE *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 = (FILE *)unbox_alien();
+ F_BYTE_ARRAY *text = untag_byte_array(dpop());
+ CELL 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 = (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 = (FILE *)unbox_alien();
+ for(;;)
+ {
+ if(fflush(file) == EOF)
+ io_error();
+ else
+ break;
+ }
+}
+
+void primitive_fclose(void)
+{
+ FILE *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;
+}
--- /dev/null
+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);
--- /dev/null
+#include "master.hpp"
+
+/* 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_byte_array_fast(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 code_template, bool *rel_p)
+{
+ F_ARRAY *quadruple = untag_array_fast(code_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 code_template)
+{
+#ifdef FACTOR_DEBUG
+ type_check(ARRAY_TYPE,code_template);
+#endif
+
+ REGISTER_ROOT(code_template);
+
+ bool rel_p;
+ F_REL rel = rel_to_emit(jit,code_template,&rel_p);
+ if(rel_p) growable_byte_array_append(&jit->relocation,&rel,sizeof(F_REL));
+
+ F_BYTE_ARRAY *code = code_to_emit(code_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(code_template);
+}
+
--- /dev/null
+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 code_template)
+{
+ return untag_byte_array_fast(array_nth(untag_array_fast(code_template),0));
+}
+
+void jit_emit(F_JIT *jit, CELL code_template);
+
+/* Allocates memory */
+INLINE void jit_add_literal(F_JIT *jit, CELL literal)
+{
+#ifdef FACTOR_DEBUG
+ type_of(literal);
+#endif
+ growable_array_add(&jit->literals,literal);
+}
+
+/* Allocates memory */
+INLINE void jit_emit_with(F_JIT *jit, CELL code_template, CELL argument)
+{
+ REGISTER_ROOT(code_template);
+ jit_add_literal(jit,argument);
+ UNREGISTER_ROOT(code_template);
+ jit_emit(jit,code_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, CELL word)
+{
+ CELL code_template = untag_word_fast(word)->subprimitive;
+ REGISTER_ROOT(code_template);
+
+ if(array_nth(untag_array_fast(code_template),1) != F)
+ jit_add_literal(jit,T);
+
+ jit_emit(jit,code_template);
+ UNREGISTER_ROOT(code_template);
+}
+
+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;
+}
--- /dev/null
+#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);
+}
+
+typedef void *XT;
+
+struct F_OBJECT {
+ CELL header;
+};
+
+/* Assembly code makes assumptions about the layout of this struct */
+struct F_ARRAY : public F_OBJECT {
+ static const CELL type_number = ARRAY_TYPE;
+ /* tagged */
+ CELL capacity;
+};
+
+/* These are really just arrays, but certain elements have special
+significance */
+struct F_TUPLE_LAYOUT : public F_ARRAY {
+ /* tagged */
+ CELL klass;
+ /* tagged fixnum */
+ CELL size;
+ /* tagged fixnum */
+ CELL echelon;
+};
+
+struct F_BIGNUM : public F_OBJECT {
+ static const CELL type_number = BIGNUM_TYPE;
+ /* tagged */
+ CELL capacity;
+};
+
+struct F_BYTE_ARRAY : public F_OBJECT {
+ static const CELL type_number = BYTE_ARRAY_TYPE;
+ /* tagged */
+ CELL capacity;
+};
+
+/* Assembly code makes assumptions about the layout of this struct */
+struct F_STRING : public F_OBJECT {
+ static const CELL type_number = STRING_TYPE;
+ /* tagged num of chars */
+ CELL length;
+ /* tagged */
+ CELL aux;
+ /* tagged */
+ CELL hashcode;
+};
+
+/* The compiled code heap is structured into blocks. */
+typedef enum
+{
+ B_FREE,
+ B_ALLOCATED,
+ B_MARKED
+} F_BLOCK_STATUS;
+
+struct F_BLOCK
+{
+ unsigned char status; /* free or allocated? */
+ unsigned char type; /* this is WORD_TYPE or QUOTATION_TYPE */
+ unsigned 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 */
+ F_BLOCK *forwarding;
+};
+
+struct F_FREE_BLOCK
+{
+ F_BLOCK block;
+
+ /* Filled in on image load */
+ F_FREE_BLOCK *next_free;
+};
+
+struct F_CODE_BLOCK
+{
+ F_BLOCK block;
+ CELL literals; /* # bytes */
+ CELL relocation; /* tagged pointer to byte-array or f */
+};
+
+/* Assembly code makes assumptions about the layout of this struct */
+struct F_WORD : public F_OBJECT {
+ static const CELL type_number = WORD_TYPE;
+ /* 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;
+};
+
+/* Assembly code makes assumptions about the layout of this struct */
+struct F_WRAPPER : public F_OBJECT {
+ static const CELL type_number = WRAPPER_TYPE;
+ CELL object;
+};
+
+/* Assembly code makes assumptions about the layout of this struct */
+struct F_FLOAT {
+/* We use a union here to force the float value to be aligned on an
+8-byte boundary. */
+ static const CELL type_number = FLOAT_TYPE;
+ union {
+ CELL header;
+ long long padding;
+ };
+ double n;
+};
+
+/* Assembly code makes assumptions about the layout of this struct */
+struct F_QUOTATION : public F_OBJECT {
+ static const CELL type_number = QUOTATION_TYPE;
+ /* 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;
+};
+
+/* Assembly code makes assumptions about the layout of this struct */
+struct F_ALIEN : public F_OBJECT {
+ static const CELL type_number = ALIEN_TYPE;
+ /* tagged */
+ CELL alien;
+ /* tagged */
+ CELL expired;
+ /* untagged */
+ CELL displacement;
+};
+
+struct F_DLL : public F_OBJECT {
+ static const CELL type_number = DLL_TYPE;
+ /* tagged byte array holding a C string */
+ CELL path;
+ /* OS-specific handle */
+ void *dll;
+};
+
+struct F_CALLSTACK : public F_OBJECT {
+ static const CELL type_number = CALLSTACK_TYPE;
+ /* tagged */
+ CELL length;
+};
+
+struct F_STACK_FRAME
+{
+ XT xt;
+ /* Frame size in bytes */
+ CELL size;
+};
+
+struct F_TUPLE : public F_OBJECT {
+ static const CELL type_number = TUPLE_TYPE;
+ /* tagged layout */
+ CELL layout;
+};
--- /dev/null
+#include "master.hpp"
+
+F_SEGMENT *gc_locals_region;
+CELL gc_locals;
+
+F_SEGMENT *extra_roots_region;
+CELL extra_roots;
--- /dev/null
+/* If a runtime function needs to call another function which potentially
+allocates memory, it must store any local variable references to Factor
+objects on the root stack */
+extern F_SEGMENT *gc_locals_region;
+extern CELL gc_locals;
+
+DEFPUSHPOP(gc_local_,gc_locals)
+
+template <typename T>
+class gc_root : public tagged<T>
+{
+ void push() { gc_local_push((CELL)this); }
+public:
+ explicit gc_root(CELL value_) : tagged<T>(value_) { push(); }
+ explicit gc_root(T *value_) : tagged<T>(value_) { push(); }
+ gc_root(const gc_root<T>& copy) : tagged<T>(copy.untag()) {}
+ ~gc_root() { CELL old = gc_local_pop(); assert(old == (CELL)this); }
+};
+
+#define REGISTER_ROOT(obj) \
+ { \
+ if(!immediate_p(obj)) \
+ check_data_pointer(obj); \
+ gc_local_push((CELL)&(obj)); \
+ }
+#define UNREGISTER_ROOT(obj) \
+ { \
+ if(gc_local_pop() != (CELL)&(obj)) \
+ critical_error("Mismatched REGISTER_ROOT/UNREGISTER_ROOT",0); \
+ }
+
+/* Extra roots: stores pointers to objects in the heap. Requires extra work
+(you have to unregister before accessing the object) but more flexible. */
+extern F_SEGMENT *extra_roots_region;
+extern CELL extra_roots;
+
+DEFPUSHPOP(root_,extra_roots)
+
+#define REGISTER_UNTAGGED(obj) root_push(obj ? RETAG(obj,OBJECT_TYPE) : 0)
+#define UNREGISTER_UNTAGGED(type,obj) obj = (type *)UNTAG(root_pop())
+
+/* We ignore strings which point outside the data heap, but we might be given
+a char* which points inside the data heap, in which case it is a root, for
+example if we call unbox_char_string() the result is placed in a byte array */
+INLINE bool root_push_alien(const void *ptr)
+{
+ if(in_data_heap_p((CELL)ptr))
+ {
+ F_BYTE_ARRAY *objptr = ((F_BYTE_ARRAY *)ptr) - 1;
+ if(objptr->header == tag_header(BYTE_ARRAY_TYPE))
+ {
+ root_push(tag_object(objptr));
+ return true;
+ }
+ }
+
+ return false;
+}
+
+#define REGISTER_C_STRING(obj) \
+ bool obj##_root = root_push_alien((const char *)obj)
+#define UNREGISTER_C_STRING(type,obj) \
+ if(obj##_root) obj = (type *)alien_offset(root_pop())
+
+#define REGISTER_BIGNUM(obj) if(obj) root_push(tag_bignum(obj))
+#define UNREGISTER_BIGNUM(obj) if(obj) obj = (untag_bignum_fast(root_pop()))
--- /dev/null
+/* Fault handler information. MacOSX version.
+Copyright (C) 1993-1999, 2002-2003 Bruno Haible <clisp.org at bruno>
+Copyright (C) 2003 Paolo Bonzini <gnu.org at bonzini>
+
+Used under BSD license with permission from Paolo Bonzini and Bruno Haible,
+2005-03-10:
+
+http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org
+
+Modified for Factor by Slava Pestov */
+
+#include "master.hpp"
+
+/* The exception port on which our thread listens. */
+mach_port_t our_exception_port;
+
+/* The following sources were used as a *reference* for this exception handling
+code:
+1. Apple's mach/xnu documentation
+2. Timothy J. Wood's "Mach Exception Handlers 101" post to the
+omnigroup's macosx-dev list.
+http://www.wodeveloper.com/omniLists/macosx-dev/2000/June/msg00137.html */
+
+/* Modify a suspended thread's thread_state so that when the thread resumes
+executing, the call frame of the current C primitive (if any) is rewound, and
+the appropriate Factor error is thrown from the top-most Factor frame. */
+static void call_fault_handler(exception_type_t exception,
+ MACH_EXC_STATE_TYPE *exc_state,
+ MACH_THREAD_STATE_TYPE *thread_state)
+{
+ /* There is a race condition here, but in practice an exception
+ delivered during stack frame setup/teardown or while transitioning
+ from Factor to C is a sign of things seriously gone wrong, not just
+ a divide by zero or stack underflow in the listener */
+
+ /* Are we in compiled Factor code? Then use the current stack pointer */
+ if(in_code_heap_p(MACH_PROGRAM_COUNTER(thread_state)))
+ signal_callstack_top = (F_STACK_FRAME *)MACH_STACK_POINTER(thread_state);
+ /* Are we in C? Then use the saved callstack top */
+ else
+ signal_callstack_top = NULL;
+
+ MACH_STACK_POINTER(thread_state) = fix_stack_pointer(MACH_STACK_POINTER(thread_state));
+
+ /* Now we point the program counter at the right handler function. */
+ if(exception == EXC_BAD_ACCESS)
+ {
+ signal_fault_addr = MACH_EXC_STATE_FAULT(exc_state);
+ MACH_PROGRAM_COUNTER(thread_state) = (CELL)memory_signal_handler_impl;
+ }
+ else
+ {
+ if(exception == EXC_ARITHMETIC)
+ signal_number = SIGFPE;
+ else
+ signal_number = SIGABRT;
+ MACH_PROGRAM_COUNTER(thread_state) = (CELL)misc_signal_handler_impl;
+ }
+}
+
+/* Handle an exception by invoking the user's fault handler and/or forwarding
+the duty to the previously installed handlers. */
+kern_return_t
+catch_exception_raise (mach_port_t exception_port,
+ mach_port_t thread,
+ mach_port_t task,
+ exception_type_t exception,
+ exception_data_t code,
+ mach_msg_type_number_t code_count)
+{
+ MACH_EXC_STATE_TYPE exc_state;
+ MACH_THREAD_STATE_TYPE thread_state;
+ mach_msg_type_number_t state_count;
+
+ /* Get fault information and the faulting thread's register contents..
+
+ See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/thread_get_state.html. */
+ state_count = MACH_EXC_STATE_COUNT;
+ if (thread_get_state (thread, MACH_EXC_STATE_FLAVOR,
+ (natural_t *)&exc_state, &state_count)
+ != KERN_SUCCESS)
+ {
+ /* The thread is supposed to be suspended while the exception
+ handler is called. This shouldn't fail. */
+ return KERN_FAILURE;
+ }
+
+ state_count = MACH_THREAD_STATE_COUNT;
+ if (thread_get_state (thread, MACH_THREAD_STATE_FLAVOR,
+ (natural_t *)&thread_state, &state_count)
+ != KERN_SUCCESS)
+ {
+ /* The thread is supposed to be suspended while the exception
+ handler is called. This shouldn't fail. */
+ return KERN_FAILURE;
+ }
+
+ /* Modify registers so to have the thread resume executing the
+ fault handler */
+ call_fault_handler(exception,&exc_state,&thread_state);
+
+ /* Set the faulting thread's register contents..
+
+ See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/thread_set_state.html. */
+ if (thread_set_state (thread, MACH_THREAD_STATE_FLAVOR,
+ (natural_t *)&thread_state, state_count)
+ != KERN_SUCCESS)
+ {
+ return KERN_FAILURE;
+ }
+
+ return KERN_SUCCESS;
+}
+
+
+/* The main function of the thread listening for exceptions. */
+static void *
+mach_exception_thread (void *arg)
+{
+ for (;;)
+ {
+ /* These two structures contain some private kernel data. We don't need
+ to access any of it so we don't bother defining a proper struct. The
+ correct definitions are in the xnu source code. */
+ /* Buffer for a message to be received. */
+ struct
+ {
+ mach_msg_header_t head;
+ mach_msg_body_t msgh_body;
+ char data[1024];
+ }
+ msg;
+ /* Buffer for a reply message. */
+ struct
+ {
+ mach_msg_header_t head;
+ char data[1024];
+ }
+ reply;
+
+ mach_msg_return_t retval;
+
+ /* Wait for a message on the exception port. */
+ retval = mach_msg (&msg.head, MACH_RCV_MSG | MACH_RCV_LARGE, 0,
+ sizeof (msg), our_exception_port,
+ MACH_MSG_TIMEOUT_NONE, MACH_PORT_NULL);
+ if (retval != MACH_MSG_SUCCESS)
+ {
+ abort ();
+ }
+
+ /* Handle the message: Call exc_server, which will call
+ catch_exception_raise and produce a reply message. */
+ exc_server (&msg.head, &reply.head);
+
+ /* Send the reply. */
+ if (mach_msg (&reply.head, MACH_SEND_MSG, reply.head.msgh_size,
+ 0, MACH_PORT_NULL, MACH_MSG_TIMEOUT_NONE, MACH_PORT_NULL)
+ != MACH_MSG_SUCCESS)
+ {
+ abort ();
+ }
+ }
+}
+
+
+/* Initialize the Mach exception handler thread. */
+void mach_initialize (void)
+{
+ mach_port_t self;
+ exception_mask_t mask;
+
+ self = mach_task_self ();
+
+ /* Allocate a port on which the thread shall listen for exceptions. */
+ if (mach_port_allocate (self, MACH_PORT_RIGHT_RECEIVE, &our_exception_port)
+ != KERN_SUCCESS)
+ fatal_error("mach_port_allocate() failed",0);
+
+ /* See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/mach_port_insert_right.html. */
+ if (mach_port_insert_right (self, our_exception_port, our_exception_port,
+ MACH_MSG_TYPE_MAKE_SEND)
+ != KERN_SUCCESS)
+ fatal_error("mach_port_insert_right() failed",0);
+
+ /* The exceptions we want to catch. */
+ mask = EXC_MASK_BAD_ACCESS | EXC_MASK_ARITHMETIC;
+
+ /* Create the thread listening on the exception port. */
+ start_thread(mach_exception_thread);
+
+ /* Replace the exception port info for these exceptions with our own.
+ Note that we replace the exception port for the entire task, not only
+ for a particular thread. This has the effect that when our exception
+ port gets the message, the thread specific exception port has already
+ been asked, and we don't need to bother about it.
+ See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/task_set_exception_ports.html. */
+ if (task_set_exception_ports (self, mask, our_exception_port,
+ EXCEPTION_DEFAULT, MACHINE_THREAD_STATE)
+ != KERN_SUCCESS)
+ fatal_error("task_set_exception_ports() failed",0);
+}
--- /dev/null
+/* Fault handler information. MacOSX version.
+Copyright (C) 1993-1999, 2002-2003 Bruno Haible <clisp.org at bruno>
+Copyright (C) 2003 Paolo Bonzini <gnu.org at bonzini>
+
+Used under BSD license with permission from Paolo Bonzini and Bruno Haible,
+2005-03-10:
+
+http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org
+
+Modified for Factor by Slava Pestov */
+#include <stdio.h>
+#include <stdlib.h>
+#include <errno.h>
+#include <signal.h>
+
+#include <mach/mach.h>
+#include <mach/mach_error.h>
+#include <mach/thread_status.h>
+#include <mach/exception.h>
+#include <mach/task.h>
+#include <pthread.h>
+
+/* This is not defined in any header, although documented. */
+
+/* http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/exc_server.html says:
+ The exc_server function is the MIG generated server handling function
+ to handle messages from the kernel relating to the occurrence of an
+ exception in a thread. Such messages are delivered to the exception port
+ set via thread_set_exception_ports or task_set_exception_ports. When an
+ exception occurs in a thread, the thread sends an exception message to its
+ exception port, blocking in the kernel waiting for the receipt of a reply.
+ The exc_server function performs all necessary argument handling for this
+ kernel message and calls catch_exception_raise, catch_exception_raise_state
+ or catch_exception_raise_state_identity, which should handle the exception.
+ If the called routine returns KERN_SUCCESS, a reply message will be sent,
+ allowing the thread to continue from the point of the exception; otherwise,
+ no reply message is sent and the called routine must have dealt with the
+ exception thread directly. */
+extern "C" boolean_t exc_server (mach_msg_header_t *request_msg, mach_msg_header_t *reply_msg);
+
+
+/* http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/catch_exception_raise.html
+ These functions are defined in this file, and called by exc_server.
+ FIXME: What needs to be done when this code is put into a shared library? */
+kern_return_t
+catch_exception_raise (mach_port_t exception_port,
+ mach_port_t thread,
+ mach_port_t task,
+ exception_type_t exception,
+ exception_data_t code,
+ mach_msg_type_number_t code_count);
+kern_return_t
+catch_exception_raise_state (mach_port_t exception_port,
+ exception_type_t exception,
+ exception_data_t code,
+ mach_msg_type_number_t code_count,
+ thread_state_flavor_t *flavor,
+ thread_state_t in_state,
+ mach_msg_type_number_t in_state_count,
+ thread_state_t out_state,
+ mach_msg_type_number_t *out_state_count);
+kern_return_t
+catch_exception_raise_state_identity (mach_port_t exception_port,
+ mach_port_t thread,
+ mach_port_t task,
+ exception_type_t exception,
+ exception_data_t code,
+ mach_msg_type_number_t codeCnt,
+ thread_state_flavor_t *flavor,
+ thread_state_t in_state,
+ mach_msg_type_number_t in_state_count,
+ thread_state_t out_state,
+ mach_msg_type_number_t *out_state_count);
+
+void mach_initialize (void);
--- /dev/null
+#include "master.hpp"
+
+int main(int argc, char **argv)
+{
+ start_standalone_factor(argc,argv);
+ return 0;
+}
--- /dev/null
+#include "master.hpp"
+
+/*
+ Windows CE argument parsing ported to work on
+ int main(int argc, wchar_t **argv).
+
+ This would not be necessary if Windows CE had CommandLineToArgvW.
+
+ Based on MinGW's public domain char** version.
+
+*/
+
+int __argc;
+wchar_t **__argv;
+
+static int
+parse_tokens(wchar_t* string, wchar_t*** tokens, int length)
+{
+ /* Extract whitespace- and quotes- delimited tokens from the given string
+ and put them into the tokens array. Returns number of tokens
+ extracted. Length specifies the current size of tokens[].
+ THIS METHOD MODIFIES string. */
+
+ const wchar_t* whitespace = L" \t\r\n";
+ wchar_t* tokenEnd = 0;
+ const wchar_t* quoteCharacters = L"\"\'";
+ wchar_t *end = string + wcslen(string);
+
+ if (string == NULL)
+ return length;
+
+ while (1)
+ {
+ const wchar_t* q;
+ /* Skip over initial whitespace. */
+ string += wcsspn(string, whitespace);
+ if (*string == '\0')
+ break;
+
+ for (q = quoteCharacters; *q; ++q)
+ {
+ if (*string == *q)
+ break;
+ }
+ if (*q)
+ {
+ /* Token is quoted. */
+ wchar_t quote = *string++;
+ tokenEnd = wcschr(string, quote);
+ /* If there is no endquote, the token is the rest of the string. */
+ if (!tokenEnd)
+ tokenEnd = end;
+ }
+ else
+ {
+ tokenEnd = string + wcscspn(string, whitespace);
+ }
+
+ *tokenEnd = '\0';
+
+ {
+ wchar_t** new_tokens;
+ int newlen = length + 1;
+ new_tokens = realloc (*tokens, sizeof (wchar_t**) * newlen);
+ if (!new_tokens)
+ {
+ /* Out of memory. */
+ return -1;
+ }
+
+ *tokens = new_tokens;
+ (*tokens)[length] = string;
+ length = newlen;
+ }
+ if (tokenEnd == end)
+ break;
+ string = tokenEnd + 1;
+ }
+ return length;
+}
+
+static void
+parse_args(int *argc, wchar_t ***argv, wchar_t *cmdlinePtrW)
+{
+ wchar_t cmdnameBufW[MAX_UNICODE_PATH];
+ int cmdlineLen = 0;
+ int modlen;
+
+ /* argv[0] is the path of invoked program - get this from CE. */
+ cmdnameBufW[0] = 0;
+ modlen = GetModuleFileNameW(NULL, cmdnameBufW, sizeof (cmdnameBufW)/sizeof (cmdnameBufW[0]));
+
+ if (!cmdlinePtrW)
+ cmdlineLen = 0;
+ else
+ cmdlineLen = wcslen(cmdlinePtrW);
+
+ /* gets realloc()'d later */
+ *argv = malloc (sizeof (wchar_t**) * 1);
+ if (!*argv)
+ ExitProcess(-1);
+
+ (*argv)[0] = wcsdup(cmdnameBufW);
+ if(!(*argv[0]))
+ ExitProcess(-1);
+ /* Add one to account for argv[0] */
+ (*argc)++;
+
+ if (cmdlineLen > 0)
+ {
+ wchar_t* argv1 = (*argv)[0] + wcslen((*argv)[0]) + 1;
+ argv1 = wcsdup(cmdlinePtrW);
+ if(!argv1)
+ ExitProcess(-1);
+ *argc = parse_tokens(argv1, argv, 1);
+ if (*argc < 0)
+ ExitProcess(-1);
+ }
+ (*argv)[*argc] = 0;
+ return;
+}
+
+int WINAPI
+WinMain(
+ HINSTANCE hInstance,
+ HINSTANCE hPrevInstance,
+ LPWSTR lpCmdLine,
+ int nCmdShow)
+{
+ parse_args(&__argc, &__argv, lpCmdLine);
+ start_standalone_factor(__argc,(LPWSTR*)__argv);
+ // memory leak from malloc, wcsdup
+ return 0;
+}
--- /dev/null
+#include <windows.h>
+#include <stdio.h>
+#include <shellapi.h>
+#include "master.hpp"
+
+int WINAPI WinMain(
+ HINSTANCE hInstance,
+ HINSTANCE hPrevInstance,
+ LPSTR lpCmdLine,
+ int nCmdShow)
+{
+ LPWSTR *szArglist;
+ int nArgs;
+
+ szArglist = CommandLineToArgvW(GetCommandLineW(), &nArgs);
+ if(NULL == szArglist)
+ {
+ puts("CommandLineToArgvW failed");
+ return 1;
+ }
+
+ start_standalone_factor(nArgs,szArglist);
+
+ LocalFree(szArglist);
+
+ return 0;
+}
--- /dev/null
+#ifndef __FACTOR_MASTER_H__
+#define __FACTOR_MASTER_H__
+
+#ifndef WINCE
+#include <errno.h>
+#endif
+
+#ifdef FACTOR_DEBUG
+#include <assert.h>
+#endif
+
+#include <fcntl.h>
+#include <limits.h>
+#include <math.h>
+#include <stdbool.h>
+#include <setjmp.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <time.h>
+#include <sys/param.h>
+
+#include "layouts.hpp"
+#include "tagged.hpp"
+#include "platform.hpp"
+#include "primitives.hpp"
+#include "run.hpp"
+#include "profiler.hpp"
+#include "errors.hpp"
+#include "bignumint.hpp"
+#include "bignum.hpp"
+#include "write_barrier.hpp"
+#include "generic_arrays.hpp"
+#include "data_heap.hpp"
+#include "data_gc.hpp"
+#include "local_roots.hpp"
+#include "debug.hpp"
+#include "arrays.hpp"
+#include "strings.hpp"
+#include "booleans.hpp"
+#include "byte_arrays.hpp"
+#include "tuples.hpp"
+#include "words.hpp"
+#include "math.hpp"
+#include "float_bits.hpp"
+#include "io.hpp"
+#include "code_gc.hpp"
+#include "code_block.hpp"
+#include "code_heap.hpp"
+#include "image.hpp"
+#include "callstack.hpp"
+#include "alien.hpp"
+#include "quotations.hpp"
+#include "jit.hpp"
+#include "dispatch.hpp"
+#include "inline_cache.hpp"
+#include "factor.hpp"
+#include "utilities.hpp"
+
+#endif /* __FACTOR_MASTER_H__ */
--- /dev/null
+#include "master.hpp"
+
+CELL bignum_zero;
+CELL bignum_pos_one;
+CELL bignum_neg_one;
+
+/* Fixnums */
+F_FIXNUM to_fixnum(CELL tagged)
+{
+ switch(TAG(tagged))
+ {
+ case FIXNUM_TYPE:
+ return untag_fixnum_fast(tagged);
+ case BIGNUM_TYPE:
+ return bignum_to_fixnum(untag_bignum_fast(tagged));
+ default:
+ type_error(FIXNUM_TYPE,tagged);
+ return -1; /* can't happen */
+ }
+}
+
+CELL to_cell(CELL tagged)
+{
+ return (CELL)to_fixnum(tagged);
+}
+
+void primitive_bignum_to_fixnum(void)
+{
+ drepl(tag_fixnum(bignum_to_fixnum(untag_bignum_fast(dpeek()))));
+}
+
+void primitive_float_to_fixnum(void)
+{
+ drepl(tag_fixnum(float_to_fixnum(dpeek())));
+}
+
+/* The fixnum+, fixnum- and fixnum* primitives are defined in cpu_*.S. On
+overflow, they call these functions. */
+F_FASTCALL void overflow_fixnum_add(F_FIXNUM x, F_FIXNUM y)
+{
+ drepl(tag_bignum(fixnum_to_bignum(
+ untag_fixnum_fast(x) + untag_fixnum_fast(y))));
+}
+
+F_FASTCALL void overflow_fixnum_subtract(F_FIXNUM x, F_FIXNUM y)
+{
+ drepl(tag_bignum(fixnum_to_bignum(
+ untag_fixnum_fast(x) - untag_fixnum_fast(y))));
+}
+
+F_FASTCALL void overflow_fixnum_multiply(F_FIXNUM x, F_FIXNUM y)
+{
+ F_ARRAY *bx = fixnum_to_bignum(x);
+ REGISTER_BIGNUM(bx);
+ F_ARRAY *by = fixnum_to_bignum(y);
+ UNREGISTER_BIGNUM(bx);
+ drepl(tag_bignum(bignum_multiply(bx,by)));
+}
+
+/* Division can only overflow when we are dividing the most negative fixnum
+by -1. */
+void primitive_fixnum_divint(void)
+{
+ F_FIXNUM y = untag_fixnum_fast(dpop()); \
+ F_FIXNUM x = untag_fixnum_fast(dpeek());
+ F_FIXNUM result = x / y;
+ if(result == -FIXNUM_MIN)
+ drepl(allot_integer(-FIXNUM_MIN));
+ else
+ drepl(tag_fixnum(result));
+}
+
+void primitive_fixnum_divmod(void)
+{
+ CELL y = get(ds);
+ CELL x = get(ds - CELLS);
+ if(y == tag_fixnum(-1) && x == tag_fixnum(FIXNUM_MIN))
+ {
+ put(ds - CELLS,allot_integer(-FIXNUM_MIN));
+ put(ds,tag_fixnum(0));
+ }
+ else
+ {
+ put(ds - CELLS,tag_fixnum(untag_fixnum_fast(x) / untag_fixnum_fast(y)));
+ put(ds,x % y);
+ }
+}
+
+/*
+ * If we're shifting right by n bits, we won't overflow as long as none of the
+ * high WORD_SIZE-TAG_BITS-n bits are set.
+ */
+#define SIGN_MASK(x) ((x) >> (WORD_SIZE - 1))
+#define BRANCHLESS_MAX(x,y) ((x) - (((x) - (y)) & SIGN_MASK((x) - (y))))
+#define BRANCHLESS_ABS(x) ((x ^ SIGN_MASK(x)) - SIGN_MASK(x))
+
+void primitive_fixnum_shift(void)
+{
+ F_FIXNUM y = untag_fixnum_fast(dpop()); \
+ F_FIXNUM x = untag_fixnum_fast(dpeek());
+
+ if(x == 0)
+ return;
+ else if(y < 0)
+ {
+ y = BRANCHLESS_MAX(y,-WORD_SIZE + 1);
+ drepl(tag_fixnum(x >> -y));
+ return;
+ }
+ else if(y < WORD_SIZE - TAG_BITS)
+ {
+ F_FIXNUM mask = -((F_FIXNUM)1 << (WORD_SIZE - 1 - TAG_BITS - y));
+ if(!(BRANCHLESS_ABS(x) & mask))
+ {
+ drepl(tag_fixnum(x << y));
+ return;
+ }
+ }
+
+ drepl(tag_bignum(bignum_arithmetic_shift(
+ fixnum_to_bignum(x),y)));
+}
+
+/* Bignums */
+void primitive_fixnum_to_bignum(void)
+{
+ drepl(tag_bignum(fixnum_to_bignum(untag_fixnum_fast(dpeek()))));
+}
+
+void primitive_float_to_bignum(void)
+{
+ drepl(tag_bignum(float_to_bignum(dpeek())));
+}
+
+#define POP_BIGNUMS(x,y) \
+ bignum_type y = untag_bignum_fast(dpop()); \
+ bignum_type x = untag_bignum_fast(dpop());
+
+void primitive_bignum_eq(void)
+{
+ POP_BIGNUMS(x,y);
+ box_boolean(bignum_equal_p(x,y));
+}
+
+void primitive_bignum_add(void)
+{
+ POP_BIGNUMS(x,y);
+ dpush(tag_bignum(bignum_add(x,y)));
+}
+
+void primitive_bignum_subtract(void)
+{
+ POP_BIGNUMS(x,y);
+ dpush(tag_bignum(bignum_subtract(x,y)));
+}
+
+void primitive_bignum_multiply(void)
+{
+ POP_BIGNUMS(x,y);
+ dpush(tag_bignum(bignum_multiply(x,y)));
+}
+
+void primitive_bignum_divint(void)
+{
+ POP_BIGNUMS(x,y);
+ dpush(tag_bignum(bignum_quotient(x,y)));
+}
+
+void primitive_bignum_divmod(void)
+{
+ F_ARRAY *q, *r;
+ POP_BIGNUMS(x,y);
+ bignum_divide(x,y,&q,&r);
+ dpush(tag_bignum(q));
+ dpush(tag_bignum(r));
+}
+
+void primitive_bignum_mod(void)
+{
+ POP_BIGNUMS(x,y);
+ dpush(tag_bignum(bignum_remainder(x,y)));
+}
+
+void primitive_bignum_and(void)
+{
+ POP_BIGNUMS(x,y);
+ dpush(tag_bignum(bignum_bitwise_and(x,y)));
+}
+
+void primitive_bignum_or(void)
+{
+ POP_BIGNUMS(x,y);
+ dpush(tag_bignum(bignum_bitwise_ior(x,y)));
+}
+
+void primitive_bignum_xor(void)
+{
+ POP_BIGNUMS(x,y);
+ dpush(tag_bignum(bignum_bitwise_xor(x,y)));
+}
+
+void primitive_bignum_shift(void)
+{
+ F_FIXNUM y = untag_fixnum_fast(dpop());
+ F_ARRAY* x = untag_bignum_fast(dpop());
+ dpush(tag_bignum(bignum_arithmetic_shift(x,y)));
+}
+
+void primitive_bignum_less(void)
+{
+ POP_BIGNUMS(x,y);
+ box_boolean(bignum_compare(x,y) == bignum_comparison_less);
+}
+
+void primitive_bignum_lesseq(void)
+{
+ POP_BIGNUMS(x,y);
+ box_boolean(bignum_compare(x,y) != bignum_comparison_greater);
+}
+
+void primitive_bignum_greater(void)
+{
+ POP_BIGNUMS(x,y);
+ box_boolean(bignum_compare(x,y) == bignum_comparison_greater);
+}
+
+void primitive_bignum_greatereq(void)
+{
+ POP_BIGNUMS(x,y);
+ box_boolean(bignum_compare(x,y) != bignum_comparison_less);
+}
+
+void primitive_bignum_not(void)
+{
+ drepl(tag_bignum(bignum_bitwise_not(untag_bignum_fast(dpeek()))));
+}
+
+void primitive_bignum_bitp(void)
+{
+ F_FIXNUM bit = to_fixnum(dpop());
+ F_ARRAY *x = untag_bignum_fast(dpop());
+ box_boolean(bignum_logbitp(bit,x));
+}
+
+void primitive_bignum_log2(void)
+{
+ drepl(tag_bignum(bignum_integer_length(untag_bignum_fast(dpeek()))));
+}
+
+unsigned int bignum_producer(unsigned int digit)
+{
+ unsigned char *ptr = (unsigned char *)alien_offset(dpeek());
+ return *(ptr + digit);
+}
+
+void primitive_byte_array_to_bignum(void)
+{
+ type_check(BYTE_ARRAY_TYPE,dpeek());
+ CELL n_digits = array_capacity(untag_bignum_fast(dpeek()));
+ bignum_type bignum = digit_stream_to_bignum(
+ n_digits,bignum_producer,0x100,0);
+ drepl(tag_bignum(bignum));
+}
+
+void box_signed_1(s8 n)
+{
+ dpush(tag_fixnum(n));
+}
+
+void box_unsigned_1(u8 n)
+{
+ dpush(tag_fixnum(n));
+}
+
+void box_signed_2(s16 n)
+{
+ dpush(tag_fixnum(n));
+}
+
+void box_unsigned_2(u16 n)
+{
+ dpush(tag_fixnum(n));
+}
+
+void box_signed_4(s32 n)
+{
+ dpush(allot_integer(n));
+}
+
+void box_unsigned_4(u32 n)
+{
+ dpush(allot_cell(n));
+}
+
+void box_signed_cell(F_FIXNUM integer)
+{
+ dpush(allot_integer(integer));
+}
+
+void box_unsigned_cell(CELL cell)
+{
+ dpush(allot_cell(cell));
+}
+
+void box_signed_8(s64 n)
+{
+ if(n < FIXNUM_MIN || n > FIXNUM_MAX)
+ dpush(tag_bignum(long_long_to_bignum(n)));
+ else
+ dpush(tag_fixnum(n));
+}
+
+s64 to_signed_8(CELL obj)
+{
+ switch(type_of(obj))
+ {
+ case FIXNUM_TYPE:
+ return untag_fixnum_fast(obj);
+ case BIGNUM_TYPE:
+ return bignum_to_long_long(untag_bignum_fast(obj));
+ default:
+ type_error(BIGNUM_TYPE,obj);
+ return -1;
+ }
+}
+
+void box_unsigned_8(u64 n)
+{
+ if(n > FIXNUM_MAX)
+ dpush(tag_bignum(ulong_long_to_bignum(n)));
+ else
+ dpush(tag_fixnum(n));
+}
+
+u64 to_unsigned_8(CELL obj)
+{
+ switch(type_of(obj))
+ {
+ case FIXNUM_TYPE:
+ return untag_fixnum_fast(obj);
+ case BIGNUM_TYPE:
+ return bignum_to_ulong_long(untag_bignum_fast(obj));
+ default:
+ type_error(BIGNUM_TYPE,obj);
+ return -1;
+ }
+}
+
+CELL unbox_array_size(void)
+{
+ switch(type_of(dpeek()))
+ {
+ case FIXNUM_TYPE:
+ {
+ F_FIXNUM n = untag_fixnum_fast(dpeek());
+ if(n >= 0 && n < (F_FIXNUM)ARRAY_SIZE_MAX)
+ {
+ dpop();
+ return n;
+ }
+ break;
+ }
+ case BIGNUM_TYPE:
+ {
+ bignum_type zero = untag_bignum_fast(bignum_zero);
+ bignum_type max = cell_to_bignum(ARRAY_SIZE_MAX);
+ bignum_type n = untag_bignum_fast(dpeek());
+ if(bignum_compare(n,zero) != bignum_comparison_less
+ && bignum_compare(n,max) == bignum_comparison_less)
+ {
+ dpop();
+ return bignum_to_cell(n);
+ }
+ break;
+ }
+ }
+
+ general_error(ERROR_ARRAY_SIZE,dpop(),tag_fixnum(ARRAY_SIZE_MAX),NULL);
+ return 0; /* can't happen */
+}
+
+/* Floats */
+void primitive_fixnum_to_float(void)
+{
+ drepl(allot_float(fixnum_to_float(dpeek())));
+}
+
+void primitive_bignum_to_float(void)
+{
+ drepl(allot_float(bignum_to_float(dpeek())));
+}
+
+void primitive_str_to_float(void)
+{
+ char *c_str, *end;
+ double f;
+ F_STRING *str = untag_string(dpeek());
+ CELL capacity = string_capacity(str);
+
+ c_str = to_char_string(str,false);
+ end = c_str;
+ f = strtod(c_str,&end);
+ if(end != c_str + capacity)
+ drepl(F);
+ else
+ drepl(allot_float(f));
+}
+
+void primitive_float_to_str(void)
+{
+ char tmp[33];
+ snprintf(tmp,32,"%.16g",untag_float(dpop()));
+ tmp[32] = '\0';
+ box_char_string(tmp);
+}
+
+#define POP_FLOATS(x,y) \
+ double y = untag_float_fast(dpop()); \
+ double x = untag_float_fast(dpop());
+
+void primitive_float_eq(void)
+{
+ POP_FLOATS(x,y);
+ box_boolean(x == y);
+}
+
+void primitive_float_add(void)
+{
+ POP_FLOATS(x,y);
+ box_double(x + y);
+}
+
+void primitive_float_subtract(void)
+{
+ POP_FLOATS(x,y);
+ box_double(x - y);
+}
+
+void primitive_float_multiply(void)
+{
+ POP_FLOATS(x,y);
+ box_double(x * y);
+}
+
+void primitive_float_divfloat(void)
+{
+ POP_FLOATS(x,y);
+ box_double(x / y);
+}
+
+void primitive_float_mod(void)
+{
+ POP_FLOATS(x,y);
+ box_double(fmod(x,y));
+}
+
+void primitive_float_less(void)
+{
+ POP_FLOATS(x,y);
+ box_boolean(x < y);
+}
+
+void primitive_float_lesseq(void)
+{
+ POP_FLOATS(x,y);
+ box_boolean(x <= y);
+}
+
+void primitive_float_greater(void)
+{
+ POP_FLOATS(x,y);
+ box_boolean(x > y);
+}
+
+void primitive_float_greatereq(void)
+{
+ POP_FLOATS(x,y);
+ box_boolean(x >= y);
+}
+
+void primitive_float_bits(void)
+{
+ box_unsigned_4(float_bits(untag_float(dpop())));
+}
+
+void primitive_bits_float(void)
+{
+ box_float(bits_float(to_cell(dpop())));
+}
+
+void primitive_double_bits(void)
+{
+ box_unsigned_8(double_bits(untag_float(dpop())));
+}
+
+void primitive_bits_double(void)
+{
+ box_double(bits_double(to_unsigned_8(dpop())));
+}
+
+float to_float(CELL value)
+{
+ return untag_float(value);
+}
+
+double to_double(CELL value)
+{
+ return untag_float(value);
+}
+
+void box_float(float flo)
+{
+ dpush(allot_float(flo));
+}
+
+void box_double(double flo)
+{
+ dpush(allot_float(flo));
+}
--- /dev/null
+#define CELL_MAX (CELL)(-1)
+#define FIXNUM_MAX (((F_FIXNUM)1 << (WORD_SIZE - TAG_BITS - 1)) - 1)
+#define FIXNUM_MIN (-((F_FIXNUM)1 << (WORD_SIZE - TAG_BITS - 1)))
+#define ARRAY_SIZE_MAX ((CELL)1 << (WORD_SIZE - TAG_BITS - 2))
+
+DLLEXPORT F_FIXNUM to_fixnum(CELL tagged);
+DLLEXPORT CELL to_cell(CELL tagged);
+
+void primitive_bignum_to_fixnum(void);
+void primitive_float_to_fixnum(void);
+
+F_FASTCALL void overflow_fixnum_add(F_FIXNUM x, F_FIXNUM y);
+F_FASTCALL void overflow_fixnum_subtract(F_FIXNUM x, F_FIXNUM y);
+F_FASTCALL void overflow_fixnum_multiply(F_FIXNUM x, F_FIXNUM y);
+
+void primitive_fixnum_divint(void);
+void primitive_fixnum_divmod(void);
+void primitive_fixnum_shift(void);
+
+extern CELL bignum_zero;
+extern CELL bignum_pos_one;
+extern CELL bignum_neg_one;
+
+DEFINE_UNTAG(F_ARRAY,BIGNUM_TYPE,bignum);
+
+INLINE CELL tag_bignum(F_ARRAY* bignum)
+{
+ return RETAG(bignum,BIGNUM_TYPE);
+}
+
+void primitive_fixnum_to_bignum(void);
+void primitive_float_to_bignum(void);
+void primitive_bignum_eq(void);
+void primitive_bignum_add(void);
+void primitive_bignum_subtract(void);
+void primitive_bignum_multiply(void);
+void primitive_bignum_divint(void);
+void primitive_bignum_divmod(void);
+void primitive_bignum_mod(void);
+void primitive_bignum_and(void);
+void primitive_bignum_or(void);
+void primitive_bignum_xor(void);
+void primitive_bignum_shift(void);
+void primitive_bignum_less(void);
+void primitive_bignum_lesseq(void);
+void primitive_bignum_greater(void);
+void primitive_bignum_greatereq(void);
+void primitive_bignum_not(void);
+void primitive_bignum_bitp(void);
+void primitive_bignum_log2(void);
+void primitive_byte_array_to_bignum(void);
+
+INLINE CELL allot_integer(F_FIXNUM x)
+{
+ if(x < FIXNUM_MIN || x > FIXNUM_MAX)
+ return tag_bignum(fixnum_to_bignum(x));
+ else
+ return tag_fixnum(x);
+}
+
+INLINE CELL allot_cell(CELL x)
+{
+ if(x > (CELL)FIXNUM_MAX)
+ return tag_bignum(cell_to_bignum(x));
+ else
+ return tag_fixnum(x);
+}
+
+/* FFI calls this */
+DLLEXPORT void box_signed_1(s8 n);
+DLLEXPORT void box_unsigned_1(u8 n);
+DLLEXPORT void box_signed_2(s16 n);
+DLLEXPORT void box_unsigned_2(u16 n);
+DLLEXPORT void box_signed_4(s32 n);
+DLLEXPORT void box_unsigned_4(u32 n);
+DLLEXPORT void box_signed_cell(F_FIXNUM integer);
+DLLEXPORT void box_unsigned_cell(CELL cell);
+DLLEXPORT void box_signed_8(s64 n);
+DLLEXPORT s64 to_signed_8(CELL obj);
+
+DLLEXPORT void box_unsigned_8(u64 n);
+DLLEXPORT u64 to_unsigned_8(CELL obj);
+
+CELL unbox_array_size(void);
+
+INLINE double untag_float_fast(CELL tagged)
+{
+ return ((F_FLOAT *)UNTAG(tagged))->n;
+}
+
+INLINE double untag_float(CELL tagged)
+{
+ type_check(FLOAT_TYPE,tagged);
+ return untag_float_fast(tagged);
+}
+
+INLINE CELL allot_float(double n)
+{
+ F_FLOAT* flo = (F_FLOAT *)allot_object(FLOAT_TYPE,sizeof(F_FLOAT));
+ flo->n = n;
+ return RETAG(flo,FLOAT_TYPE);
+}
+
+INLINE F_FIXNUM float_to_fixnum(CELL tagged)
+{
+ return (F_FIXNUM)untag_float_fast(tagged);
+}
+
+INLINE F_ARRAY *float_to_bignum(CELL tagged)
+{
+ return double_to_bignum(untag_float_fast(tagged));
+}
+
+INLINE double fixnum_to_float(CELL tagged)
+{
+ return (double)untag_fixnum_fast(tagged);
+}
+
+INLINE double bignum_to_float(CELL tagged)
+{
+ return bignum_to_double(untag_bignum_fast(tagged));
+}
+
+DLLEXPORT void box_float(float flo);
+DLLEXPORT float to_float(CELL value);
+DLLEXPORT void box_double(double flo);
+DLLEXPORT double to_double(CELL value);
+
+void primitive_fixnum_to_float(void);
+void primitive_bignum_to_float(void);
+void primitive_str_to_float(void);
+void primitive_float_to_str(void);
+void primitive_float_to_bits(void);
+
+void primitive_float_eq(void);
+void primitive_float_add(void);
+void primitive_float_subtract(void);
+void primitive_float_multiply(void);
+void primitive_float_divfloat(void);
+void primitive_float_mod(void);
+void primitive_float_less(void);
+void primitive_float_lesseq(void);
+void primitive_float_greater(void);
+void primitive_float_greatereq(void);
+
+void primitive_float_bits(void);
+void primitive_bits_float(void);
+void primitive_double_bits(void);
+void primitive_bits_double(void);
--- /dev/null
+#include <ucontext.h>
+
+INLINE void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return (void *)ucontext->uc_mcontext.mc_esp;
+}
+
+#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)(ucontext))->uc_mcontext.mc_eip)
--- /dev/null
+#include <ucontext.h>
+
+INLINE void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return (void *)ucontext->uc_mcontext.mc_rsp;
+}
+
+#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)(ucontext))->uc_mcontext.mc_rip)
--- /dev/null
+#include "master.hpp"
+
+/* From SBCL */
+const char *vm_executable_path(void)
+{
+ char path[PATH_MAX + 1];
+
+ if (getosreldate() >= 600024)
+ {
+ /* KERN_PROC_PATHNAME is available */
+ size_t len = PATH_MAX + 1;
+ int mib[4];
+
+ mib[0] = CTL_KERN;
+ mib[1] = KERN_PROC;
+ mib[2] = KERN_PROC_PATHNAME;
+ mib[3] = -1;
+ if (sysctl(mib, 4, &path, &len, NULL, 0) != 0)
+ return NULL;
+ }
+ else
+ {
+ int size;
+ size = readlink("/proc/curproc/file", path, sizeof(path) - 1);
+ if (size < 0)
+ return NULL;
+ path[size] = '\0';
+ }
+
+ if(strcmp(path, "unknown") == 0)
+ return NULL;
+
+ return safe_strdup(path);
+}
--- /dev/null
+#include <osreldate.h>
+
+extern int getosreldate(void);
+
+#include <sys/sysctl.h>
+
+#ifndef KERN_PROC_PATHNAME
+#define KERN_PROC_PATHNAME 12
+#endif
--- /dev/null
+#include "master.hpp"
+
+void c_to_factor_toplevel(CELL quot)
+{
+ c_to_factor(quot);
+}
+
+void init_signals(void)
+{
+ unix_init_signals();
+}
+
+void early_init(void) { }
+
+#define SUFFIX ".image"
+#define SUFFIX_LEN 6
+
+const char *default_image_path(void)
+{
+ const char *path = vm_executable_path();
+
+ if(!path)
+ return "factor.image";
+
+ /* We can't call strlen() here because with gcc 4.1.2 this
+ causes an internal compiler error. */
+ int len = 0;
+ const char *iter = path;
+ while(*iter) { len++; iter++; }
+
+ char *new_path = safe_malloc(PATH_MAX + SUFFIX_LEN + 1);
+ memcpy(new_path,path,len + 1);
+ memcpy(new_path + len,SUFFIX,SUFFIX_LEN + 1);
+ return new_path;
+}
--- /dev/null
+#define DLLEXPORT extern "C"
+#define NULL_DLL NULL
+
+void c_to_factor_toplevel(CELL quot);
+void init_signals(void);
+void early_init(void);
+const char *vm_executable_path(void);
+const char *default_image_path(void);
--- /dev/null
+#include "master.hpp"
+
+void flush_icache(CELL start, CELL len)
+{
+ int result;
+
+ /* XXX: why doesn't this work on Nokia n800? It should behave
+ identically to the below assembly. */
+ /* result = syscall(__ARM_NR_cacheflush,start,start + len,0); */
+
+ /* Assembly swiped from
+ http://lists.arm.linux.org.uk/pipermail/linux-arm/2002-July/003931.html
+ */
+ __asm__ __volatile__ (
+ "mov r0, %1\n"
+ "sub r1, %2, #1\n"
+ "mov r2, #0\n"
+ "swi " __sys1(__ARM_NR_cacheflush) "\n"
+ "mov %0, r0\n"
+ : "=r" (result)
+ : "r" (start), "r" (start + len)
+ : "r0","r1","r2");
+
+ if(result < 0)
+ critical_error("flush_icache() failed",result);
+}
--- /dev/null
+#include <ucontext.h>
+#include <asm/unistd.h>
+#include <sys/syscall.h>
+
+INLINE void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return (void *)ucontext->uc_mcontext.arm_sp;
+}
+
+#define UAP_PROGRAM_COUNTER(ucontext) \
+ (((ucontext_t *)(ucontext))->uc_mcontext.arm_pc)
+
+void flush_icache(CELL start, CELL len);
--- /dev/null
+#include <ucontext.h>
+
+#define FRAME_RETURN_ADDRESS(frame) *((XT *)(frame_successor(frame) + 1) + 1)
+
+INLINE void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return (void *)ucontext->uc_mcontext.uc_regs->gregs[PT_R1];
+}
+
+#define UAP_PROGRAM_COUNTER(ucontext) \
+ (((ucontext_t *)(ucontext))->uc_mcontext.uc_regs->gregs[PT_NIP])
--- /dev/null
+#include <ucontext.h>
+
+INLINE void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return (void *)ucontext->uc_mcontext.gregs[7];
+}
+
+#define UAP_PROGRAM_COUNTER(ucontext) \
+ (((ucontext_t *)(ucontext))->uc_mcontext.gregs[14])
--- /dev/null
+#include <ucontext.h>
+
+INLINE void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return (void *)ucontext->uc_mcontext.gregs[15];
+}
+
+#define UAP_PROGRAM_COUNTER(ucontext) \
+ (((ucontext_t *)(ucontext))->uc_mcontext.gregs[16])
--- /dev/null
+#include "master.hpp"
+
+/* Snarfed from SBCL linux-so.c. You must free() this yourself. */
+const char *vm_executable_path(void)
+{
+ char *path = safe_malloc(PATH_MAX + 1);
+
+ int size = readlink("/proc/self/exe", path, PATH_MAX);
+ if (size < 0)
+ {
+ fatal_error("Cannot read /proc/self/exe",0);
+ return NULL;
+ }
+ else
+ {
+ path[size] = '\0';
+ return safe_strdup(path);
+ }
+}
+
+#ifdef SYS_inotify_init
+
+int inotify_init(void)
+{
+ return syscall(SYS_inotify_init);
+}
+
+int inotify_add_watch(int fd, const char *name, u32 mask)
+{
+ return syscall(SYS_inotify_add_watch, fd, name, mask);
+}
+
+int inotify_rm_watch(int fd, u32 wd)
+{
+ return syscall(SYS_inotify_rm_watch, fd, wd);
+}
+
+#else
+
+int inotify_init(void)
+{
+ not_implemented_error();
+ return -1;
+}
+
+int inotify_add_watch(int fd, const char *name, u32 mask)
+{
+ not_implemented_error();
+ return -1;
+}
+
+int inotify_rm_watch(int fd, u32 wd)
+{
+ not_implemented_error();
+ return -1;
+}
+
+#endif
--- /dev/null
+#include <sys/syscall.h>
+
+int inotify_init(void);
+int inotify_add_watch(int fd, const char *name, u32 mask);
+int inotify_rm_watch(int fd, u32 wd);
--- /dev/null
+/* Fault handler information. MacOSX version.
+Copyright (C) 1993-1999, 2002-2003 Bruno Haible <clisp.org at bruno>
+Copyright (C) 2003 Paolo Bonzini <gnu.org at bonzini>
+
+Used under BSD license with permission from Paolo Bonzini and Bruno Haible,
+2005-03-10:
+
+http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org
+
+Modified for Factor by Slava Pestov */
+#include <ucontext.h>
+
+#define FRAME_RETURN_ADDRESS(frame) *((XT *)(frame_successor(frame) + 1) + 2)
+
+#define MACH_EXC_STATE_TYPE ppc_exception_state_t
+#define MACH_EXC_STATE_FLAVOR PPC_EXCEPTION_STATE
+#define MACH_EXC_STATE_COUNT PPC_EXCEPTION_STATE_COUNT
+#define MACH_THREAD_STATE_TYPE ppc_thread_state_t
+#define MACH_THREAD_STATE_FLAVOR PPC_THREAD_STATE
+#define MACH_THREAD_STATE_COUNT PPC_THREAD_STATE_COUNT
+
+#if __DARWIN_UNIX03
+ #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__dar
+ #define MACH_STACK_POINTER(thr_state) (thr_state)->__r1
+ #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__srr0
+ #define UAP_PROGRAM_COUNTER(ucontext) \
+ MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->__ss))
+#else
+ #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->dar
+ #define MACH_STACK_POINTER(thr_state) (thr_state)->r1
+ #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->srr0
+ #define UAP_PROGRAM_COUNTER(ucontext) \
+ MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss))
+#endif
+
+INLINE CELL fix_stack_pointer(CELL sp)
+{
+ return sp;
+}
--- /dev/null
+/* Fault handler information. MacOSX version.
+Copyright (C) 1993-1999, 2002-2003 Bruno Haible <clisp.org at bruno>
+Copyright (C) 2003 Paolo Bonzini <gnu.org at bonzini>
+
+Used under BSD license with permission from Paolo Bonzini and Bruno Haible,
+2005-03-10:
+
+http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org
+
+Modified for Factor by Slava Pestov */
+#include <ucontext.h>
+
+#define MACH_EXC_STATE_TYPE i386_exception_state_t
+#define MACH_EXC_STATE_FLAVOR i386_EXCEPTION_STATE
+#define MACH_EXC_STATE_COUNT i386_EXCEPTION_STATE_COUNT
+#define MACH_THREAD_STATE_TYPE i386_thread_state_t
+#define MACH_THREAD_STATE_FLAVOR i386_THREAD_STATE
+#define MACH_THREAD_STATE_COUNT i386_THREAD_STATE_COUNT
+
+#if __DARWIN_UNIX03
+ #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__faultvaddr
+ #define MACH_STACK_POINTER(thr_state) (thr_state)->__esp
+ #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__eip
+ #define UAP_PROGRAM_COUNTER(ucontext) \
+ MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->__ss))
+#else
+ #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->faultvaddr
+ #define MACH_STACK_POINTER(thr_state) (thr_state)->esp
+ #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->eip
+ #define UAP_PROGRAM_COUNTER(ucontext) \
+ MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss))
+#endif
+
+INLINE CELL fix_stack_pointer(CELL sp)
+{
+ return ((sp + 4) & ~15) - 4;
+}
--- /dev/null
+/* Fault handler information. MacOSX version.
+Copyright (C) 1993-1999, 2002-2003 Bruno Haible <clisp.org at bruno>
+Copyright (C) 2003 Paolo Bonzini <gnu.org at bonzini>
+
+Used under BSD license with permission from Paolo Bonzini and Bruno Haible,
+2005-03-10:
+
+http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org
+
+Modified for Factor by Slava Pestov and Daniel Ehrenberg */
+#include <ucontext.h>
+
+#define MACH_EXC_STATE_TYPE x86_exception_state64_t
+#define MACH_EXC_STATE_FLAVOR x86_EXCEPTION_STATE64
+#define MACH_EXC_STATE_COUNT x86_EXCEPTION_STATE64_COUNT
+#define MACH_THREAD_STATE_TYPE x86_thread_state64_t
+#define MACH_THREAD_STATE_FLAVOR x86_THREAD_STATE64
+#define MACH_THREAD_STATE_COUNT MACHINE_THREAD_STATE_COUNT
+
+#if __DARWIN_UNIX03
+ #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__faultvaddr
+ #define MACH_STACK_POINTER(thr_state) (thr_state)->__rsp
+ #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__rip
+ #define UAP_PROGRAM_COUNTER(ucontext) \
+ MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->__ss))
+#else
+ #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->faultvaddr
+ #define MACH_STACK_POINTER(thr_state) (thr_state)->rsp
+ #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->rip
+ #define UAP_PROGRAM_COUNTER(ucontext) \
+ MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss))
+#endif
+
+INLINE CELL fix_stack_pointer(CELL sp)
+{
+ return ((sp + 8) & ~15) - 8;
+}
--- /dev/null
+#define DLLEXPORT extern "C" __attribute__((visibility("default")))
+#define FACTOR_OS_STRING "macosx"
+#define NULL_DLL "libfactor.dylib"
+
+void init_signals(void);
+void early_init(void);
+
+const char *vm_executable_path(void);
+const char *default_image_path(void);
+
+DLLEXPORT void c_to_factor_toplevel(CELL quot);
+
+INLINE void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return ucontext->uc_stack.ss_sp;
+}
--- /dev/null
+#import <Cocoa/Cocoa.h>
+
+#include "master.hpp"
+
+void c_to_factor_toplevel(CELL quot)
+{
+ for(;;)
+ {
+NS_DURING
+ c_to_factor(quot);
+ NS_VOIDRETURN;
+NS_HANDLER
+ dpush(allot_alien(F,(CELL)localException));
+ quot = userenv[COCOA_EXCEPTION_ENV];
+ if(type_of(quot) != QUOTATION_TYPE)
+ {
+ /* No Cocoa exception handler was registered, so
+ extra/cocoa/ is not loaded. So we pass the exception
+ along. */
+ [localException raise];
+ }
+NS_ENDHANDLER
+ }
+}
+
+void early_init(void)
+{
+ SInt32 version;
+ Gestalt(gestaltSystemVersion,&version);
+ if(version <= 0x1050)
+ {
+ printf("Factor requires Mac OS X 10.5 or later.\n");
+ exit(1);
+ }
+
+ [[NSAutoreleasePool alloc] init];
+}
+
+const char *vm_executable_path(void)
+{
+ return [[[NSBundle mainBundle] executablePath] UTF8String];
+}
+
+const char *default_image_path(void)
+{
+ NSBundle *bundle = [NSBundle mainBundle];
+ NSString *path = [bundle bundlePath];
+ NSString *executable = [[bundle executablePath] lastPathComponent];
+ NSString *image = [executable stringByAppendingString:@".image"];
+
+ NSString *returnVal;
+
+ if([path hasSuffix:@".app"] || [path hasSuffix:@".app/"])
+ {
+ NSFileManager *mgr = [NSFileManager defaultManager];
+
+ NSString *imageInBundle = [[path stringByAppendingPathComponent:@"Contents/Resources"] stringByAppendingPathComponent:image];
+ NSString *imageAlongBundle = [[path stringByDeletingLastPathComponent] stringByAppendingPathComponent:image];
+
+ returnVal = ([mgr fileExistsAtPath:imageInBundle]
+ ? imageInBundle : imageAlongBundle);
+ }
+ else
+ returnVal = [path stringByAppendingPathComponent:image];
+
+ return [returnVal UTF8String];
+}
+
+void init_signals(void)
+{
+ unix_init_signals();
+ mach_initialize();
+}
+
+/* Amateurs at Apple: implement this function, properly! */
+Protocol *objc_getProtocol(char *name)
+{
+ if(strcmp(name,"NSTextInput") == 0)
+ return @protocol(NSTextInput);
+ else
+ return nil;
+}
--- /dev/null
+#include <ucontext.h>
+
+#define ucontext_stack_pointer(uap) ((void *)_UC_MACHINE_SP((ucontext_t *)uap))
--- /dev/null
+#include <ucontext.h>
+
+#define ucontext_stack_pointer(uap) \
+ ((void *)(((ucontext_t *)(uap))->uc_mcontext.__gregs[_REG_URSP]))
--- /dev/null
+#include "master.hpp"
+
+extern int main();
+
+const char *vm_executable_path(void)
+{
+ static Dl_info info = {0};
+ if (!info.dli_fname)
+ dladdr(main, &info);
+ return info.dli_fname;
+}
--- /dev/null
+#include <ucontext.h>
+
+#define UAP_PROGRAM_COUNTER(uap) _UC_MACHINE_PC((ucontext_t *)uap)
+
+#define DIRECTORY_P(file) ((file)->d_type == DT_DIR)
--- /dev/null
+#include <i386/signal.h>
+
+INLINE void *openbsd_stack_pointer(void *uap)
+{
+ struct sigcontext *sc = (struct sigcontext*) uap;
+ return (void *)sc->sc_esp;
+}
+
+#define ucontext_stack_pointer openbsd_stack_pointer
+#define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_eip)
--- /dev/null
+#include <amd64/signal.h>
+
+INLINE void *openbsd_stack_pointer(void *uap)
+{
+ struct sigcontext *sc = (struct sigcontext*) uap;
+ return (void *)sc->sc_rsp;
+}
+
+#define ucontext_stack_pointer openbsd_stack_pointer
+#define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_rip)
--- /dev/null
+#include "master.hpp"
+
+const char *vm_executable_path(void)
+{
+ return NULL;
+}
--- /dev/null
+#include <ucontext.h>
+
+INLINE void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return (void *)ucontext->uc_mcontext.gregs[ESP];
+}
+
+#define UAP_PROGRAM_COUNTER(ucontext) \
+ (((ucontext_t *)(ucontext))->uc_mcontext.gregs[EIP])
--- /dev/null
+#include <ucontext.h>
+
+INLINE void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return (void *)ucontext->uc_mcontext.gregs[RSP];
+}
+
+#define UAP_PROGRAM_COUNTER(ucontext) \
+ (((ucontext_t *)(ucontext))->uc_mcontext.gregs[RIP])
--- /dev/null
+#include "master.hpp"
+
+const char *vm_executable_path(void)
+{
+ return NULL;
+}
--- /dev/null
+#include "master.hpp"
+
+void start_thread(void *(*start_routine)(void *))
+{
+ pthread_attr_t attr;
+ pthread_t thread;
+
+ if (pthread_attr_init (&attr) != 0)
+ fatal_error("pthread_attr_init() failed",0);
+ if (pthread_attr_setdetachstate (&attr, PTHREAD_CREATE_DETACHED) != 0)
+ fatal_error("pthread_attr_setdetachstate() failed",0);
+ if (pthread_create (&thread, &attr, start_routine, NULL) != 0)
+ fatal_error("pthread_create() failed",0);
+ pthread_attr_destroy (&attr);
+}
+
+static void *null_dll;
+
+s64 current_micros(void)
+{
+ struct timeval t;
+ gettimeofday(&t,NULL);
+ return (s64)t.tv_sec * 1000000 + t.tv_usec;
+}
+
+void sleep_micros(CELL usec)
+{
+ usleep(usec);
+}
+
+void init_ffi(void)
+{
+ /* NULL_DLL is "libfactor.dylib" for OS X and NULL for generic unix */
+ null_dll = dlopen(NULL_DLL,RTLD_LAZY);
+}
+
+void ffi_dlopen(F_DLL *dll)
+{
+ dll->dll = dlopen(alien_offset(dll->path), RTLD_LAZY);
+}
+
+void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol)
+{
+ void *handle = (dll == NULL ? null_dll : dll->dll);
+ return dlsym(handle,symbol);
+}
+
+void ffi_dlclose(F_DLL *dll)
+{
+ if(dlclose(dll->dll))
+ {
+ general_error(ERROR_FFI,tag_object(
+ from_char_string(dlerror())),F,NULL);
+ }
+ dll->dll = NULL;
+}
+
+void primitive_existsp(void)
+{
+ struct stat sb;
+ box_boolean(stat(unbox_char_string(),&sb) >= 0);
+}
+
+F_SEGMENT *alloc_segment(CELL size)
+{
+ int pagesize = getpagesize();
+
+ char *array = (char *)mmap(NULL,pagesize + size + pagesize,
+ PROT_READ | PROT_WRITE | PROT_EXEC,
+ MAP_ANON | MAP_PRIVATE,-1,0);
+
+ if(array == (char*)-1)
+ out_of_memory();
+
+ if(mprotect(array,pagesize,PROT_NONE) == -1)
+ fatal_error("Cannot protect low guard page",(CELL)array);
+
+ if(mprotect(array + pagesize + size,pagesize,PROT_NONE) == -1)
+ fatal_error("Cannot protect high guard page",(CELL)array);
+
+ F_SEGMENT *retval = (F_SEGMENT *)safe_malloc(sizeof(F_SEGMENT));
+
+ retval->start = (CELL)(array + pagesize);
+ retval->size = size;
+ retval->end = retval->start + size;
+
+ return retval;
+}
+
+void dealloc_segment(F_SEGMENT *block)
+{
+ int pagesize = getpagesize();
+
+ int retval = munmap((void*)(block->start - pagesize),
+ pagesize + block->size + pagesize);
+
+ if(retval)
+ fatal_error("dealloc_segment failed",0);
+
+ free(block);
+}
+
+INLINE F_STACK_FRAME *uap_stack_pointer(void *uap)
+{
+ /* There is a race condition here, but in practice a signal
+ delivered during stack frame setup/teardown or while transitioning
+ from Factor to C is a sign of things seriously gone wrong, not just
+ a divide by zero or stack underflow in the listener */
+ if(in_code_heap_p(UAP_PROGRAM_COUNTER(uap)))
+ {
+ F_STACK_FRAME *ptr = (F_STACK_FRAME *)ucontext_stack_pointer(uap);
+ if(!ptr)
+ critical_error("Invalid uap",(CELL)uap);
+ return ptr;
+ }
+ else
+ return NULL;
+}
+
+void memory_signal_handler(int signal, siginfo_t *siginfo, void *uap)
+{
+ signal_fault_addr = (CELL)siginfo->si_addr;
+ signal_callstack_top = uap_stack_pointer(uap);
+ UAP_PROGRAM_COUNTER(uap) = (CELL)memory_signal_handler_impl;
+}
+
+void misc_signal_handler(int signal, siginfo_t *siginfo, void *uap)
+{
+ signal_number = signal;
+ signal_callstack_top = uap_stack_pointer(uap);
+ UAP_PROGRAM_COUNTER(uap) = (CELL)misc_signal_handler_impl;
+}
+
+static void sigaction_safe(int signum, const struct sigaction *act, struct sigaction *oldact)
+{
+ int ret;
+ do
+ {
+ ret = sigaction(signum, act, oldact);
+ }
+ while(ret == -1 && errno == EINTR);
+
+ if(ret == -1)
+ fatal_error("sigaction failed", 0);
+}
+
+void unix_init_signals(void)
+{
+ struct sigaction memory_sigaction;
+ struct sigaction misc_sigaction;
+ struct sigaction ignore_sigaction;
+
+ memset(&memory_sigaction,0,sizeof(struct sigaction));
+ sigemptyset(&memory_sigaction.sa_mask);
+ memory_sigaction.sa_sigaction = memory_signal_handler;
+ memory_sigaction.sa_flags = SA_SIGINFO;
+
+ sigaction_safe(SIGBUS,&memory_sigaction,NULL);
+ sigaction_safe(SIGSEGV,&memory_sigaction,NULL);
+
+ memset(&misc_sigaction,0,sizeof(struct sigaction));
+ sigemptyset(&misc_sigaction.sa_mask);
+ misc_sigaction.sa_sigaction = misc_signal_handler;
+ misc_sigaction.sa_flags = SA_SIGINFO;
+
+ sigaction_safe(SIGABRT,&misc_sigaction,NULL);
+ sigaction_safe(SIGFPE,&misc_sigaction,NULL);
+ sigaction_safe(SIGQUIT,&misc_sigaction,NULL);
+ sigaction_safe(SIGILL,&misc_sigaction,NULL);
+
+ memset(&ignore_sigaction,0,sizeof(struct sigaction));
+ sigemptyset(&ignore_sigaction.sa_mask);
+ ignore_sigaction.sa_handler = SIG_IGN;
+ sigaction_safe(SIGPIPE,&ignore_sigaction,NULL);
+}
+
+/* On Unix, shared fds such as stdin cannot be set to non-blocking mode
+(http://homepages.tesco.net/J.deBoynePollard/FGA/dont-set-shared-file-descriptors-to-non-blocking-mode.html)
+so we kludge around this by spawning a thread, which waits on a control pipe
+for a signal, upon receiving this signal it reads one block of data from stdin
+and writes it to a data pipe. Upon completion, it writes a 4-byte integer to
+the size pipe, indicating how much data was written to the data pipe.
+
+The read end of the size pipe can be set to non-blocking. */
+extern "C" {
+ int stdin_read;
+ int stdin_write;
+
+ int control_read;
+ int control_write;
+
+ int size_read;
+ int size_write;
+}
+
+void safe_close(int fd)
+{
+ if(close(fd) < 0)
+ fatal_error("error closing fd",errno);
+}
+
+bool check_write(int fd, void *data, ssize_t size)
+{
+ if(write(fd,data,size) == size)
+ return true;
+ else
+ {
+ if(errno == EINTR)
+ return check_write(fd,data,size);
+ else
+ return false;
+ }
+}
+
+void safe_write(int fd, void *data, ssize_t size)
+{
+ if(!check_write(fd,data,size))
+ fatal_error("error writing fd",errno);
+}
+
+bool safe_read(int fd, void *data, ssize_t size)
+{
+ ssize_t bytes = read(fd,data,size);
+ if(bytes < 0)
+ {
+ if(errno == EINTR)
+ return safe_read(fd,data,size);
+ else
+ {
+ fatal_error("error reading fd",errno);
+ return false;
+ }
+ }
+ else
+ return (bytes == size);
+}
+
+void *stdin_loop(void *arg)
+{
+ unsigned char buf[4096];
+ bool loop_running = true;
+
+ while(loop_running)
+ {
+ if(!safe_read(control_read,buf,1))
+ break;
+
+ if(buf[0] != 'X')
+ fatal_error("stdin_loop: bad data on control fd",buf[0]);
+
+ for(;;)
+ {
+ ssize_t bytes = read(0,buf,sizeof(buf));
+ if(bytes < 0)
+ {
+ if(errno == EINTR)
+ continue;
+ else
+ {
+ loop_running = false;
+ break;
+ }
+ }
+ else if(bytes >= 0)
+ {
+ safe_write(size_write,&bytes,sizeof(bytes));
+
+ if(!check_write(stdin_write,buf,bytes))
+ loop_running = false;
+ break;
+ }
+ }
+ }
+
+ safe_close(stdin_write);
+ safe_close(control_read);
+
+ return NULL;
+}
+
+void open_console(void)
+{
+ int filedes[2];
+
+ if(pipe(filedes) < 0)
+ fatal_error("Error opening control pipe",errno);
+
+ control_read = filedes[0];
+ control_write = filedes[1];
+
+ if(pipe(filedes) < 0)
+ fatal_error("Error opening size pipe",errno);
+
+ size_read = filedes[0];
+ size_write = filedes[1];
+
+ if(pipe(filedes) < 0)
+ fatal_error("Error opening stdin pipe",errno);
+
+ stdin_read = filedes[0];
+ stdin_write = filedes[1];
+
+ start_thread(stdin_loop);
+}
+
+DLLEXPORT void wait_for_stdin(void)
+{
+ if(write(control_write,"X",1) != 1)
+ {
+ if(errno == EINTR)
+ wait_for_stdin();
+ else
+ fatal_error("Error writing control fd",errno);
+ }
+}
--- /dev/null
+#include <dirent.h>
+#include <sys/mman.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <unistd.h>
+#include <sys/time.h>
+#include <dlfcn.h>
+#include <signal.h>
+#include <pthread.h>
+
+typedef char F_CHAR;
+typedef char F_SYMBOL;
+
+#define from_native_string from_char_string
+#define unbox_native_string unbox_char_string
+#define string_to_native_alien(string) string_to_char_alien(string,true)
+#define unbox_symbol_string unbox_char_string
+
+#define STRING_LITERAL(string) string
+
+#define SSCANF sscanf
+#define STRCMP strcmp
+#define STRNCMP strncmp
+#define STRDUP strdup
+
+#define FSEEK fseeko
+
+#define FIXNUM_FORMAT "%ld"
+#define CELL_FORMAT "%lu"
+#define CELL_HEX_FORMAT "%lx"
+
+#ifdef FACTOR_64
+ #define CELL_HEX_PAD_FORMAT "%016lx"
+#else
+ #define CELL_HEX_PAD_FORMAT "%08lx"
+#endif
+
+#define FIXNUM_FORMAT "%ld"
+
+#define OPEN_READ(path) fopen(path,"rb")
+#define OPEN_WRITE(path) fopen(path,"wb")
+
+#define print_native_string(string) print_string(string)
+
+void start_thread(void *(*start_routine)(void *));
+
+void init_ffi(void);
+void ffi_dlopen(F_DLL *dll);
+void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol);
+void ffi_dlclose(F_DLL *dll);
+
+void unix_init_signals(void);
+void signal_handler(int signal, siginfo_t* siginfo, void* uap);
+void dump_stack_signal(int signal, siginfo_t* siginfo, void* uap);
+
+s64 current_micros(void);
+void sleep_micros(CELL usec);
+
+void open_console(void);
--- /dev/null
+#include "master.hpp"
+
+s64 current_micros(void)
+{
+ SYSTEMTIME st;
+ FILETIME ft;
+ GetSystemTime(&st);
+ SystemTimeToFileTime(&st, &ft);
+ return (((s64)ft.dwLowDateTime
+ | (s64)ft.dwHighDateTime<<32) - EPOCH_OFFSET) / 10;
+}
+
+char *strerror(int err)
+{
+ /* strerror() is not defined on WinCE */
+ return "strerror() is not defined on WinCE. Use native I/O.";
+}
+
+void flush_icache(CELL start, CELL end)
+{
+ FlushInstructionCache(GetCurrentProcess(), 0, 0);
+}
+
+char *getenv(char *name)
+{
+ not_implemented_error();
+ return 0; /* unreachable */
+}
+
+void primitive_os_envs(void)
+{
+ not_implemented_error();
+}
+
+void c_to_factor_toplevel(CELL quot)
+{
+ c_to_factor(quot);
+}
+
+void open_console(void) { }
--- /dev/null
+#ifndef UNICODE
+#define UNICODE
+#endif
+
+#include <windows.h>
+#include <ctype.h>
+
+typedef wchar_t F_SYMBOL;
+
+#define unbox_symbol_string unbox_u16_string
+#define from_symbol_string from_u16_string
+
+#define FACTOR_OS_STRING "wince"
+#define FACTOR_DLL L"factor-ce.dll"
+#define FACTOR_DLL_NAME "factor-ce.dll"
+
+int errno;
+char *strerror(int err);
+void flush_icache(CELL start, CELL end);
+char *getenv(char *name);
+
+#define snprintf _snprintf
+#define snwprintf _snwprintf
+
+s64 current_micros(void);
+void c_to_factor_toplevel(CELL quot);
+void open_console(void);
--- /dev/null
+#define ESP Esp
+#define EIP Eip
--- /dev/null
+#define ESP Rsp
+#define EIP Rip
--- /dev/null
+#include "master.hpp"
+
+s64 current_micros(void)
+{
+ FILETIME t;
+ GetSystemTimeAsFileTime(&t);
+ return (((s64)t.dwLowDateTime | (s64)t.dwHighDateTime<<32)
+ - EPOCH_OFFSET) / 10;
+}
+
+long exception_handler(PEXCEPTION_POINTERS pe)
+{
+ PEXCEPTION_RECORD e = (PEXCEPTION_RECORD)pe->ExceptionRecord;
+ CONTEXT *c = (CONTEXT*)pe->ContextRecord;
+
+ if(in_code_heap_p(c->EIP))
+ signal_callstack_top = (void *)c->ESP;
+ else
+ signal_callstack_top = NULL;
+
+ if(e->ExceptionCode == EXCEPTION_ACCESS_VIOLATION)
+ {
+ signal_fault_addr = e->ExceptionInformation[1];
+ c->EIP = (CELL)memory_signal_handler_impl;
+ }
+ /* If the Widcomm bluetooth stack is installed, the BTTray.exe process
+ injects code into running programs. For some reason this results in
+ random SEH exceptions with this (undocumented) exception code being
+ raised. The workaround seems to be ignoring this altogether, since that
+ is what happens if SEH is not enabled. Don't really have any idea what
+ this exception means. */
+ else if(e->ExceptionCode != 0x40010006)
+ {
+ signal_number = e->ExceptionCode;
+ c->EIP = (CELL)misc_signal_handler_impl;
+ }
+
+ return EXCEPTION_CONTINUE_EXECUTION;
+}
+
+void c_to_factor_toplevel(CELL quot)
+{
+ if(!AddVectoredExceptionHandler(0, (void*)exception_handler))
+ fatal_error("AddVectoredExceptionHandler failed", 0);
+ c_to_factor(quot);
+ RemoveVectoredExceptionHandler((void*)exception_handler);
+}
+
+void open_console(void)
+{
+}
--- /dev/null
+#undef _WIN32_WINNT
+#define _WIN32_WINNT 0x0501 // For AddVectoredExceptionHandler
+
+#ifndef UNICODE
+#define UNICODE
+#endif
+
+#include <windows.h>
+
+typedef char F_SYMBOL;
+
+#define unbox_symbol_string unbox_char_string
+#define from_symbol_string from_char_string
+
+#define FACTOR_OS_STRING "winnt"
+#define FACTOR_DLL L"factor.dll"
+#define FACTOR_DLL_NAME "factor.dll"
+
+void c_to_factor_toplevel(CELL quot);
+long exception_handler(PEXCEPTION_POINTERS pe);
+void open_console(void);
--- /dev/null
+#include "master.hpp"
+
+HMODULE hFactorDll;
+
+void init_ffi(void)
+{
+ hFactorDll = GetModuleHandle(FACTOR_DLL);
+ if(!hFactorDll)
+ fatal_error("GetModuleHandle(\"" FACTOR_DLL_NAME "\") failed", 0);
+}
+
+void ffi_dlopen(F_DLL *dll)
+{
+ dll->dll = LoadLibraryEx(alien_offset(dll->path), NULL, 0);
+}
+
+void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol)
+{
+ return GetProcAddress(dll ? (HMODULE)dll->dll : hFactorDll, symbol);
+}
+
+void ffi_dlclose(F_DLL *dll)
+{
+ FreeLibrary((HMODULE)dll->dll);
+ dll->dll = NULL;
+}
+
+bool windows_stat(F_CHAR *path)
+{
+ BY_HANDLE_FILE_INFORMATION bhfi;
+ HANDLE h = CreateFileW(path,
+ GENERIC_READ,
+ FILE_SHARE_READ,
+ NULL,
+ OPEN_EXISTING,
+ FILE_FLAG_BACKUP_SEMANTICS,
+ NULL);
+
+ if(h == INVALID_HANDLE_VALUE)
+ {
+ // FindFirstFile is the only call that can stat c:\pagefile.sys
+ WIN32_FIND_DATA st;
+ HANDLE h;
+
+ if(INVALID_HANDLE_VALUE == (h = FindFirstFile(path, &st)))
+ return false;
+ FindClose(h);
+ return true;
+ }
+ bool ret;
+ ret = GetFileInformationByHandle(h, &bhfi);
+ CloseHandle(h);
+ return ret;
+}
+
+void windows_image_path(F_CHAR *full_path, F_CHAR *temp_path, unsigned int length)
+{
+ snwprintf(temp_path, length-1, L"%s.image", full_path);
+ temp_path[sizeof(temp_path) - 1] = 0;
+}
+
+/* You must free() this yourself. */
+const F_CHAR *default_image_path(void)
+{
+ F_CHAR full_path[MAX_UNICODE_PATH];
+ F_CHAR *ptr;
+ F_CHAR temp_path[MAX_UNICODE_PATH];
+
+ if(!GetModuleFileName(NULL, full_path, MAX_UNICODE_PATH))
+ fatal_error("GetModuleFileName() failed", 0);
+
+ if((ptr = wcsrchr(full_path, '.')))
+ *ptr = 0;
+
+ snwprintf(temp_path, sizeof(temp_path)-1, L"%s.image", full_path);
+ temp_path[sizeof(temp_path) - 1] = 0;
+
+ return safe_strdup(temp_path);
+}
+
+/* You must free() this yourself. */
+const F_CHAR *vm_executable_path(void)
+{
+ F_CHAR full_path[MAX_UNICODE_PATH];
+ if(!GetModuleFileName(NULL, full_path, MAX_UNICODE_PATH))
+ fatal_error("GetModuleFileName() failed", 0);
+ return safe_strdup(full_path);
+}
+
+
+void primitive_existsp(void)
+{
+
+ F_CHAR *path = unbox_u16_string();
+ box_boolean(windows_stat(path));
+}
+
+F_SEGMENT *alloc_segment(CELL size)
+{
+ char *mem;
+ DWORD ignore;
+
+ if((mem = (char *)VirtualAlloc(NULL, getpagesize() * 2 + size,
+ MEM_COMMIT, PAGE_EXECUTE_READWRITE)) == 0)
+ out_of_memory();
+
+ if (!VirtualProtect(mem, getpagesize(), PAGE_NOACCESS, &ignore))
+ fatal_error("Cannot allocate low guard page", (CELL)mem);
+
+ if (!VirtualProtect(mem + size + getpagesize(),
+ getpagesize(), PAGE_NOACCESS, &ignore))
+ fatal_error("Cannot allocate high guard page", (CELL)mem);
+
+ F_SEGMENT *block = safe_malloc(sizeof(F_SEGMENT));
+
+ block->start = (CELL)mem + getpagesize();
+ block->size = size;
+ block->end = block->start + size;
+
+ return block;
+}
+
+void dealloc_segment(F_SEGMENT *block)
+{
+ SYSTEM_INFO si;
+ GetSystemInfo(&si);
+ if(!VirtualFree((void*)(block->start - si.dwPageSize), 0, MEM_RELEASE))
+ fatal_error("dealloc_segment failed",0);
+ free(block);
+}
+
+long getpagesize(void)
+{
+ static long g_pagesize = 0;
+ if (! g_pagesize)
+ {
+ SYSTEM_INFO system_info;
+ GetSystemInfo (&system_info);
+ g_pagesize = system_info.dwPageSize;
+ }
+ return g_pagesize;
+}
+
+void sleep_micros(u64 usec)
+{
+ Sleep((DWORD)(usec / 1000));
+}
--- /dev/null
+#include <ctype.h>
+
+#ifndef wcslen
+ /* for cygwin */
+ #include <wchar.h>
+#endif
+
+typedef wchar_t F_CHAR;
+
+#define from_native_string from_u16_string
+#define unbox_native_string unbox_u16_string
+#define string_to_native_alien(string) string_to_u16_alien(string,true)
+
+#define STRING_LITERAL(string) L##string
+
+#define MAX_UNICODE_PATH 32768
+#define DLLEXPORT extern "C" __declspec(dllexport)
+#define SSCANF swscanf
+#define STRCMP wcscmp
+#define STRNCMP wcsncmp
+#define STRDUP _wcsdup
+#define MIN(a,b) ((a)>(b)?(b):(a))
+#define FSEEK fseek
+
+#ifdef WIN64
+ #define CELL_FORMAT "%Iu"
+ #define CELL_HEX_FORMAT "%Ix"
+ #define CELL_HEX_PAD_FORMAT "%016Ix"
+ #define FIXNUM_FORMAT "%Id"
+#else
+ #define CELL_FORMAT "%lu"
+ #define CELL_HEX_FORMAT "%lx"
+ #define CELL_HEX_PAD_FORMAT "%08lx"
+ #define FIXNUM_FORMAT "%ld"
+#endif
+
+#define OPEN_READ(path) _wfopen(path,L"rb")
+#define OPEN_WRITE(path) _wfopen(path,L"wb")
+
+#define print_native_string(string) wprintf(L"%s",string)
+
+/* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */
+#define EPOCH_OFFSET 0x019db1ded53e8000LL
+
+void init_ffi(void);
+void ffi_dlopen(F_DLL *dll);
+void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol);
+void ffi_dlclose(F_DLL *dll);
+
+void sleep_micros(u64 msec);
+
+INLINE void init_signals(void) {}
+INLINE void early_init(void) {}
+const F_CHAR *vm_executable_path(void);
+const F_CHAR *default_image_path(void);
+long getpagesize (void);
+
+s64 current_micros(void);
+
--- /dev/null
+#if defined(__arm__)
+ #define FACTOR_ARM
+#elif defined(__amd64__) || defined(__x86_64__)
+ #define FACTOR_AMD64
+#elif defined(i386) || defined(__i386) || defined(__i386__) || defined(WIN32)
+ #define FACTOR_X86
+#elif defined(__POWERPC__) || defined(__ppc__) || defined(_ARCH_PPC)
+ #define FACTOR_PPC
+#else
+ #error "Unsupported architecture"
+#endif
+
+#if defined(WINDOWS)
+ #if defined(WINCE)
+ #include "os-windows-ce.hpp"
+ #else
+ #include "os-windows-nt.hpp"
+ #endif
+
+ #include "os-windows.hpp"
+ #if defined(FACTOR_AMD64)
+ #include "os-windows-nt.64.hpp"
+ #elif defined(FACTOR_X86)
+ #include "os-windows-nt.32.hpp"
+ #endif
+#else
+ #include "os-unix.hpp"
+
+ #ifdef __APPLE__
+ #include "os-macosx.hpp"
+ #include "mach_signal.hpp"
+
+ #ifdef FACTOR_X86
+ #include "os-macosx-x86.32.hpp"
+ #elif defined(FACTOR_PPC)
+ #include "os-macosx-ppc.hpp"
+ #elif defined(FACTOR_AMD64)
+ #include "os-macosx-x86.64.hpp"
+ #else
+ #error "Unsupported Mac OS X flavor"
+ #endif
+ #else
+ #include "os-genunix.hpp"
+
+ #ifdef __FreeBSD__
+ #define FACTOR_OS_STRING "freebsd"
+ #include "os-freebsd.hpp"
+
+ #if defined(FACTOR_X86)
+ #include "os-freebsd-x86.32.hpp"
+ #elif defined(FACTOR_AMD64)
+ #include "os-freebsd-x86.64.hpp"
+ #else
+ #error "Unsupported FreeBSD flavor"
+ #endif
+ #elif defined(__OpenBSD__)
+ #define FACTOR_OS_STRING "openbsd"
+
+ #if defined(FACTOR_X86)
+ #include "os-openbsd-x86.32.hpp"
+ #elif defined(FACTOR_AMD64)
+ #include "os-openbsd-x86.64.hpp"
+ #else
+ #error "Unsupported OpenBSD flavor"
+ #endif
+ #elif defined(__NetBSD__)
+ #define FACTOR_OS_STRING "netbsd"
+
+ #if defined(FACTOR_X86)
+ #include "os-netbsd-x86.32.hpp"
+ #elif defined(FACTOR_AMD64)
+ #include "os-netbsd-x86.64.hpp"
+ #else
+ #error "Unsupported NetBSD flavor"
+ #endif
+
+ #include "os-netbsd.hpp"
+ #elif defined(linux)
+ #define FACTOR_OS_STRING "linux"
+ #include "os-linux.hpp"
+
+ #if defined(FACTOR_X86)
+ #include "os-linux-x86.32.hpp"
+ #elif defined(FACTOR_PPC)
+ #include "os-linux-ppc.hpp"
+ #elif defined(FACTOR_ARM)
+ #include "os-linux-arm.hpp"
+ #elif defined(FACTOR_AMD64)
+ #include "os-linux-x86.64.hpp"
+ #else
+ #error "Unsupported Linux flavor"
+ #endif
+ #elif defined(__SVR4) && defined(sun)
+ #define FACTOR_OS_STRING "solaris"
+
+ #if defined(FACTOR_X86)
+ #include "os-solaris-x86.32.hpp"
+ #elif defined(FACTOR_AMD64)
+ #include "os-solaris-x86.64.hpp"
+ #else
+ #error "Unsupported Solaris flavor"
+ #endif
+
+ #else
+ #error "Unsupported OS"
+ #endif
+ #endif
+#endif
+
+#if defined(FACTOR_X86)
+ #include "cpu-x86.32.hpp"
+ #include "cpu-x86.hpp"
+#elif defined(FACTOR_AMD64)
+ #include "cpu-x86.64.hpp"
+ #include "cpu-x86.hpp"
+#elif defined(FACTOR_PPC)
+ #include "cpu-ppc.hpp"
+#elif defined(FACTOR_ARM)
+ #include "cpu-arm.hpp"
+#else
+ #error "Unsupported CPU"
+#endif
--- /dev/null
+#include "master.hpp"
+
+F_PRIMITIVE primitives[] = {
+ primitive_bignum_to_fixnum,
+ primitive_float_to_fixnum,
+ primitive_fixnum_to_bignum,
+ primitive_float_to_bignum,
+ primitive_fixnum_to_float,
+ primitive_bignum_to_float,
+ primitive_str_to_float,
+ primitive_float_to_str,
+ primitive_float_bits,
+ primitive_double_bits,
+ primitive_bits_float,
+ primitive_bits_double,
+ primitive_fixnum_add,
+ primitive_fixnum_subtract,
+ primitive_fixnum_multiply,
+ primitive_fixnum_divint,
+ primitive_fixnum_divmod,
+ primitive_fixnum_shift,
+ primitive_bignum_eq,
+ primitive_bignum_add,
+ primitive_bignum_subtract,
+ primitive_bignum_multiply,
+ primitive_bignum_divint,
+ primitive_bignum_mod,
+ primitive_bignum_divmod,
+ primitive_bignum_and,
+ primitive_bignum_or,
+ primitive_bignum_xor,
+ primitive_bignum_not,
+ primitive_bignum_shift,
+ primitive_bignum_less,
+ primitive_bignum_lesseq,
+ primitive_bignum_greater,
+ primitive_bignum_greatereq,
+ primitive_bignum_bitp,
+ primitive_bignum_log2,
+ primitive_byte_array_to_bignum,
+ primitive_float_eq,
+ primitive_float_add,
+ primitive_float_subtract,
+ primitive_float_multiply,
+ primitive_float_divfloat,
+ primitive_float_mod,
+ primitive_float_less,
+ primitive_float_lesseq,
+ primitive_float_greater,
+ primitive_float_greatereq,
+ primitive_word,
+ primitive_word_xt,
+ primitive_getenv,
+ primitive_setenv,
+ primitive_existsp,
+ primitive_gc,
+ primitive_gc_stats,
+ primitive_save_image,
+ primitive_save_image_and_exit,
+ primitive_datastack,
+ primitive_retainstack,
+ primitive_callstack,
+ primitive_set_datastack,
+ primitive_set_retainstack,
+ primitive_set_callstack,
+ primitive_exit,
+ primitive_data_room,
+ primitive_code_room,
+ primitive_micros,
+ primitive_modify_code_heap,
+ primitive_dlopen,
+ primitive_dlsym,
+ primitive_dlclose,
+ primitive_byte_array,
+ primitive_uninitialized_byte_array,
+ primitive_displaced_alien,
+ primitive_alien_signed_cell,
+ primitive_set_alien_signed_cell,
+ primitive_alien_unsigned_cell,
+ primitive_set_alien_unsigned_cell,
+ primitive_alien_signed_8,
+ primitive_set_alien_signed_8,
+ primitive_alien_unsigned_8,
+ primitive_set_alien_unsigned_8,
+ primitive_alien_signed_4,
+ primitive_set_alien_signed_4,
+ primitive_alien_unsigned_4,
+ primitive_set_alien_unsigned_4,
+ primitive_alien_signed_2,
+ primitive_set_alien_signed_2,
+ primitive_alien_unsigned_2,
+ primitive_set_alien_unsigned_2,
+ primitive_alien_signed_1,
+ primitive_set_alien_signed_1,
+ primitive_alien_unsigned_1,
+ primitive_set_alien_unsigned_1,
+ primitive_alien_float,
+ primitive_set_alien_float,
+ primitive_alien_double,
+ primitive_set_alien_double,
+ primitive_alien_cell,
+ primitive_set_alien_cell,
+ primitive_alien_address,
+ primitive_set_slot,
+ primitive_string_nth,
+ primitive_set_string_nth_fast,
+ primitive_set_string_nth_slow,
+ primitive_resize_array,
+ primitive_resize_string,
+ primitive_array,
+ primitive_begin_scan,
+ primitive_next_object,
+ primitive_end_scan,
+ primitive_size,
+ primitive_die,
+ primitive_fopen,
+ primitive_fgetc,
+ primitive_fread,
+ primitive_fputc,
+ primitive_fwrite,
+ primitive_fflush,
+ primitive_fseek,
+ primitive_fclose,
+ primitive_wrapper,
+ primitive_clone,
+ primitive_string,
+ primitive_array_to_quotation,
+ primitive_quotation_xt,
+ primitive_tuple,
+ primitive_profiling,
+ primitive_become,
+ primitive_sleep,
+ primitive_tuple_boa,
+ primitive_callstack_to_array,
+ primitive_innermost_stack_frame_quot,
+ primitive_innermost_stack_frame_scan,
+ primitive_set_innermost_stack_frame_quot,
+ primitive_call_clear,
+ primitive_resize_byte_array,
+ primitive_dll_validp,
+ primitive_unimplemented,
+ primitive_clear_gc_stats,
+ primitive_jit_compile,
+ primitive_load_locals,
+ primitive_check_datastack,
+ primitive_inline_cache_miss,
+ primitive_mega_cache_miss,
+ primitive_lookup_method,
+ primitive_reset_dispatch_stats,
+ primitive_dispatch_stats,
+ primitive_reset_inline_cache_stats,
+ primitive_inline_cache_stats,
+ primitive_optimized_p,
+};
--- /dev/null
+typedef void (*F_PRIMITIVE)(void);
+
+extern F_PRIMITIVE primitives[];
--- /dev/null
+#include "master.hpp"
+
+bool profiling_p;
+
+void init_profiler(void)
+{
+ profiling_p = false;
+}
+
+/* Allocates memory */
+F_CODE_BLOCK *compile_profiling_stub(CELL word)
+{
+ REGISTER_ROOT(word);
+ F_JIT jit;
+ jit_init(&jit,WORD_TYPE,word);
+ jit_emit_with(&jit,userenv[JIT_PROFILING],word);
+ F_CODE_BLOCK *block = jit_make_code_block(&jit);
+ jit_dispose(&jit);
+ UNREGISTER_ROOT(word);
+ return block;
+}
+
+/* Allocates memory */
+static void set_profiling(bool profiling)
+{
+ if(profiling == profiling_p)
+ return;
+
+ profiling_p = profiling;
+
+ /* Push everything to tenured space so that we can heap scan
+ and allocate profiling blocks if necessary */
+ gc();
+
+ CELL words = find_all_words();
+
+ REGISTER_ROOT(words);
+
+ CELL i;
+ CELL length = array_capacity(untag_array_fast(words));
+ for(i = 0; i < length; i++)
+ {
+ F_WORD *word = untag_word(array_nth(untag_array(words),i));
+ if(profiling)
+ word->counter = tag_fixnum(0);
+ update_word_xt(word);
+ }
+
+ UNREGISTER_ROOT(words);
+
+ /* Update XTs in code heap */
+ iterate_code_heap(relocate_code_block);
+}
+
+void primitive_profiling(void)
+{
+ set_profiling(to_boolean(dpop()));
+}
--- /dev/null
+extern bool profiling_p;
+void init_profiler(void);
+F_CODE_BLOCK *compile_profiling_stub(CELL word);
+void primitive_profiling(void);
--- /dev/null
+#include "master.hpp"
+
+/* Simple non-optimizing compiler.
+
+This is one of the two compilers implementing Factor; the second one is written
+in Factor and performs advanced optimizations. See core/compiler/compiler.factor.
+
+The non-optimizing compiler compiles a quotation at a time by concatenating
+machine code chunks; prolog, epilog, call word, jump to word, etc. These machine
+code chunks are generated from Factor code in core/cpu/.../bootstrap.factor.
+
+Calls to words and constant quotations (referenced by conditionals and dips)
+are direct jumps to machine code blocks. Literals are also referenced directly
+without going through the literal table.
+
+It actually does do a little bit of very simple optimization:
+
+1) Tail call optimization.
+
+2) If a quotation is determined to not call any other words (except for a few
+special words which are open-coded, see below), then no prolog/epilog is
+generated.
+
+3) When in tail position and immediately preceded by literal arguments, the
+'if' is generated inline, instead of as a call to the 'if' word.
+
+4) When preceded by a quotation, calls to 'dip', '2dip' and '3dip' are
+open-coded as retain stack manipulation surrounding a subroutine call.
+
+5) Sub-primitives are primitive words which are implemented in assembly and not
+in the VM. They are open-coded and no subroutine call is generated. This
+includes stack shufflers, some fixnum arithmetic words, and words such as tag,
+slot and eq?. A primitive call is relatively expensive (two subroutine calls)
+so this results in a big speedup for relatively little effort. */
+
+static bool jit_primitive_call_p(F_ARRAY *array, CELL i)
+{
+ return (i + 2) == array_capacity(array)
+ && type_of(array_nth(array,i)) == FIXNUM_TYPE
+ && array_nth(array,i + 1) == userenv[JIT_PRIMITIVE_WORD];
+}
+
+static bool jit_fast_if_p(F_ARRAY *array, CELL i)
+{
+ return (i + 3) == array_capacity(array)
+ && type_of(array_nth(array,i)) == QUOTATION_TYPE
+ && type_of(array_nth(array,i + 1)) == QUOTATION_TYPE
+ && array_nth(array,i + 2) == userenv[JIT_IF_WORD];
+}
+
+static bool jit_fast_dip_p(F_ARRAY *array, CELL i)
+{
+ return (i + 2) <= array_capacity(array)
+ && type_of(array_nth(array,i)) == QUOTATION_TYPE
+ && array_nth(array,i + 1) == userenv[JIT_DIP_WORD];
+}
+
+static bool jit_fast_2dip_p(F_ARRAY *array, CELL i)
+{
+ return (i + 2) <= array_capacity(array)
+ && type_of(array_nth(array,i)) == QUOTATION_TYPE
+ && array_nth(array,i + 1) == userenv[JIT_2DIP_WORD];
+}
+
+static bool jit_fast_3dip_p(F_ARRAY *array, CELL i)
+{
+ return (i + 2) <= array_capacity(array)
+ && type_of(array_nth(array,i)) == QUOTATION_TYPE
+ && array_nth(array,i + 1) == userenv[JIT_3DIP_WORD];
+}
+
+static bool jit_mega_lookup_p(F_ARRAY *array, CELL i)
+{
+ return (i + 3) < array_capacity(array)
+ && type_of(array_nth(array,i)) == ARRAY_TYPE
+ && type_of(array_nth(array,i + 1)) == FIXNUM_TYPE
+ && type_of(array_nth(array,i + 2)) == ARRAY_TYPE
+ && array_nth(array,i + 3) == userenv[MEGA_LOOKUP_WORD];
+}
+
+static bool jit_stack_frame_p(F_ARRAY *array)
+{
+ F_FIXNUM length = array_capacity(array);
+ F_FIXNUM i;
+
+ for(i = 0; i < length - 1; i++)
+ {
+ CELL obj = array_nth(array,i);
+ if(type_of(obj) == WORD_TYPE)
+ {
+ F_WORD *word = untag_word_fast(obj);
+ if(word->subprimitive == F)
+ return true;
+ }
+ else if(type_of(obj) == QUOTATION_TYPE)
+ {
+ if(jit_fast_dip_p(array,i)
+ || jit_fast_2dip_p(array,i)
+ || jit_fast_3dip_p(array,i))
+ return true;
+ }
+ }
+
+ return false;
+}
+
+#define TAIL_CALL { \
+ if(stack_frame) jit_emit(jit,userenv[JIT_EPILOG]); \
+ tail_call = true; \
+ }
+
+/* Allocates memory */
+static void jit_iterate_quotation(F_JIT *jit, CELL array, CELL compiling, CELL relocate)
+{
+ REGISTER_ROOT(array);
+
+ bool stack_frame = jit_stack_frame_p(untag_array_fast(array));
+
+ jit_set_position(jit,0);
+
+ if(stack_frame)
+ jit_emit(jit,userenv[JIT_PROLOG]);
+
+ CELL i;
+ CELL length = array_capacity(untag_array_fast(array));
+ bool tail_call = false;
+
+ for(i = 0; i < length; i++)
+ {
+ jit_set_position(jit,i);
+
+ CELL obj = array_nth(untag_array_fast(array),i);
+ REGISTER_ROOT(obj);
+
+ F_WORD *word;
+ F_WRAPPER *wrapper;
+
+ switch(type_of(obj))
+ {
+ case WORD_TYPE:
+ word = untag_word_fast(obj);
+
+ /* Intrinsics */
+ if(word->subprimitive != F)
+ jit_emit_subprimitive(jit,obj);
+ /* The (execute) primitive is special-cased */
+ else if(obj == userenv[JIT_EXECUTE_WORD])
+ {
+ if(i == length - 1)
+ {
+ TAIL_CALL;
+ jit_emit(jit,userenv[JIT_EXECUTE_JUMP]);
+ }
+ else
+ jit_emit(jit,userenv[JIT_EXECUTE_CALL]);
+ }
+ /* Everything else */
+ else
+ {
+ if(i == length - 1)
+ {
+ TAIL_CALL;
+ jit_word_jump(jit,obj);
+ }
+ else
+ jit_word_call(jit,obj);
+ }
+ break;
+ case WRAPPER_TYPE:
+ wrapper = untag_wrapper_fast(obj);
+ jit_push(jit,wrapper->object);
+ break;
+ case FIXNUM_TYPE:
+ /* Primitive calls */
+ if(jit_primitive_call_p(untag_array_fast(array),i))
+ {
+ jit_emit(jit,userenv[JIT_SAVE_STACK]);
+ jit_emit_with(jit,userenv[JIT_PRIMITIVE],obj);
+
+ i++;
+
+ tail_call = true;
+ break;
+ }
+ case QUOTATION_TYPE:
+ /* 'if' preceeded by two literal quotations (this is why if and ? are
+ mutually recursive in the library, but both still work) */
+ if(jit_fast_if_p(untag_array_fast(array),i))
+ {
+ TAIL_CALL;
+
+ if(compiling)
+ {
+ jit_compile(array_nth(untag_array_fast(array),i),relocate);
+ jit_compile(array_nth(untag_array_fast(array),i + 1),relocate);
+ }
+
+ jit_emit_with(jit,userenv[JIT_IF_1],array_nth(untag_array_fast(array),i));
+ jit_emit_with(jit,userenv[JIT_IF_2],array_nth(untag_array_fast(array),i + 1));
+
+ i += 2;
+
+ break;
+ }
+ /* dip */
+ else if(jit_fast_dip_p(untag_array_fast(array),i))
+ {
+ if(compiling)
+ jit_compile(obj,relocate);
+ jit_emit_with(jit,userenv[JIT_DIP],obj);
+ i++;
+ break;
+ }
+ /* 2dip */
+ else if(jit_fast_2dip_p(untag_array_fast(array),i))
+ {
+ if(compiling)
+ jit_compile(obj,relocate);
+ jit_emit_with(jit,userenv[JIT_2DIP],obj);
+ i++;
+ break;
+ }
+ /* 3dip */
+ else if(jit_fast_3dip_p(untag_array_fast(array),i))
+ {
+ if(compiling)
+ jit_compile(obj,relocate);
+ jit_emit_with(jit,userenv[JIT_3DIP],obj);
+ i++;
+ break;
+ }
+ case ARRAY_TYPE:
+ /* Method dispatch */
+ if(jit_mega_lookup_p(untag_array_fast(array),i))
+ {
+ jit_emit_mega_cache_lookup(jit,
+ array_nth(untag_array_fast(array),i),
+ untag_fixnum_fast(array_nth(untag_array_fast(array),i + 1)),
+ array_nth(untag_array_fast(array),i + 2));
+ i += 3;
+ tail_call = true;
+ break;
+ }
+ default:
+ jit_push(jit,obj);
+ break;
+ }
+
+ UNREGISTER_ROOT(obj);
+ }
+
+ if(!tail_call)
+ {
+ jit_set_position(jit,length);
+
+ if(stack_frame)
+ jit_emit(jit,userenv[JIT_EPILOG]);
+ jit_emit(jit,userenv[JIT_RETURN]);
+ }
+
+ UNREGISTER_ROOT(array);
+}
+
+void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code)
+{
+ if(code->block.type != QUOTATION_TYPE)
+ critical_error("Bad param to set_quot_xt",(CELL)code);
+
+ quot->code = code;
+ quot->xt = (XT)(code + 1);
+ quot->compiledp = T;
+}
+
+/* Allocates memory */
+void jit_compile(CELL quot, bool relocate)
+{
+ if(untag_quotation(quot)->compiledp != F)
+ return;
+
+ CELL array = untag_quotation(quot)->array;
+
+ REGISTER_ROOT(quot);
+ REGISTER_ROOT(array);
+
+ F_JIT jit;
+ jit_init(&jit,QUOTATION_TYPE,quot);
+
+ jit_iterate_quotation(&jit,array,true,relocate);
+
+ F_CODE_BLOCK *compiled = jit_make_code_block(&jit);
+
+ set_quot_xt(untag_quotation_fast(quot),compiled);
+
+ if(relocate) relocate_code_block(compiled);
+
+ jit_dispose(&jit);
+
+ UNREGISTER_ROOT(array);
+ UNREGISTER_ROOT(quot);
+}
+
+F_FIXNUM quot_code_offset_to_scan(CELL quot, CELL offset)
+{
+ CELL array = untag_quotation(quot)->array;
+ REGISTER_ROOT(array);
+
+ F_JIT jit;
+ jit_init(&jit,QUOTATION_TYPE,quot);
+ jit_compute_position(&jit,offset);
+ jit_iterate_quotation(&jit,array,false,false);
+ jit_dispose(&jit);
+
+ UNREGISTER_ROOT(array);
+
+ return jit_get_position(&jit);
+}
+
+F_FASTCALL CELL lazy_jit_compile_impl(CELL quot, F_STACK_FRAME *stack)
+{
+ stack_chain->callstack_top = stack;
+ REGISTER_ROOT(quot);
+ jit_compile(quot,true);
+ UNREGISTER_ROOT(quot);
+ return quot;
+}
+
+void primitive_jit_compile(void)
+{
+ jit_compile(dpop(),true);
+}
+
+/* push a new quotation on the stack */
+void primitive_array_to_quotation(void)
+{
+ F_QUOTATION *quot = (F_QUOTATION *)allot_object(QUOTATION_TYPE,sizeof(F_QUOTATION));
+ quot->array = dpeek();
+ quot->xt = (void *)lazy_jit_compile;
+ quot->compiledp = F;
+ quot->cached_effect = F;
+ quot->cache_counter = F;
+ drepl(tag_quotation(quot));
+}
+
+void primitive_quotation_xt(void)
+{
+ F_QUOTATION *quot = untag_quotation(dpeek());
+ drepl(allot_cell((CELL)quot->xt));
+}
+
+void compile_all_words(void)
+{
+ CELL words = find_all_words();
+
+ REGISTER_ROOT(words);
+
+ CELL i;
+ CELL length = array_capacity(untag_array(words));
+ for(i = 0; i < length; i++)
+ {
+ F_WORD *word = untag_word(array_nth(untag_array(words),i));
+ REGISTER_UNTAGGED(word);
+
+ if(!word->code || !word_optimized_p(word))
+ jit_compile_word(word,word->def,false);
+
+ UNREGISTER_UNTAGGED(F_WORD,word);
+ update_word_xt(word);
+
+ }
+
+ UNREGISTER_ROOT(words);
+
+ iterate_code_heap(relocate_code_block);
+}
--- /dev/null
+DEFINE_UNTAG(F_QUOTATION,QUOTATION_TYPE,quotation)
+
+INLINE CELL tag_quotation(F_QUOTATION *quotation)
+{
+ return RETAG(quotation,QUOTATION_TYPE);
+}
+
+void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code);
+void jit_compile(CELL quot, bool relocate);
+F_FIXNUM quot_code_offset_to_scan(CELL quot, CELL offset);
+void primitive_array_to_quotation(void);
+void primitive_quotation_xt(void);
+void primitive_jit_compile(void);
+void compile_all_words(void);
+
+F_FASTCALL CELL lazy_jit_compile_impl(CELL quot, F_STACK_FRAME *stack);
--- /dev/null
+#include "master.hpp"
+
+CELL userenv[USER_ENV];
+CELL T;
+F_CONTEXT *stack_chain;
+CELL ds_size, rs_size;
+F_CONTEXT *unused_contexts;
+
+void reset_datastack(void)
+{
+ ds = ds_bot - CELLS;
+}
+
+void reset_retainstack(void)
+{
+ rs = rs_bot - CELLS;
+}
+
+#define RESERVED (64 * CELLS)
+
+void fix_stacks(void)
+{
+ if(ds + CELLS < ds_bot || ds + RESERVED >= ds_top) reset_datastack();
+ if(rs + CELLS < rs_bot || rs + RESERVED >= rs_top) reset_retainstack();
+}
+
+/* called before entry into foreign C code. Note that ds and rs might
+be stored in registers, so callbacks must save and restore the correct values */
+void save_stacks(void)
+{
+ if(stack_chain)
+ {
+ stack_chain->datastack = ds;
+ stack_chain->retainstack = rs;
+ }
+}
+
+F_CONTEXT *alloc_context(void)
+{
+ F_CONTEXT *context;
+
+ if(unused_contexts)
+ {
+ context = unused_contexts;
+ unused_contexts = unused_contexts->next;
+ }
+ else
+ {
+ context = (F_CONTEXT *)safe_malloc(sizeof(F_CONTEXT));
+ context->datastack_region = alloc_segment(ds_size);
+ context->retainstack_region = alloc_segment(rs_size);
+ }
+
+ return context;
+}
+
+void dealloc_context(F_CONTEXT *context)
+{
+ context->next = unused_contexts;
+ unused_contexts = context;
+}
+
+/* called on entry into a compiled callback */
+void nest_stacks(void)
+{
+ F_CONTEXT *new_stacks = alloc_context();
+
+ new_stacks->callstack_bottom = (F_STACK_FRAME *)-1;
+ new_stacks->callstack_top = (F_STACK_FRAME *)-1;
+
+ /* note that these register values are not necessarily valid stack
+ pointers. they are merely saved non-volatile registers, and are
+ restored in unnest_stacks(). consider this scenario:
+ - factor code calls C function
+ - C function saves ds/cs registers (since they're non-volatile)
+ - C function clobbers them
+ - C function calls Factor callback
+ - Factor callback returns
+ - C function restores registers
+ - C function returns to Factor code */
+ new_stacks->datastack_save = ds;
+ new_stacks->retainstack_save = rs;
+
+ /* save per-callback userenv */
+ new_stacks->current_callback_save = userenv[CURRENT_CALLBACK_ENV];
+ new_stacks->catchstack_save = userenv[CATCHSTACK_ENV];
+
+ new_stacks->next = stack_chain;
+ stack_chain = new_stacks;
+
+ reset_datastack();
+ reset_retainstack();
+}
+
+/* called when leaving a compiled callback */
+void unnest_stacks(void)
+{
+ ds = stack_chain->datastack_save;
+ rs = stack_chain->retainstack_save;
+
+ /* restore per-callback userenv */
+ userenv[CURRENT_CALLBACK_ENV] = stack_chain->current_callback_save;
+ userenv[CATCHSTACK_ENV] = stack_chain->catchstack_save;
+
+ F_CONTEXT *old_stacks = stack_chain;
+ stack_chain = old_stacks->next;
+ dealloc_context(old_stacks);
+}
+
+/* called on startup */
+void init_stacks(CELL ds_size_, CELL rs_size_)
+{
+ ds_size = ds_size_;
+ rs_size = rs_size_;
+ stack_chain = NULL;
+ unused_contexts = NULL;
+}
+
+bool stack_to_array(CELL bottom, CELL top)
+{
+ F_FIXNUM depth = (F_FIXNUM)(top - bottom + CELLS);
+
+ if(depth < 0)
+ return false;
+ else
+ {
+ F_ARRAY *a = allot_array_internal(ARRAY_TYPE,depth / CELLS);
+ memcpy(a + 1,(void*)bottom,depth);
+ dpush(tag_array(a));
+ return true;
+ }
+}
+
+void primitive_datastack(void)
+{
+ if(!stack_to_array(ds_bot,ds))
+ general_error(ERROR_DS_UNDERFLOW,F,F,NULL);
+}
+
+void primitive_retainstack(void)
+{
+ if(!stack_to_array(rs_bot,rs))
+ general_error(ERROR_RS_UNDERFLOW,F,F,NULL);
+}
+
+/* returns pointer to top of stack */
+CELL array_to_stack(F_ARRAY *array, CELL bottom)
+{
+ CELL depth = array_capacity(array) * CELLS;
+ memcpy((void*)bottom,array + 1,depth);
+ return bottom + depth - CELLS;
+}
+
+void primitive_set_datastack(void)
+{
+ ds = array_to_stack(untag_array(dpop()),ds_bot);
+}
+
+void primitive_set_retainstack(void)
+{
+ rs = array_to_stack(untag_array(dpop()),rs_bot);
+}
+
+/* Used to implement call( */
+void primitive_check_datastack(void)
+{
+ F_FIXNUM out = to_fixnum(dpop());
+ F_FIXNUM in = to_fixnum(dpop());
+ F_FIXNUM height = out - in;
+ F_ARRAY *array = untag_array(dpop());
+ F_FIXNUM length = array_capacity(array);
+ F_FIXNUM depth = (ds - ds_bot + CELLS) / CELLS;
+ if(depth - height != length)
+ dpush(F);
+ else
+ {
+ F_FIXNUM i;
+ for(i = 0; i < length - in; i++)
+ {
+ if(get(ds_bot + i * CELLS) != array_nth(array,i))
+ {
+ dpush(F);
+ return;
+ }
+ }
+ dpush(T);
+ }
+}
+
+void primitive_getenv(void)
+{
+ F_FIXNUM e = untag_fixnum_fast(dpeek());
+ drepl(userenv[e]);
+}
+
+void primitive_setenv(void)
+{
+ F_FIXNUM e = untag_fixnum_fast(dpop());
+ CELL value = dpop();
+ userenv[e] = value;
+}
+
+void primitive_exit(void)
+{
+ exit(to_fixnum(dpop()));
+}
+
+void primitive_micros(void)
+{
+ box_unsigned_8(current_micros());
+}
+
+void primitive_sleep(void)
+{
+ sleep_micros(to_cell(dpop()));
+}
+
+void primitive_set_slot(void)
+{
+ F_FIXNUM slot = untag_fixnum_fast(dpop());
+ CELL obj = dpop();
+ CELL value = dpop();
+ set_slot(obj,slot,value);
+}
+
+void primitive_load_locals(void)
+{
+ F_FIXNUM count = untag_fixnum_fast(dpop());
+ memcpy((CELL *)(rs + CELLS),(CELL *)(ds - CELLS * (count - 1)),CELLS * count);
+ ds -= CELLS * count;
+ rs += CELLS * count;
+}
+
+static CELL clone_object(CELL object)
+{
+ CELL size = object_size(object);
+ if(size == 0)
+ return object;
+ else
+ {
+ REGISTER_ROOT(object);
+ void *new_obj = allot_object(type_of(object),size);
+ UNREGISTER_ROOT(object);
+
+ CELL tag = TAG(object);
+ memcpy(new_obj,(void*)UNTAG(object),size);
+ return RETAG(new_obj,tag);
+ }
+}
+
+void primitive_clone(void)
+{
+ drepl(clone_object(dpeek()));
+}
--- /dev/null
+#define USER_ENV 70
+
+typedef enum {
+ NAMESTACK_ENV, /* used by library only */
+ CATCHSTACK_ENV, /* used by library only, per-callback */
+
+ CURRENT_CALLBACK_ENV = 2, /* used by library only, per-callback */
+ WALKER_HOOK_ENV, /* non-local exit hook, used by library only */
+ CALLCC_1_ENV, /* used to pass the value in callcc1 */
+
+ BREAK_ENV = 5, /* quotation called by throw primitive */
+ ERROR_ENV, /* a marker consed onto kernel errors */
+
+ CELL_SIZE_ENV = 7, /* sizeof(CELL) */
+ CPU_ENV, /* CPU architecture */
+ OS_ENV, /* operating system name */
+
+ ARGS_ENV = 10, /* command line arguments */
+ STDIN_ENV, /* stdin FILE* handle */
+ STDOUT_ENV, /* stdout FILE* handle */
+
+ IMAGE_ENV = 13, /* image path name */
+ EXECUTABLE_ENV, /* runtime executable path name */
+
+ EMBEDDED_ENV = 15, /* are we embedded in another app? */
+ EVAL_CALLBACK_ENV, /* used when Factor is embedded in a C app */
+ YIELD_CALLBACK_ENV, /* used when Factor is embedded in a C app */
+ SLEEP_CALLBACK_ENV, /* used when Factor is embedded in a C app */
+
+ COCOA_EXCEPTION_ENV = 19, /* Cocoa exception handler quotation */
+
+ BOOT_ENV = 20, /* boot quotation */
+ GLOBAL_ENV, /* global namespace */
+
+ /* Quotation compilation in quotations.c */
+ JIT_PROLOG = 23,
+ JIT_PRIMITIVE_WORD,
+ JIT_PRIMITIVE,
+ JIT_WORD_JUMP,
+ JIT_WORD_CALL,
+ JIT_IF_WORD,
+ JIT_IF_1,
+ JIT_IF_2,
+ JIT_EPILOG = 33,
+ JIT_RETURN,
+ JIT_PROFILING,
+ JIT_PUSH_IMMEDIATE,
+ JIT_SAVE_STACK = 38,
+ JIT_DIP_WORD,
+ JIT_DIP,
+ JIT_2DIP_WORD,
+ JIT_2DIP,
+ JIT_3DIP_WORD,
+ JIT_3DIP,
+ JIT_EXECUTE_WORD,
+ JIT_EXECUTE_JUMP,
+ JIT_EXECUTE_CALL,
+
+ /* Polymorphic inline cache generation in inline_cache.c */
+ PIC_LOAD = 48,
+ PIC_TAG,
+ PIC_HI_TAG,
+ PIC_TUPLE,
+ PIC_HI_TAG_TUPLE,
+ PIC_CHECK_TAG,
+ PIC_CHECK,
+ PIC_HIT,
+ PIC_MISS_WORD,
+
+ /* Megamorphic cache generation in dispatch.c */
+ MEGA_LOOKUP = 57,
+ MEGA_LOOKUP_WORD,
+ MEGA_MISS_WORD,
+
+ UNDEFINED_ENV = 60, /* default quotation for undefined words */
+
+ STDERR_ENV = 61, /* stderr FILE* handle */
+
+ STAGE2_ENV = 62, /* have we bootstrapped? */
+
+ CURRENT_THREAD_ENV = 63,
+
+ THREADS_ENV = 64,
+ RUN_QUEUE_ENV = 65,
+ SLEEP_QUEUE_ENV = 66,
+
+ STACK_TRACES_ENV = 67,
+} F_ENVTYPE;
+
+#define FIRST_SAVE_ENV BOOT_ENV
+#define LAST_SAVE_ENV STAGE2_ENV
+
+/* TAGGED user environment data; see getenv/setenv prims */
+extern CELL userenv[USER_ENV];
+
+/* macros for reading/writing memory, useful when working around
+C's type system */
+INLINE CELL get(CELL where)
+{
+ return *((CELL*)where);
+}
+
+INLINE void put(CELL where, CELL what)
+{
+ *((CELL*)where) = what;
+}
+
+INLINE CELL cget(CELL where)
+{
+ return *((u16 *)where);
+}
+
+INLINE void cput(CELL where, CELL what)
+{
+ *((u16 *)where) = what;
+}
+
+INLINE CELL bget(CELL where)
+{
+ return *((u8 *)where);
+}
+
+INLINE void bput(CELL where, CELL what)
+{
+ *((u8 *)where) = what;
+}
+
+INLINE CELL align(CELL a, CELL b)
+{
+ return (a + (b-1)) & ~(b-1);
+}
+
+#define align8(a) align(a,8)
+#define align_page(a) align(a,getpagesize())
+
+/* Canonical T object. It's just a word */
+extern CELL T;
+
+INLINE CELL tag_header(CELL cell)
+{
+ return cell << TAG_BITS;
+}
+
+INLINE void check_header(CELL cell)
+{
+#ifdef FACTOR_DEBUG
+ assert(TAG(cell) == FIXNUM_TYPE && untag_fixnum_fast(cell) < TYPE_COUNT);
+#endif
+}
+
+INLINE CELL untag_header(CELL cell)
+{
+ check_header(cell);
+ return cell >> TAG_BITS;
+}
+
+INLINE CELL hi_tag(CELL tagged)
+{
+ return untag_header(get(UNTAG(tagged)));
+}
+
+INLINE CELL tag_object(void *cell)
+{
+#ifdef FACTOR_DEBUG
+ assert(hi_tag((CELL)cell) >= HEADER_TYPE);
+#endif
+ return RETAG(cell,OBJECT_TYPE);
+}
+
+INLINE CELL type_of(CELL tagged)
+{
+ CELL tag = TAG(tagged);
+ if(tag == OBJECT_TYPE)
+ return hi_tag(tagged);
+ else
+ return tag;
+}
+
+#define DEFPUSHPOP(prefix,ptr) \
+ INLINE CELL prefix##pop(void) \
+ { \
+ CELL value = get(ptr); \
+ ptr -= CELLS; \
+ return value; \
+ } \
+ INLINE void prefix##push(CELL tagged) \
+ { \
+ ptr += CELLS; \
+ put(ptr,tagged); \
+ } \
+ INLINE void prefix##repl(CELL tagged) \
+ { \
+ put(ptr,tagged); \
+ } \
+ INLINE CELL prefix##peek() \
+ { \
+ return get(ptr); \
+ }
+
+DEFPUSHPOP(d,ds)
+DEFPUSHPOP(r,rs)
+
+typedef struct {
+ CELL start;
+ CELL size;
+ CELL end;
+} F_SEGMENT;
+
+/* Assembly code makes assumptions about the layout of this struct:
+ - callstack_top field is 0
+ - callstack_bottom field is 1
+ - datastack field is 2
+ - retainstack field is 3 */
+typedef struct _F_CONTEXT {
+ /* C stack pointer on entry */
+ F_STACK_FRAME *callstack_top;
+ F_STACK_FRAME *callstack_bottom;
+
+ /* current datastack top pointer */
+ CELL datastack;
+
+ /* current retain stack top pointer */
+ CELL retainstack;
+
+ /* saved contents of ds register on entry to callback */
+ CELL datastack_save;
+
+ /* saved contents of rs register on entry to callback */
+ CELL retainstack_save;
+
+ /* memory region holding current datastack */
+ F_SEGMENT *datastack_region;
+
+ /* memory region holding current retain stack */
+ F_SEGMENT *retainstack_region;
+
+ /* saved userenv slots on entry to callback */
+ CELL catchstack_save;
+ CELL current_callback_save;
+
+ struct _F_CONTEXT *next;
+} F_CONTEXT;
+
+extern F_CONTEXT *stack_chain;
+
+extern CELL ds_size, rs_size;
+
+#define ds_bot (stack_chain->datastack_region->start)
+#define ds_top (stack_chain->datastack_region->end)
+#define rs_bot (stack_chain->retainstack_region->start)
+#define rs_top (stack_chain->retainstack_region->end)
+
+void reset_datastack(void);
+void reset_retainstack(void);
+void fix_stacks(void);
+DLLEXPORT void save_stacks(void);
+DLLEXPORT void nest_stacks(void);
+DLLEXPORT void unnest_stacks(void);
+void init_stacks(CELL ds_size, CELL rs_size);
+
+void primitive_datastack(void);
+void primitive_retainstack(void);
+void primitive_set_datastack(void);
+void primitive_set_retainstack(void);
+void primitive_check_datastack(void);
+void primitive_getenv(void);
+void primitive_setenv(void);
+void primitive_exit(void);
+void primitive_micros(void);
+void primitive_sleep(void);
+void primitive_set_slot(void);
+void primitive_load_locals(void);
+void primitive_clone(void);
--- /dev/null
+#include "master.hpp"
+
+CELL string_nth(F_STRING* string, CELL index)
+{
+ /* If high bit is set, the most significant 16 bits of the char
+ come from the aux vector. The least significant bit of the
+ corresponding aux vector entry is negated, so that we can
+ XOR the two components together and get the original code point
+ back. */
+ CELL ch = bget(SREF(string,index));
+ if((ch & 0x80) == 0)
+ return ch;
+ else
+ {
+ F_BYTE_ARRAY *aux = untag_byte_array_fast(string->aux);
+ return (cget(BREF(aux,index * sizeof(u16))) << 7) ^ ch;
+ }
+}
+
+void set_string_nth_fast(F_STRING* string, CELL index, CELL ch)
+{
+ bput(SREF(string,index),ch);
+}
+
+void set_string_nth_slow(F_STRING* string, CELL index, CELL ch)
+{
+ F_BYTE_ARRAY *aux;
+
+ bput(SREF(string,index),(ch & 0x7f) | 0x80);
+
+ if(string->aux == F)
+ {
+ REGISTER_UNTAGGED(string);
+ /* We don't need to pre-initialize the
+ byte array with any data, since we
+ only ever read from the aux vector
+ if the most significant bit of a
+ character is set. Initially all of
+ the bits are clear. */
+ aux = allot_byte_array_internal(
+ untag_fixnum_fast(string->length)
+ * sizeof(u16));
+ UNREGISTER_UNTAGGED(F_STRING,string);
+
+ write_barrier((CELL)string);
+ string->aux = tag_object(aux);
+ }
+ else
+ aux = untag_byte_array_fast(string->aux);
+
+ cput(BREF(aux,index * sizeof(u16)),(ch >> 7) ^ 1);
+}
+
+/* allocates memory */
+void set_string_nth(F_STRING* string, CELL index, CELL ch)
+{
+ if(ch <= 0x7f)
+ set_string_nth_fast(string,index,ch);
+ else
+ set_string_nth_slow(string,index,ch);
+}
+
+/* untagged */
+F_STRING* allot_string_internal(CELL capacity)
+{
+ F_STRING *string = (F_STRING *)allot_object(STRING_TYPE,string_size(capacity));
+
+ string->length = tag_fixnum(capacity);
+ string->hashcode = F;
+ string->aux = F;
+
+ return string;
+}
+
+/* allocates memory */
+void fill_string(F_STRING *string, CELL start, CELL capacity, CELL fill)
+{
+ if(fill <= 0x7f)
+ memset((void *)SREF(string,start),fill,capacity - start);
+ else
+ {
+ CELL i;
+
+ for(i = start; i < capacity; i++)
+ {
+ REGISTER_UNTAGGED(string);
+ set_string_nth(string,i,fill);
+ UNREGISTER_UNTAGGED(F_STRING,string);
+ }
+ }
+}
+
+/* untagged */
+F_STRING *allot_string(CELL capacity, CELL fill)
+{
+ F_STRING* string = allot_string_internal(capacity);
+ REGISTER_UNTAGGED(string);
+ fill_string(string,0,capacity,fill);
+ UNREGISTER_UNTAGGED(F_STRING,string);
+ return string;
+}
+
+void primitive_string(void)
+{
+ CELL initial = to_cell(dpop());
+ CELL length = unbox_array_size();
+ dpush(tag_object(allot_string(length,initial)));
+}
+
+static bool reallot_string_in_place_p(F_STRING *string, CELL capacity)
+{
+ return in_zone(&nursery,(CELL)string) && capacity <= string_capacity(string);
+}
+
+F_STRING* reallot_string(F_STRING* string, CELL capacity)
+{
+ if(reallot_string_in_place_p(string,capacity))
+ {
+ string->length = tag_fixnum(capacity);
+
+ if(string->aux != F)
+ {
+ F_BYTE_ARRAY *aux = untag_byte_array_fast(string->aux);
+ aux->capacity = tag_fixnum(capacity * 2);
+ }
+
+ return string;
+ }
+ else
+ {
+ CELL to_copy = string_capacity(string);
+ if(capacity < to_copy)
+ to_copy = capacity;
+
+ REGISTER_UNTAGGED(string);
+ F_STRING *new_string = allot_string_internal(capacity);
+ UNREGISTER_UNTAGGED(F_STRING,string);
+
+ memcpy(new_string + 1,string + 1,to_copy);
+
+ if(string->aux != F)
+ {
+ REGISTER_UNTAGGED(string);
+ REGISTER_UNTAGGED(new_string);
+ F_BYTE_ARRAY *new_aux = allot_byte_array(capacity * sizeof(u16));
+ UNREGISTER_UNTAGGED(F_STRING,new_string);
+ UNREGISTER_UNTAGGED(F_STRING,string);
+
+ write_barrier((CELL)new_string);
+ new_string->aux = tag_object(new_aux);
+
+ F_BYTE_ARRAY *aux = untag_byte_array_fast(string->aux);
+ memcpy(new_aux + 1,aux + 1,to_copy * sizeof(u16));
+ }
+
+ REGISTER_UNTAGGED(string);
+ REGISTER_UNTAGGED(new_string);
+ fill_string(new_string,to_copy,capacity,'\0');
+ UNREGISTER_UNTAGGED(F_STRING,new_string);
+ UNREGISTER_UNTAGGED(F_STRING,string);
+
+ return new_string;
+ }
+}
+
+void primitive_resize_string(void)
+{
+ F_STRING* string = untag_string(dpop());
+ CELL capacity = unbox_array_size();
+ dpush(tag_object(reallot_string(string,capacity)));
+}
+
+/* Some ugly macros to prevent a 2x code duplication */
+
+#define MEMORY_TO_STRING(type,utype) \
+ F_STRING *memory_to_##type##_string(const type *string, CELL length) \
+ { \
+ REGISTER_C_STRING(string); \
+ F_STRING *s = allot_string_internal(length); \
+ UNREGISTER_C_STRING(type,string); \
+ CELL i; \
+ for(i = 0; i < length; i++) \
+ { \
+ REGISTER_UNTAGGED(s); \
+ set_string_nth(s,i,(utype)*string); \
+ UNREGISTER_UNTAGGED(F_STRING,s); \
+ string++; \
+ } \
+ return s; \
+ } \
+ F_STRING *from_##type##_string(const type *str) \
+ { \
+ CELL length = 0; \
+ const type *scan = str; \
+ while(*scan++) length++; \
+ return memory_to_##type##_string(str,length); \
+ } \
+ void box_##type##_string(const type *str) \
+ { \
+ dpush(str ? tag_object(from_##type##_string(str)) : F); \
+ }
+
+MEMORY_TO_STRING(char,u8)
+MEMORY_TO_STRING(u16,u16)
+MEMORY_TO_STRING(u32,u32)
+
+bool check_string(F_STRING *s, CELL max)
+{
+ CELL capacity = string_capacity(s);
+ CELL i;
+ for(i = 0; i < capacity; i++)
+ {
+ CELL ch = string_nth(s,i);
+ if(ch == 0 || ch >= ((CELL)1 << (max * 8)))
+ return false;
+ }
+ return true;
+}
+
+F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size)
+{
+ return allot_byte_array((capacity + 1) * size);
+}
+
+#define STRING_TO_MEMORY(type) \
+ void type##_string_to_memory(F_STRING *s, type *string) \
+ { \
+ CELL i; \
+ CELL capacity = string_capacity(s); \
+ for(i = 0; i < capacity; i++) \
+ string[i] = string_nth(s,i); \
+ } \
+ void primitive_##type##_string_to_memory(void) \
+ { \
+ type *address = (type *)unbox_alien(); \
+ F_STRING *str = untag_string(dpop()); \
+ type##_string_to_memory(str,address); \
+ } \
+ F_BYTE_ARRAY *string_to_##type##_alien(F_STRING *s, bool check) \
+ { \
+ CELL capacity = string_capacity(s); \
+ F_BYTE_ARRAY *_c_str; \
+ if(check && !check_string(s,sizeof(type))) \
+ general_error(ERROR_C_STRING,tag_object(s),F,NULL); \
+ REGISTER_UNTAGGED(s); \
+ _c_str = allot_c_string(capacity,sizeof(type)); \
+ UNREGISTER_UNTAGGED(F_STRING,s); \
+ type *c_str = (type*)(_c_str + 1); \
+ type##_string_to_memory(s,c_str); \
+ c_str[capacity] = 0; \
+ return _c_str; \
+ } \
+ type *to_##type##_string(F_STRING *s, bool check) \
+ { \
+ return (type*)(string_to_##type##_alien(s,check) + 1); \
+ } \
+ type *unbox_##type##_string(void) \
+ { \
+ return to_##type##_string(untag_string(dpop()),true); \
+ }
+
+STRING_TO_MEMORY(char);
+STRING_TO_MEMORY(u16);
+
+void primitive_string_nth(void)
+{
+ F_STRING *string = untag_string_fast(dpop());
+ CELL index = untag_fixnum_fast(dpop());
+ dpush(tag_fixnum(string_nth(string,index)));
+}
+
+void primitive_set_string_nth(void)
+{
+ F_STRING *string = untag_string_fast(dpop());
+ CELL index = untag_fixnum_fast(dpop());
+ CELL value = untag_fixnum_fast(dpop());
+ set_string_nth(string,index,value);
+}
+
+void primitive_set_string_nth_fast(void)
+{
+ F_STRING *string = untag_string_fast(dpop());
+ CELL index = untag_fixnum_fast(dpop());
+ CELL value = untag_fixnum_fast(dpop());
+ set_string_nth_fast(string,index,value);
+}
+
+void primitive_set_string_nth_slow(void)
+{
+ F_STRING *string = untag_string_fast(dpop());
+ CELL index = untag_fixnum_fast(dpop());
+ CELL value = untag_fixnum_fast(dpop());
+ set_string_nth_slow(string,index,value);
+}
--- /dev/null
+INLINE CELL string_capacity(F_STRING *str)
+{
+ return untag_fixnum_fast(str->length);
+}
+
+INLINE CELL string_size(CELL size)
+{
+ return sizeof(F_STRING) + size;
+}
+
+#define BREF(byte_array,index) ((CELL)byte_array + sizeof(F_BYTE_ARRAY) + (index))
+#define SREF(string,index) ((CELL)string + sizeof(F_STRING) + (index))
+
+DEFINE_UNTAG(F_STRING,STRING_TYPE,string)
+
+F_STRING* allot_string_internal(CELL capacity);
+F_STRING* allot_string(CELL capacity, CELL fill);
+void primitive_string(void);
+F_STRING *reallot_string(F_STRING *string, CELL capacity);
+void primitive_resize_string(void);
+
+F_STRING *memory_to_char_string(const char *string, CELL length);
+F_STRING *from_char_string(const char *c_string);
+DLLEXPORT void box_char_string(const char *c_string);
+
+F_STRING *memory_to_u16_string(const u16 *string, CELL length);
+F_STRING *from_u16_string(const u16 *c_string);
+DLLEXPORT void box_u16_string(const u16 *c_string);
+
+void char_string_to_memory(F_STRING *s, char *string);
+F_BYTE_ARRAY *string_to_char_alien(F_STRING *s, bool check);
+char* to_char_string(F_STRING *s, bool check);
+DLLEXPORT char *unbox_char_string(void);
+
+void u16_string_to_memory(F_STRING *s, u16 *string);
+F_BYTE_ARRAY *string_to_u16_alien(F_STRING *s, bool check);
+u16* to_u16_string(F_STRING *s, bool check);
+DLLEXPORT u16 *unbox_u16_string(void);
+
+/* String getters and setters */
+CELL string_nth(F_STRING* string, CELL index);
+void set_string_nth(F_STRING* string, CELL index, CELL value);
+
+void primitive_string_nth(void);
+void primitive_set_string_nth_slow(void);
+void primitive_set_string_nth_fast(void);
--- /dev/null
+#include "master.hpp"
+
+/* push a new tuple on the stack */
+F_TUPLE *allot_tuple(F_TUPLE_LAYOUT *layout)
+{
+ REGISTER_UNTAGGED(layout);
+ F_TUPLE *tuple = (F_TUPLE *)allot_object(TUPLE_TYPE,tuple_size(layout));
+ UNREGISTER_UNTAGGED(F_TUPLE_LAYOUT,layout);
+ tuple->layout = tag_array((F_ARRAY *)layout);
+ return tuple;
+}
+
+void primitive_tuple(void)
+{
+ F_TUPLE_LAYOUT *layout = untag_tuple_layout(dpop());
+ F_FIXNUM size = untag_fixnum_fast(layout->size);
+
+ F_TUPLE *tuple = allot_tuple(layout);
+ F_FIXNUM i;
+ for(i = size - 1; i >= 0; i--)
+ put(AREF(tuple,i),F);
+
+ dpush(tag_tuple(tuple));
+}
+
+/* push a new tuple on the stack, filling its slots from the stack */
+void primitive_tuple_boa(void)
+{
+ F_TUPLE_LAYOUT *layout = untag_tuple_layout(dpop());
+ F_FIXNUM size = untag_fixnum_fast(layout->size);
+ F_TUPLE *tuple = allot_tuple(layout);
+ memcpy(tuple + 1,(CELL *)(ds - CELLS * (size - 1)),CELLS * size);
+ ds -= CELLS * size;
+ dpush(tag_tuple(tuple));
+}
--- /dev/null
+INLINE CELL tag_tuple(F_TUPLE *tuple)
+{
+ return RETAG(tuple,TUPLE_TYPE);
+}
+
+INLINE CELL tuple_size(F_TUPLE_LAYOUT *layout)
+{
+ CELL size = untag_fixnum_fast(layout->size);
+ return sizeof(F_TUPLE) + size * CELLS;
+}
+
+DEFINE_UNTAG(F_TUPLE,TUPLE_TYPE,tuple)
+
+INLINE F_TUPLE_LAYOUT *untag_tuple_layout(CELL obj)
+{
+ return (F_TUPLE_LAYOUT *)UNTAG(obj);
+}
+
+INLINE CELL tuple_nth(F_TUPLE *tuple, CELL slot)
+{
+ return get(AREF(tuple,slot));
+}
+
+INLINE void set_tuple_nth(F_TUPLE *tuple, CELL slot, CELL value)
+{
+ put(AREF(tuple,slot),value);
+ write_barrier((CELL)tuple);
+}
+
+void primitive_tuple(void);
+void primitive_tuple_boa(void);
+void primitive_tuple_layout(void);
--- /dev/null
+#include "master.hpp"
+
+/* If memory allocation fails, bail out */
+void *safe_malloc(size_t size)
+{
+ void *ptr = malloc(size);
+ if(!ptr) fatal_error("Out of memory in safe_malloc", 0);
+ return ptr;
+}
+
+F_CHAR *safe_strdup(const F_CHAR *str)
+{
+ F_CHAR *ptr = STRDUP(str);
+ if(!ptr) fatal_error("Out of memory in safe_strdup", 0);
+ return ptr;
+}
+
+/* We don't use printf directly, because format directives are not portable.
+Instead we define the common cases here. */
+void nl(void)
+{
+ fputs("\n",stdout);
+}
+
+void print_string(const char *str)
+{
+ fputs(str,stdout);
+}
+
+void print_cell(CELL x)
+{
+ printf(CELL_FORMAT,x);
+}
+
+void print_cell_hex(CELL x)
+{
+ printf(CELL_HEX_FORMAT,x);
+}
+
+void print_cell_hex_pad(CELL x)
+{
+ printf(CELL_HEX_PAD_FORMAT,x);
+}
+
+void print_fixnum(F_FIXNUM x)
+{
+ printf(FIXNUM_FORMAT,x);
+}
+
+CELL read_cell_hex(void)
+{
+ CELL cell;
+ if(scanf(CELL_HEX_FORMAT,&cell) < 0) exit(1);
+ return cell;
+};
--- /dev/null
+void *safe_malloc(size_t size);
+F_CHAR *safe_strdup(const F_CHAR *str);
+
+void nl(void);
+void print_string(const char *str);
+void print_cell(CELL x);
+void print_cell_hex(CELL x);
+void print_cell_hex_pad(CELL x);
+void print_fixnum(F_FIXNUM x);
+CELL read_cell_hex(void);
--- /dev/null
+#include "master.hpp"
+
+F_WORD *allot_word(CELL vocab, CELL name)
+{
+ REGISTER_ROOT(vocab);
+ REGISTER_ROOT(name);
+ F_WORD *word = (F_WORD *)allot_object(WORD_TYPE,sizeof(F_WORD));
+ UNREGISTER_ROOT(name);
+ UNREGISTER_ROOT(vocab);
+
+ word->hashcode = tag_fixnum((rand() << 16) ^ rand());
+ word->vocabulary = vocab;
+ word->name = name;
+ word->def = userenv[UNDEFINED_ENV];
+ word->props = F;
+ word->counter = tag_fixnum(0);
+ word->direct_entry_def = F;
+ word->subprimitive = F;
+ word->profiling = NULL;
+ word->code = NULL;
+
+ REGISTER_UNTAGGED(word);
+ jit_compile_word(word,word->def,true);
+ UNREGISTER_UNTAGGED(F_WORD,word);
+
+ REGISTER_UNTAGGED(word);
+ update_word_xt(word);
+ UNREGISTER_UNTAGGED(F_WORD,word);
+
+ if(profiling_p)
+ relocate_code_block(word->profiling);
+
+ return word;
+}
+
+/* <word> ( name vocabulary -- word ) */
+void primitive_word(void)
+{
+ CELL vocab = dpop();
+ CELL name = dpop();
+ dpush(tag_object(allot_word(vocab,name)));
+}
+
+/* word-xt ( word -- start end ) */
+void primitive_word_xt(void)
+{
+ F_WORD *word = untag_word(dpop());
+ F_CODE_BLOCK *code = (profiling_p ? word->profiling : word->code);
+ dpush(allot_cell((CELL)code + sizeof(F_CODE_BLOCK)));
+ dpush(allot_cell((CELL)code + code->block.size));
+}
+
+/* Allocates memory */
+void update_word_xt(F_WORD *word)
+{
+ if(profiling_p)
+ {
+ if(!word->profiling)
+ {
+ REGISTER_UNTAGGED(word);
+ F_CODE_BLOCK *profiling = compile_profiling_stub(tag_object(word));
+ UNREGISTER_UNTAGGED(F_WORD,word);
+ word->profiling = profiling;
+ }
+
+ word->xt = (XT)(word->profiling + 1);
+ }
+ else
+ word->xt = (XT)(word->code + 1);
+}
+
+void primitive_optimized_p(void)
+{
+ drepl(tag_boolean(word_optimized_p(untag_word(dpeek()))));
+}
+
+void primitive_wrapper(void)
+{
+ F_WRAPPER *wrapper = (F_WRAPPER *)allot_object(WRAPPER_TYPE,sizeof(F_WRAPPER));
+ wrapper->object = dpeek();
+ drepl(tag_object(wrapper));
+}
--- /dev/null
+DEFINE_UNTAG(F_WORD,WORD_TYPE,word)
+
+F_WORD *allot_word(CELL vocab, CELL name);
+
+void primitive_word(void);
+void primitive_word_xt(void);
+void update_word_xt(F_WORD *word);
+
+INLINE bool word_optimized_p(F_WORD *word)
+{
+ return word->code->block.type == WORD_TYPE;
+}
+
+void primitive_optimized_p(void);
+
+DEFINE_UNTAG(F_WRAPPER,WRAPPER_TYPE,wrapper)
+
+void primitive_wrapper(void);
--- /dev/null
+#include "master.hpp"
+
+CELL cards_offset;
+CELL decks_offset;
+CELL allot_markers_offset;
--- /dev/null
+/* card marking write barrier. a card is a byte storing a mark flag,
+and the offset (in cells) of the first object in the card.
+
+the mark flag is set by the write barrier when an object in the
+card has a slot written to.
+
+the offset of the first object is set by the allocator. */
+
+/* if CARD_POINTS_TO_NURSERY is set, CARD_POINTS_TO_AGING must also be set. */
+#define CARD_POINTS_TO_NURSERY 0x80
+#define CARD_POINTS_TO_AGING 0x40
+#define CARD_MARK_MASK (CARD_POINTS_TO_NURSERY | CARD_POINTS_TO_AGING)
+typedef u8 F_CARD;
+
+#define CARD_BITS 8
+#define CARD_SIZE (1<<CARD_BITS)
+#define ADDR_CARD_MASK (CARD_SIZE-1)
+
+extern "C" CELL cards_offset;
+
+#define ADDR_TO_CARD(a) (F_CARD*)(((CELL)(a) >> CARD_BITS) + cards_offset)
+#define CARD_TO_ADDR(c) (CELL*)(((CELL)(c) - cards_offset)<<CARD_BITS)
+
+typedef u8 F_DECK;
+
+#define DECK_BITS (CARD_BITS + 10)
+#define DECK_SIZE (1<<DECK_BITS)
+#define ADDR_DECK_MASK (DECK_SIZE-1)
+
+extern "C" CELL decks_offset;
+
+#define ADDR_TO_DECK(a) (F_DECK*)(((CELL)(a) >> DECK_BITS) + decks_offset)
+#define DECK_TO_ADDR(c) (CELL*)(((CELL)(c) - decks_offset) << DECK_BITS)
+
+#define DECK_TO_CARD(d) (F_CARD*)((((CELL)(d) - decks_offset) << (DECK_BITS - CARD_BITS)) + cards_offset)
+
+#define ADDR_TO_ALLOT_MARKER(a) (F_CARD*)(((CELL)(a) >> CARD_BITS) + allot_markers_offset)
+#define CARD_OFFSET(c) (*((c) - (CELL)data_heap->cards + (CELL)data_heap->allot_markers))
+
+#define INVALID_ALLOT_MARKER 0xff
+
+extern "C" CELL allot_markers_offset;
+
+/* the write barrier must be called any time we are potentially storing a
+pointer from an older generation to a younger one */
+INLINE void write_barrier(CELL address)
+{
+ *ADDR_TO_CARD(address) = CARD_MARK_MASK;
+ *ADDR_TO_DECK(address) = CARD_MARK_MASK;
+}
+
+#define SLOT(obj,slot) (UNTAG(obj) + (slot) * CELLS)
+
+INLINE void set_slot(CELL obj, CELL slot, CELL value)
+{
+ put(SLOT(obj,slot),value);
+ write_barrier(obj);
+}
+
+/* we need to remember the first object allocated in the card */
+INLINE void allot_barrier(CELL address)
+{
+ F_CARD *ptr = ADDR_TO_ALLOT_MARKER(address);
+ if(*ptr == INVALID_ALLOT_MARKER)
+ *ptr = (address & ADDR_CARD_MASK);
+}
projects / factor.git / commitdiff