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

Big runtime cleanup

slava 2006-07-07 04:07:18 +00:00
parent da5539c29b
commit 6d21c52ac9
104 changed files with 5830 additions and 5938 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

139
Makefile
View File

@ -3,82 +3,51 @@ CC = gcc
BINARY = f
IMAGE = factor.image
BUNDLE = Factor.app
DISK_IMAGE_DIR = Factor-0.81
DISK_IMAGE = Factor-0.81.dmg
DISK_IMAGE_DIR = Factor-0.83
DISK_IMAGE = Factor-0.83.dmg
ifdef DEBUG
DEFAULT_CFLAGS = -g
CFLAGS = -g
STRIP = touch
else
DEFAULT_CFLAGS = -Wall -O3 -ffast-math -fomit-frame-pointer $(SITE_CFLAGS)
CFLAGS = -Wall -O3 -ffast-math -fomit-frame-pointer $(SITE_CFLAGS)
STRIP = strip
endif
DEFAULT_LIBS = -lm
ifdef NO_UI
UNIX_UI_LIBS =
X11_UI_LIBS =
else
UNIX_UI_LIBS = -lfreetype -lGL -lGLU -L/usr/X11R6/lib -lX11
X11_UI_LIBS = -lfreetype -lGL -lGLU -L/usr/X11R6/lib -lX11
endif
WINDOWS_OBJS = vm/windows/ffi.o \
vm/windows/file.o \
vm/windows/misc.o \
vm/windows/run.o \
vm/windows/memory.o
UNIX_OBJS = vm/unix/file.o \
vm/unix/signal.o \
vm/unix/ffi.o \
vm/unix/memory.o \
vm/unix/icache.o
MACOSX_OBJS = $(UNIX_OBJS) \
vm/macosx/run.o \
vm/macosx/mach_signal.o
GENERIC_UNIX_OBJS = $(UNIX_OBJS) \
vm/unix/run.o
ifdef WINDOWS
PLAF_OBJS = $(WINDOWS_OBJS)
PLAF_SUFFIX = .exe
else
ifdef MACOSX
PLAF_OBJS = $(MACOSX_OBJS)
else
PLAF_OBJS = $(GENERIC_UNIX_OBJS)
endif
ifdef CONFIG
include $(CONFIG)
endif
OBJS = $(PLAF_OBJS) vm/array.o vm/bignum.o \
vm/s48_bignum.o \
vm/complex.o vm/error.o \
vm/factor.o vm/fixnum.o \
vm/float.o vm/gc.o \
vm/image.o vm/memory.o \
vm/misc.o vm/primitives.o \
vm/ratio.o vm/relocate.o \
vm/run.o \
vm/sbuf.o vm/stack.o \
vm/string.o vm/cards.o vm/vector.o \
vm/word.o vm/compiler.o \
vm/alien.o vm/dll.o \
vm/boolean.o \
OBJS = $(PLAF_OBJS) \
vm/alien.o \
vm/bignum.o \
vm/debug.o \
vm/hashtable.o \
vm/factor.o \
vm/ffi_test.o \
vm/image.o \
vm/io.o \
vm/wrapper.o \
vm/ffi_test.o
vm/math.o \
vm/memory.o \
vm/primitives.o \
vm/run.o \
vm/stack.o \
vm/types.o
default:
@echo "Run 'make' with one of the following parameters:"
@echo ""
@echo "bsd"
@echo "linux"
@echo "freebsd"
@echo "linux-x86"
@echo "linux-amd64"
@echo "linux-ppc"
@echo "macosx"
@echo "macosx-x86"
@echo "macosx-ppc"
@echo "solaris"
@echo "windows"
@echo ""
@ -91,17 +60,29 @@ default:
@echo ""
@echo "export SITE_CFLAGS=\"-march=pentium4 -ffast-math\""
bsd:
$(MAKE) $(BINARY) \
CFLAGS="$(DEFAULT_CFLAGS) -export-dynamic -pthread" \
LIBS="$(DEFAULT_LIBS) $(UI_LIBS)"
freebsd:
$(MAKE) $(BINARY) CONFIG=vm/Config.freebsd
macosx-ppc:
$(MAKE) $(BINARY) CONFIG=vm/Config.macosx.ppc
macosx-x86:
$(MAKE) $(BINARY) CONFIG=vm/Config.macosx
linux linux-x86 linux-amd64:
$(MAKE) $(BINARY) CONFIG=vm/Config.linux
$(STRIP) $(BINARY)
macosx:
$(MAKE) $(BINARY) \
CFLAGS="$(DEFAULT_CFLAGS)" \
LIBS="$(DEFAULT_LIBS) -framework Cocoa -framework OpenGL -L/usr/X11R6/lib/ -lfreetype" \
MACOSX=y
linux-ppc:
$(MAKE) $(BINARY) CONFIG=vm/Config.linux.ppc
$(STRIP) $(BINARY)
solaris solaris-x86 solaris-amd64:
$(MAKE) $(BINARY) CONFIG=vm/Config.solaris
$(STRIP) $(BINARY)
windows:
$(MAKE) $(BINARY) CONFIG=vm/Config.windows
macosx.app:
cp $(BINARY) $(BUNDLE)/Contents/MacOS/Factor
@ -138,29 +119,6 @@ macosx.dmg:
hdiutil create -srcfolder "$(DISK_IMAGE_DIR)" -fs HFS+ \
-volname "$(DISK_IMAGE_DIR)" "$(DISK_IMAGE)"
linux linux-x86 linux-amd64:
$(MAKE) $(BINARY) \
CFLAGS="$(DEFAULT_CFLAGS) -export-dynamic" \
LIBS="-ldl $(DEFAULT_LIBS) $(UNIX_UI_LIBS)"
$(STRIP) $(BINARY)
linux-ppc:
$(MAKE) $(BINARY) \
CFLAGS="$(DEFAULT_CFLAGS) -export-dynamic -mregnames" \
LIBS="-ldl $(DEFAULT_LIBS) $(UNIX_UI_LIBS)"
$(STRIP) $(BINARY)
solaris solaris-x86:
$(MAKE) $(BINARY) \
CFLAGS="$(DEFAULT_CFLAGS) -D_STDC_C99 -Drestrict=\"\" " \
LIBS="-ldl -lsocket -lnsl $(DEFAULT_LIBS) -R/opt/PM/lib -R/opt/csw/lib -R/usr/local/lib -R/usr/sfw/lib -R/usr/X11R6/lib -R/opt/sfw/lib $(UNIX_UI_LIBS)"
$(STRIP) $(BINARY)
windows:
$(MAKE) $(BINARY) \
CFLAGS="$(DEFAULT_CFLAGS) -DWINDOWS" \
LIBS="$(DEFAULT_LIBS)" WINDOWS=y
f: $(OBJS)
$(CC) $(LIBS) $(CFLAGS) -o $@$(PLAF_SUFFIX) $(OBJS)
@ -177,8 +135,3 @@ clean:
.m.o:
$(CC) -c $(CFLAGS) -o $@ $<
boot:
echo "USE: image \"$(ARCH)\" make-image bye" | ./f factor.image
./f boot.image.$(ARCH) $(BOOTSTRAP_FLAGS)

19
README.txt
View File

@ -22,6 +22,7 @@ Factor is fully supported on the following platforms:
Linux/x86
Linux/AMD64
Mac OS X/x86
Mac OS X/PowerPC
The following platforms should work, but are not tested on a
@ -32,7 +33,6 @@ regular basis:
Solaris/x86
Solaris/AMD64
Linux/PowerPC
Microsoft Windows 2000 or later
Please donate time or hardware if you wish to see Factor running on
other platforms.
@ -47,12 +47,13 @@ Factor requires gcc 3.4 or later. On x86, it /will not/ build using gcc
Run 'make' (or 'gmake' on non-Linux platforms) with one of the following
parameters to build the Factor runtime:
bsd
linux
freebsd
linux-x86
linux-amd64
linux-ppc
macosx
macosx-x86
macosx-ppc
solaris
windows
The following options can be given to make:
@ -137,14 +138,6 @@ this point), and the library source into a self-contained Factor.app.
Factor.app runs the UI when double-clicked and can be transported
between PowerPC Macs.
* Running Factor on Windows
On Windows, double-clicking f.exe will start running the Win32-based UI
with the factor.image in the same directory as the executable.
Bootstrap runs in a Windows command prompt, however there is no
terminal listener and after bootstrapping only the UI can be used.
* Source organization
doc/ - the developer's handbook, and various other bits and pieces

3
TODO.FACTOR.txt
View File

@ -7,11 +7,8 @@
- roundoff is still not quite right with tracks
- httpd search tools
tathi: hrm. wish I knew more about OpenGL.
[2:45pm] tathi: Factor's text display is a bit odd sometimes, until you mouse over (or click, if there's no "live" text)
[2:46pm] tathi: but the text display code looks good as far as I can tell
[2:48pm] tathi: it appears to be using the font metrics from the sprite tuple, but re-using the texture from the previous letter
[2:48pm] tathi: very odd
[2:59pm] tathi: hmm...and it looks like it's only be happening the first time you use a given character (from a given font face)
+ io:

6
contrib/README.txt
View File

@ -1,11 +1,11 @@
This directory contains Factor code that is not part of the core
library, but is useful enough to ship with the Factor distribution.
You can load these modules by typing:
Modules can be loaded from the listener:
REQUIRE: modulename
"modulename" require
in the listener.
Credits:
- aim -- AOL Instant Messenger client library (Doug Coleman)
- automata -- Graphics demo for the UI (Eduardo Cavazos)

4
vm/Config.freebsd Normal file
View File

@ -0,0 +1,4 @@
include vm/Config.unix
PLAF_OBJS += vm/genunix.o
CFLAGS += -export-dynamic -pthread
LIBS = -ldl -lm $(X11_UI_LIBS)

4
vm/Config.linux Normal file
View File

@ -0,0 +1,4 @@
include vm/Config.unix
PLAF_OBJS += vm/genunix.o
CFLAGS += -export-dynamic
LIBS = -ldl -lm $(X11_UI_LIBS)

3
vm/Config.linux.ppc Normal file
View File

@ -0,0 +1,3 @@
include vm/Config.linux
include vm/Config.ppc
CFLAGS += -mregnames

3
vm/Config.macosx Normal file
View File

@ -0,0 +1,3 @@
include vm/Config.unix
PLAF_OBJS += vm/os-macosx.o vm/mach_signal.o
LIBS= -lm -framework Cocoa -framework OpenGL -LFactor.app/Contents/Frameworks/ -lfreetype

2
vm/Config.macosx.ppc Normal file
View File

@ -0,0 +1,2 @@
include vm/Config.macosx
include vm/Config.ppc

1
vm/Config.ppc Normal file
View File

@ -0,0 +1 @@
PLAF_OBJS += vm/cpu-ppc.o

4
vm/Config.solaris Normal file
View File

@ -0,0 +1,4 @@
CFLAGS += -D_STDC_C99 -Drestrict=""
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)

1
vm/Config.unix Normal file
View File

@ -0,0 +1 @@
PLAF_OBJS = vm/os-unix.o

3
vm/Config.windows Normal file
View File

@ -0,0 +1,3 @@
CFLAGS += -DWINDOWS
LIBS = -lm
PLAF_SUFFIX = .exe

54
vm/alien.c
View File

@ -154,3 +154,57 @@ void box_value_pair(CELL x, CELL y)
put(AREF(array,1),y);
dpush(tag_object(array));
}
void primitive_dlopen(void)
{
DLL* dll;
F_STRING* path;
maybe_gc(sizeof(DLL));
path = untag_string(dpop());
dll = allot_object(DLL_TYPE,sizeof(DLL));
dll->path = tag_object(path);
ffi_dlopen(dll,true);
dpush(tag_object(dll));
}
void primitive_dlsym(void)
{
CELL dll;
F_STRING *sym;
DLL *d;
maybe_gc(0);
dll = dpop();
sym = untag_string(dpop());
if(dll == F)
d = NULL;
else
{
d = untag_dll(dll);
if(d->dll == NULL)
general_error(ERROR_EXPIRED,dll,F,true);
}
dpush(tag_cell((CELL)ffi_dlsym(d,sym,true)));
}
void primitive_dlclose(void)
{
ffi_dlclose(untag_dll(dpop()));
}
void fixup_dll(DLL* dll)
{
data_fixup(&dll->path);
ffi_dlopen(dll,false);
}
void collect_dll(DLL* dll)
{
copy_handle(&dll->path);
}

20
vm/alien.h
View File

@ -1,10 +1,3 @@
typedef struct {
CELL header;
CELL alien;
CELL displacement;
bool expired;
} ALIEN;
INLINE ALIEN* untag_alien_fast(CELL tagged)
{
return (ALIEN*)UNTAG(tagged);
@ -52,3 +45,16 @@ void primitive_set_alien_double(void);
DLLEXPORT void unbox_value_struct(void *dest, CELL size);
DLLEXPORT void box_value_struct(void *src, CELL size);
DLLEXPORT void box_value_pair(CELL x, CELL y);
INLINE DLL *untag_dll(CELL tagged)
{
type_check(DLL_TYPE,tagged);
return (DLL*)UNTAG(tagged);
}
void primitive_dlopen(void);
void primitive_dlsym(void);
void primitive_dlclose(void);
void fixup_dll(DLL* dll);
void collect_dll(DLL* dll);

154
vm/array.c
View File

@ -1,154 +0,0 @@
#include "factor.h"
/* the array is full of undefined data, and must be correctly filled before the
next GC. size is in cells */
F_ARRAY *allot_array(CELL type, F_FIXNUM capacity)
{
F_ARRAY *array;
if(capacity < 0)
general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_integer(capacity),F,true);
array = allot_object(type,array_size(capacity));
array->capacity = tag_fixnum(capacity);
return array;
}
/* make a new array with an initial element */
F_ARRAY *array(CELL type, F_FIXNUM capacity, CELL fill)
{
int i;
F_ARRAY* array = allot_array(type, capacity);
for(i = 0; i < capacity; i++)
put(AREF(array,i),fill);
return array;
}
/* size is in bytes this time */
F_ARRAY *byte_array(F_FIXNUM size)
{
F_FIXNUM byte_size = (size + sizeof(CELL) - 1) / sizeof(CELL);
return array(BYTE_ARRAY_TYPE,byte_size,0);
}
/* push a new array on the stack */
void primitive_array(void)
{
CELL initial;
F_FIXNUM size;
maybe_gc(0);
initial = dpop();
size = to_fixnum(dpop());
dpush(tag_object(array(ARRAY_TYPE,size,initial)));
}
/* push a new tuple on the stack */
void primitive_tuple(void)
{
CELL class;
F_FIXNUM size;
F_ARRAY *tuple;
maybe_gc(0);
size = to_fixnum(dpop());
class = dpop();
tuple = array(TUPLE_TYPE,size,F);
put(AREF(tuple,0),class);
dpush(tag_object(tuple));
}
/* push a new byte on the stack */
void primitive_byte_array(void)
{
F_FIXNUM size = to_fixnum(dpop());
maybe_gc(0);
dpush(tag_object(byte_array(size)));
}
/* push a new quotation on the stack */
void primitive_quotation(void)
{
F_FIXNUM size;
maybe_gc(0);
size = to_fixnum(dpop());
dpush(tag_object(array(QUOTATION_TYPE,size,F)));
}
CELL make_array_2(CELL v1, CELL v2)
{
F_ARRAY *a = array(ARRAY_TYPE,2,F);
put(AREF(a,0),v1);
put(AREF(a,1),v2);
return tag_object(a);
}
CELL make_array_4(CELL v1, CELL v2, CELL v3, CELL v4)
{
F_ARRAY *a = array(ARRAY_TYPE,4,F);
put(AREF(a,0),v1);
put(AREF(a,1),v2);
put(AREF(a,2),v3);
put(AREF(a,3),v4);
return tag_object(a);
}
F_ARRAY* resize_array(F_ARRAY* array, F_FIXNUM capacity, CELL fill)
{
int i;
F_ARRAY* new_array;
CELL to_copy = array_capacity(array);
if(capacity < to_copy)
to_copy = capacity;
new_array = allot_array(untag_header(array->header),capacity);
memcpy(new_array + 1,array + 1,to_copy * CELLS);
for(i = to_copy; i < capacity; i++)
put(AREF(new_array,i),fill);
return new_array;
}
void primitive_resize_array(void)
{
F_ARRAY* array;
F_FIXNUM capacity = to_fixnum(dpeek2());
maybe_gc(array_size(capacity));
array = untag_array(dpop());
drepl(tag_object(resize_array(array,capacity,F)));
}
void primitive_array_to_tuple(void)
{
CELL array = dpeek();
type_check(ARRAY_TYPE,array);
array = clone(array);
put(SLOT(UNTAG(array),0),tag_header(TUPLE_TYPE));
drepl(array);
}
void primitive_tuple_to_array(void)
{
CELL tuple = dpeek();
type_check(TUPLE_TYPE,tuple);
tuple = clone(tuple);
put(SLOT(UNTAG(tuple),0),tag_header(ARRAY_TYPE));
drepl(tuple);
}
/* image loading */
void fixup_array(F_ARRAY* array)
{
int i = 0; CELL capacity = array_capacity(array);
for(i = 0; i < capacity; i++)
data_fixup((void*)AREF(array,i));
}
/* GC */
void collect_array(F_ARRAY* array)
{
int i = 0; CELL capacity = array_capacity(array);
for(i = 0; i < capacity; i++)
copy_handle((void*)AREF(array,i));
}

54
vm/array.h
View File

@ -1,54 +0,0 @@
typedef struct {
CELL header;
/* tagged */
CELL capacity;
} F_ARRAY;
INLINE F_ARRAY* untag_array_fast(CELL tagged)
{
return (F_ARRAY*)UNTAG(tagged);
}
INLINE F_ARRAY* untag_array(CELL tagged)
{
type_check(ARRAY_TYPE,tagged);
return untag_array_fast(tagged);
}
INLINE F_ARRAY* untag_byte_array_fast(CELL tagged)
{
return (F_ARRAY*)UNTAG(tagged);
}
INLINE CELL array_size(CELL size)
{
return align8(sizeof(F_ARRAY) + size * CELLS);
}
F_ARRAY *allot_array(CELL type, F_FIXNUM capacity);
F_ARRAY *array(CELL type, F_FIXNUM capacity, CELL fill);
F_ARRAY *byte_array(F_FIXNUM size);
CELL make_array_2(CELL v1, CELL v2);
CELL make_array_4(CELL v1, CELL v2, CELL v3, CELL v4);
void primitive_array(void);
void primitive_tuple(void);
void primitive_byte_array(void);
void primitive_quotation(void);
F_ARRAY *resize_array(F_ARRAY* array, F_FIXNUM capacity, CELL fill);
void primitive_resize_array(void);
void primitive_array_to_tuple(void);
void primitive_tuple_to_array(void);
#define AREF(array,index) ((CELL)(array) + sizeof(F_ARRAY) + (index) * CELLS)
#define UNAREF(array,ptr) (((CELL)(ptr)-(CELL)(array)-sizeof(F_ARRAY)) / CELLS)
INLINE CELL array_capacity(F_ARRAY* array)
{
return untag_fixnum_fast(array->capacity);
}
void fixup_array(F_ARRAY* array);
void collect_array(F_ARRAY* array);

1967
vm/bignum.c
View File

File diff suppressed because it is too large Load Diff

209
vm/bignum.h
View File

@ -1,69 +1,156 @@
CELL bignum_zero;
CELL bignum_pos_one;
CELL bignum_neg_one;
/* -*-C-*-
INLINE F_ARRAY* untag_bignum_fast(CELL tagged)
$Id: s48_bignum.h,v 1.13 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. */
/* External Interface to Bignum Code */
/* The `unsigned long' type is used for the conversion procedures
`bignum_to_long' and `long_to_bignum'. Older implementations of C
don't support this type; if you have such an implementation you can
disable these procedures using the following flag (alternatively
you could write alternate versions that don't require this type). */
/* #define BIGNUM_NO_ULONG */
typedef F_ARRAY * bignum_type;
#define BIGNUM_OUT_OF_BAND ((bignum_type) 0)
enum bignum_comparison
{
return (F_ARRAY*)UNTAG(tagged);
}
bignum_comparison_equal = 0,
bignum_comparison_less = -1,
bignum_comparison_greater = 1
};
INLINE CELL tag_bignum(F_ARRAY* bignum)
{
return RETAG(bignum,BIGNUM_TYPE);
}
typedef void * bignum_procedure_context;
int s48_bignum_equal_p(bignum_type, bignum_type);
enum bignum_comparison s48_bignum_test(bignum_type);
enum bignum_comparison s48_bignum_compare(bignum_type, bignum_type);
bignum_type s48_bignum_add(bignum_type, bignum_type);
bignum_type s48_bignum_subtract(bignum_type, bignum_type);
bignum_type s48_bignum_negate(bignum_type);
bignum_type s48_bignum_multiply(bignum_type, bignum_type);
void
s48_bignum_divide(bignum_type numerator, bignum_type denominator,
bignum_type * quotient, bignum_type * remainder);
bignum_type s48_bignum_quotient(bignum_type, bignum_type);
bignum_type s48_bignum_remainder(bignum_type, bignum_type);
DLLEXPORT bignum_type s48_fixnum_to_bignum(F_FIXNUM);
DLLEXPORT bignum_type s48_cell_to_bignum(CELL);
DLLEXPORT bignum_type s48_long_to_bignum(long);
DLLEXPORT bignum_type s48_long_long_to_bignum(s64 n);
DLLEXPORT bignum_type s48_ulong_long_to_bignum(u64 n);
DLLEXPORT bignum_type s48_ulong_to_bignum(unsigned long);
DLLEXPORT bignum_type s48_fixnum_pair_to_bignum(CELL x, F_FIXNUM y);
F_FIXNUM s48_bignum_to_fixnum(bignum_type);
CELL s48_bignum_to_cell(bignum_type);
long s48_bignum_to_long(bignum_type);
unsigned long s48_bignum_to_ulong(bignum_type);
s64 s48_bignum_to_long_long(bignum_type);
u64 s48_bignum_to_ulong_long(bignum_type);
bignum_type s48_double_to_bignum(double);
double s48_bignum_to_double(bignum_type);
int s48_bignum_fits_in_word_p(bignum_type, long word_length,
int twos_complement_p);
bignum_type s48_bignum_length_in_bits(bignum_type);
bignum_type s48_bignum_length_upper_limit(void);
bignum_type s48_digit_stream_to_bignum
(unsigned int n_digits,
unsigned int (*producer(bignum_procedure_context)),
bignum_procedure_context context,
unsigned int radix,
int negative_p);
long s48_bignum_max_digit_stream_radix(void);
CELL to_cell(CELL x);
F_ARRAY* to_bignum(CELL tagged);
void primitive_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_divfloat(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);
/* Added bitwise operators. */
INLINE CELL tag_integer(F_FIXNUM x)
{
if(x < FIXNUM_MIN || x > FIXNUM_MAX)
return tag_bignum(s48_fixnum_to_bignum(x));
else
return tag_fixnum(x);
}
DLLEXPORT bignum_type s48_bignum_bitwise_not(bignum_type),
s48_bignum_arithmetic_shift(bignum_type, long),
s48_bignum_bitwise_and(bignum_type, bignum_type),
s48_bignum_bitwise_ior(bignum_type, bignum_type),
s48_bignum_bitwise_xor(bignum_type, bignum_type);
INLINE CELL tag_cell(CELL x)
{
if(x > FIXNUM_MAX)
return tag_bignum(s48_cell_to_bignum(x));
else
return tag_fixnum(x);
}
int s48_bignum_oddp(bignum_type);
long s48_bignum_bit_count(bignum_type);
/* FFI calls this */
DLLEXPORT void box_signed_cell(F_FIXNUM integer);
DLLEXPORT F_FIXNUM unbox_signed_cell(void);
/* 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 bignum_allocate(bignum_length_type, int);
bignum_type bignum_allocate_zeroed(bignum_length_type, int);
bignum_type bignum_shorten_length(bignum_type, bignum_length_type);
bignum_type bignum_trim(bignum_type);
bignum_type bignum_copy(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);
/* Unused
void bignum_destructive_zero(bignum_type);
*/
DLLEXPORT void box_unsigned_cell(CELL cell);
DLLEXPORT F_FIXNUM unbox_unsigned_cell(void);
DLLEXPORT void box_signed_4(s32 n);
DLLEXPORT s32 unbox_signed_4(void);
DLLEXPORT void box_unsigned_4(u32 n);
DLLEXPORT u32 unbox_unsigned_4(void);
DLLEXPORT void box_signed_8(s64 n);
DLLEXPORT s64 unbox_signed_8(void);
DLLEXPORT void box_unsigned_8(u64 n);
DLLEXPORT u64 unbox_unsigned_8(void);
/* Added for bitwise operations. */
bignum_type bignum_magnitude_ash(bignum_type arg1, long 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);
long bignum_unsigned_logcount(bignum_type arg);
int bignum_unsigned_logbitp(int shift, bignum_type bignum);

0
vm/s48_bignumint.h → vm/bignumint.h
View File

13
vm/boolean.c
View File

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

7
vm/boolean.h
View File

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

66
vm/cards.c
View File

@ -1,66 +0,0 @@
#include "factor.h"
/* scan all the objects in the card */
INLINE void collect_card(CARD *ptr, CELL here)
{
CARD c = *ptr;
CELL offset = (c & CARD_BASE_MASK);
CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + offset;
CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1);
if(offset == 0x7f)
{
if(c == 0xff)
critical_error("bad card",(CELL)ptr);
else
return;
}
while(card_scan < card_end && card_scan < here)
card_scan = collect_next(card_scan);
cards_scanned++;
}
INLINE void collect_gen_cards(CELL gen)
{
CARD *ptr = ADDR_TO_CARD(generations[gen].base);
CELL here = generations[gen].here;
CARD *last_card = ADDR_TO_CARD(here);
if(generations[gen].here == generations[gen].limit)
last_card--;
for(; ptr <= last_card; ptr++)
{
if(card_marked(*ptr))
collect_card(ptr,here);
}
}
void unmark_cards(CELL from, CELL to)
{
CARD *ptr = ADDR_TO_CARD(generations[from].base);
CARD *last_card = ADDR_TO_CARD(generations[to].here);
if(generations[to].here == generations[to].limit)
last_card--;
for(; ptr <= last_card; ptr++)
unmark_card(ptr);
}
void clear_cards(CELL from, CELL to)
{
/* NOTE: reverse order due to heap layout. */
CARD *last_card = ADDR_TO_CARD(generations[from].limit);
CARD *ptr = ADDR_TO_CARD(generations[to].base);
for(; ptr < last_card; ptr++)
clear_card(ptr);
}
/* scan cards in all generations older than the one being collected */
void collect_cards(CELL gen)
{
int i;
for(i = gen + 1; i < gen_count; i++)
collect_gen_cards(i);
}

71
vm/cards.h
View File

@ -1,71 +0,0 @@
CELL heap_start;
CELL heap_end;
/* 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.
*/
#define CARD_MARK_MASK 0x80
#define CARD_BASE_MASK 0x7f
typedef u8 CARD;
CARD *cards;
CARD *cards_end;
/* A card is 16 bytes (128 bits), 5 address bits per card.
it is important that 7 bits is sufficient to represent every
offset within the card */
#define CARD_SIZE 128
#define CARD_BITS 7
#define ADDR_CARD_MASK (CARD_SIZE-1)
INLINE CARD card_marked(CARD c)
{
return c & CARD_MARK_MASK;
}
INLINE void unmark_card(CARD *c)
{
*c &= CARD_BASE_MASK;
}
INLINE void clear_card(CARD *c)
{
*c = CARD_BASE_MASK; /* invalid value */
}
INLINE u8 card_base(CARD c)
{
return c & CARD_BASE_MASK;
}
#define ADDR_TO_CARD(a) (CARD*)(((CELL)a >> CARD_BITS) + cards_offset)
#define CARD_TO_ADDR(c) (CELL*)(((CELL)c - cards_offset)<<CARD_BITS)
/* this is an inefficient write barrier. compiled definitions use a more
efficient one hand-coded in assembly. 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)
{
CARD *c = ADDR_TO_CARD(address);
*c |= CARD_MARK_MASK;
}
/* we need to remember the first object allocated in the card */
INLINE void allot_barrier(CELL address)
{
CARD *ptr = ADDR_TO_CARD(address);
CARD c = *ptr;
CELL b = card_base(c);
CELL a = (address & ADDR_CARD_MASK);
*ptr = (card_marked(c) | ((b < a) ? b : a));
}
void unmark_cards(CELL from, CELL to);
void clear_cards(CELL from, CELL to);
void collect_cards(CELL gen);

50
vm/compiler.c
View File

@ -1,50 +0,0 @@
#include "factor.h"
void init_compiler(CELL size)
{
compiling.base = compiling.here = (CELL)(alloc_bounded_block(size)->start);
if(compiling.base == 0)
fatal_error("Cannot allocate code heap",size);
compiling.limit = compiling.base + size;
last_flush = compiling.base;
}
void primitive_compiled_offset(void)
{
box_unsigned_cell(compiling.here);
}
void primitive_set_compiled_offset(void)
{
CELL offset = unbox_unsigned_cell();
compiling.here = offset;
if(compiling.here >= compiling.limit)
{
fprintf(stderr,"Code space exhausted\n");
factorbug();
}
}
void primitive_add_literal(void)
{
CELL object = dpeek();
CELL offset = literal_top;
put(literal_top,object);
literal_top += CELLS;
if(literal_top >= literal_max)
critical_error("Too many compiled literals",literal_top);
drepl(tag_cell(offset));
}
void primitive_flush_icache(void)
{
flush_icache((void*)last_flush,compiling.here - last_flush);
last_flush = compiling.here;
}
void collect_literals(void)
{
CELL i;
for(i = compiling.base; i < literal_top; i += CELLS)
copy_handle((CELL*)i);
}

30
vm/compiler.h
View File

@ -1,30 +0,0 @@
/* The compiled code heap is structured into blocks. */
typedef struct
{
CELL header; /* = COMPILED_HEADER */
CELL code_length;
CELL reloc_length; /* see relocate.h */
} F_COMPILED;
#define COMPILED_HEADER 0x01c3babe
ZONE compiling;
CELL literal_top;
CELL literal_max;
void init_compiler(CELL size);
void primitive_compiled_offset(void);
void primitive_set_compiled_offset(void);
void primitive_add_literal(void);
void collect_literals(void);
#ifdef FACTOR_PPC
void flush_icache(void *start, int len);
#else
INLINE void flush_icache(void *start, int len) {}
#endif
CELL last_flush;
void primitive_flush_icache(void);

28
vm/complex.c
View File

@ -1,28 +0,0 @@
#include "factor.h"
void primitive_from_rect(void)
{
CELL real, imaginary;
F_COMPLEX* complex;
maybe_gc(sizeof(F_COMPLEX));
imaginary = dpop();
real = dpop();
complex = allot_object(COMPLEX_TYPE,sizeof(F_COMPLEX));
complex->real = real;
complex->imaginary = imaginary;
dpush(RETAG(complex,COMPLEX_TYPE));
}
void fixup_complex(F_COMPLEX* complex)
{
data_fixup(&complex->real);
data_fixup(&complex->imaginary);
}
void collect_complex(F_COMPLEX* complex)
{
copy_handle(&complex->real);
copy_handle(&complex->imaginary);
}

9
vm/complex.h
View File

@ -1,9 +0,0 @@
typedef struct {
CELL header;
CELL real;
CELL imaginary;
} F_COMPLEX;
void primitive_from_rect(void);
void fixup_complex(F_COMPLEX* complex);
void collect_complex(F_COMPLEX* complex);

7
vm/cpu-amd64.h Normal file
View File

@ -0,0 +1,7 @@
#define FACTOR_CPU_STRING "amd64"
register CELL ds asm("r14");
register CELL rs asm("r15");
register CELL cards_offset asm("r13");
INLINE void flush_icache(void *start, int len) {}

7
vm/cpu-ppc.h Normal file
View File

@ -0,0 +1,7 @@
#define FACTOR_CPU_STRING "ppc"
register CELL ds asm("r14");
register CELL rs asm("r15");
register CELL cards_offset asm("r16");
void flush_icache(void *start, int len);

7
vm/cpu-x86.h Normal file
View File

@ -0,0 +1,7 @@
#define FACTOR_CPU_STRING "ppc"
register CELL ds asm("esi");
register CELL rs asm("edi");
CELL cards_offset;
INLINE void flush_icache(void *start, int len) {}

11
vm/debug.c
View File

@ -145,12 +145,11 @@ void dump_generations(void)
void factorbug(void)
{
#ifndef WIN32
fcntl(0,F_SETFL,0);
fcntl(1,F_SETFL,0);
#endif
reset_stdio();
fprintf(stderr," Front end processor commands:\n");
fprintf(stderr,"A fatal error has occurred and Factor cannot continue.\n");
fprintf(stderr,"The low-level debugger has been started to help diagnose the problem.\n");
fprintf(stderr," Basic commands:\n");
fprintf(stderr,"t -- throw exception in Factor\n");
fprintf(stderr,"q -- continue executing Factor\n");
fprintf(stderr,"im -- save image to fep.image\n");
@ -172,7 +171,7 @@ void factorbug(void)
{
char cmd[1024];
fprintf(stderr,"fep> ");
fprintf(stderr,"READY\n");
fflush(stdout);
if(scanf("%1000s",cmd) <= 0)

55
vm/dll.c
View File

@ -1,55 +0,0 @@
#include "factor.h"
void primitive_dlopen(void)
{
DLL* dll;
F_STRING* path;
maybe_gc(sizeof(DLL));
path = untag_string(dpop());
dll = allot_object(DLL_TYPE,sizeof(DLL));
dll->path = tag_object(path);
ffi_dlopen(dll,true);
dpush(tag_object(dll));
}
void primitive_dlsym(void)
{
CELL dll;
F_STRING *sym;
DLL *d;
maybe_gc(0);
dll = dpop();
sym = untag_string(dpop());
if(dll == F)
d = NULL;
else
{
d = untag_dll(dll);
if(d->dll == NULL)
general_error(ERROR_EXPIRED,dll,F,true);
}
dpush(tag_cell((CELL)ffi_dlsym(d,sym,true)));
}
void primitive_dlclose(void)
{
ffi_dlclose(untag_dll(dpop()));
}
void fixup_dll(DLL* dll)
{
data_fixup(&dll->path);
ffi_dlopen(dll,false);
}
void collect_dll(DLL* dll)
{
copy_handle(&dll->path);
}

26
vm/dll.h
View File

@ -1,26 +0,0 @@
typedef struct {
CELL header;
/* tagged string */
CELL path;
/* OS-specific handle */
void* dll;
} DLL;
INLINE DLL *untag_dll(CELL tagged)
{
type_check(DLL_TYPE,tagged);
return (DLL*)UNTAG(tagged);
}
void init_ffi(void);
void ffi_dlopen(DLL *dll, bool error);
void *ffi_dlsym(DLL *dll, F_STRING *symbol, bool error);
void ffi_dlclose(DLL *dll);
void primitive_dlopen(void);
void primitive_dlsym(void);
void primitive_dlclose(void);
void fixup_dll(DLL* dll);
void collect_dll(DLL* dll);

67
vm/error.c
View File

@ -1,67 +0,0 @@
#include "factor.h"
void fatal_error(char* msg, CELL tagged)
{
fprintf(stderr,"Fatal error: %s %ld\n",msg,tagged);
exit(1);
}
void critical_error(char* msg, CELL tagged)
{
fprintf(stderr,"Critical error: %s %ld\n",msg,tagged);
factorbug();
}
void early_error(CELL error)
{
if(userenv[BREAK_ENV] == F)
{
/* Crash at startup */
fprintf(stderr,"Error during startup: ");
print_obj(error);
fprintf(stderr,"\n");
factorbug();
}
}
void throw_error(CELL error, bool keep_stacks)
{
early_error(error);
throwing = true;
thrown_error = error;
thrown_keep_stacks = keep_stacks;
thrown_ds = ds;
thrown_rs = rs;
/* Return to run() method */
LONGJMP(stack_chain->toplevel,1);
}
void primitive_throw(void)
{
throw_error(dpop(),true);
}
void primitive_die(void)
{
factorbug();
}
void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2, bool keep_stacks)
{
throw_error(make_array_4(userenv[ERROR_ENV],
tag_fixnum(error),arg1,arg2),keep_stacks);
}
/* It is not safe to access 'ds' from a signal handler, so we just not
touch it */
void signal_error(int signal)
{
general_error(ERROR_SIGNAL,tag_fixnum(signal),F,false);
}
void type_error(CELL type, CELL tagged)
{
general_error(ERROR_TYPE,tag_fixnum(type),tagged,true);
}

41
vm/error.h
View File

@ -1,41 +0,0 @@
typedef enum
{
ERROR_EXPIRED,
ERROR_IO,
ERROR_UNDEFINED_WORD,
ERROR_TYPE,
ERROR_SIGNAL,
ERROR_NEGATIVE_ARRAY_SIZE,
ERROR_C_STRING,
ERROR_FFI,
ERROR_HEAP_SCAN,
ERROR_UNDEFINED_SYMBOL,
ERROR_USER_INTERRUPT,
ERROR_DS_UNDERFLOW,
ERROR_DS_OVERFLOW,
ERROR_RS_UNDERFLOW,
ERROR_RS_OVERFLOW,
ERROR_CS_UNDERFLOW,
ERROR_CS_OVERFLOW,
ERROR_OBJECTIVE_C
} F_ERRORTYPE;
/* Are we throwing an error? */
bool throwing;
/* When throw_error throws an error, it sets this global and
longjmps back to the top-level. */
CELL thrown_error;
CELL thrown_keep_stacks;
/* Since longjmp restores registers, we must save all these values. */
CELL thrown_ds;
CELL thrown_rs;
void fatal_error(char* msg, CELL tagged);
void critical_error(char* msg, CELL tagged);
void throw_error(CELL error, bool keep_stacks);
void early_error(CELL error);
void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2, bool keep_stacks);
void signal_error(int signal);
void type_error(CELL type, CELL tagged);
void primitive_throw(void);
void primitive_die(void);

23
vm/factor.c
View File

@ -38,22 +38,6 @@ INLINE bool factor_arg(const char* str, const char* arg, CELL* value)
return false;
}
void usage(void)
{
printf("Usage: factor <image file> [ parameters ... ]\n");
printf("Runtime options -- n is a number:\n");
printf(" -D=n Data stack size, kilobytes\n");
printf(" -R=n Retain stack size, kilobytes\n");
printf(" -C=n Call stack size, kilobytes\n");
printf(" -G=n Number of generations, must be >= 2\n");
printf(" -Y=n Size of n-1 youngest generations, megabytes\n");
printf(" -A=n Size of tenured and semi-spaces, megabytes\n");
printf(" -X=n Code heap size, megabytes\n");
printf("Other options are handled by the Factor library.\n");
printf("See the documentation for details.\n");
printf("Send bug reports to Slava Pestov <slava@factorcode.org>.\n");
}
int main(int argc, char** argv)
{
const char *image = NULL;
@ -82,13 +66,6 @@ int main(int argc, char** argv)
if(factor_arg(argv[i],"-A=%d",&aging_size)) continue;
if(factor_arg(argv[i],"-X=%d",&code_size)) continue;
if(strncmp(argv[i],"+",1) == 0)
{
printf("Unknown option: %s\n",argv[i]);
usage();
return 1;
}
if(strncmp(argv[i],"-",1) != 0 && image == NULL)
image = argv[1];
}

113
vm/factor.h
View File

@ -1,66 +1,6 @@
#ifndef __FACTOR_H__
#define __FACTOR_H__
#include "platform.h"
#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 FIXNUM_MAX (((F_FIXNUM)1 << (WORD_SIZE - TAG_BITS - 1)) - 1)
#define FIXNUM_MIN (-((F_FIXNUM)1 << (WORD_SIZE - TAG_BITS - 1)))
/* must always be 16 bits */
#define CHARS ((signed)sizeof(u16))
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;
CELL cs;
#if defined(FACTOR_X86)
register CELL ds asm("esi");
register CELL rs asm("edi");
CELL cards_offset;
#elif defined(FACTOR_PPC)
register CELL ds asm("r14");
register CELL rs asm("r15");
register CELL cards_offset asm("r16");
#elif defined(FACTOR_AMD64)
register CELL ds asm("r14");
register CELL rs asm("r15");
register CELL cards_offset asm("r13");
#else
CELL ds;
CELL rs;
CELL cards_offset;
#endif
/* TAGGED currently executing quotation */
CELL callframe;
/* UNTAGGED currently executing word in quotation */
CELL callframe_scan;
/* UNTAGGED end of quotation */
CELL callframe_end;
#include <errno.h>
#include <fcntl.h>
#include <limits.h>
@ -72,62 +12,21 @@ CELL callframe_end;
#include <stdlib.h>
#include <string.h>
#include <time.h>
#include <sys/param.h>
#ifdef WIN32
#include <windows.h>
#include <ctype.h>
/* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */
#define EPOCH_OFFSET 0x019db1ded53e8000LL
#else
#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>
#endif
#include "layouts.h"
#include "platform.h"
#include "debug.h"
#include "error.h"
#include "cards.h"
#include "memory.h"
#include "gc.h"
#include "boolean.h"
#include "word.h"
#include "run.h"
#include "signal.h"
#include "fixnum.h"
#include "array.h"
#include "s48_bignumint.h"
#include "s48_bignum.h"
#include "memory.h"
#include "bignumint.h"
#include "bignum.h"
#include "ratio.h"
#include "float.h"
#include "complex.h"
#include "string.h"
#include "misc.h"
#include "sbuf.h"
#include "math.h"
#include "types.h"
#include "io.h"
#include "file.h"
#include "image.h"
#include "primitives.h"
#include "vector.h"
#include "hashtable.h"
#include "stack.h"
#include "compiler.h"
#include "relocate.h"
#include "alien.h"
#include "dll.h"
#include "wrapper.h"
void usage(void);
void early_init(void);
const char *default_image_path(void);
#endif /* __FACTOR_H__ */

7
vm/file.h
View File

@ -1,7 +0,0 @@
#define FILE_MODE 0600
void primitive_open_file(void);
void primitive_stat(void);
void primitive_read_dir(void);
void primitive_cwd(void);
void primitive_cd(void);

220
vm/fixnum.c
View File

@ -1,220 +0,0 @@
#include "factor.h"
F_FIXNUM to_fixnum(CELL tagged)
{
F_RATIO* r;
F_ARRAY* x;
F_ARRAY* y;
F_FLOAT* f;
switch(TAG(tagged))
{
case FIXNUM_TYPE:
return untag_fixnum_fast(tagged);
case BIGNUM_TYPE:
return (F_FIXNUM)s48_bignum_to_fixnum((F_ARRAY*)UNTAG(tagged));
case RATIO_TYPE:
r = (F_RATIO*)UNTAG(tagged);
x = to_bignum(r->numerator);
y = to_bignum(r->denominator);
return to_fixnum(tag_bignum(s48_bignum_quotient(x,y)));
case FLOAT_TYPE:
f = (F_FLOAT*)UNTAG(tagged);
return (F_FIXNUM)f->n;
default:
type_error(FIXNUM_TYPE,tagged);
return -1; /* can't happen */
}
}
void primitive_to_fixnum(void)
{
drepl(tag_fixnum(to_fixnum(dpeek())));
}
#define POP_FIXNUMS(x,y) \
F_FIXNUM x, y; \
y = untag_fixnum_fast(dpop()); \
x = untag_fixnum_fast(dpop());
/* The fixnum arithmetic operations defined in C are relatively slow.
The Factor compiler has optimized assembly intrinsics for all these
operations. */
void primitive_fixnum_add(void)
{
POP_FIXNUMS(x,y)
box_signed_cell(x + y);
}
void primitive_fixnum_add_fast(void)
{
POP_FIXNUMS(x,y)
dpush(tag_fixnum(x + y));
}
void primitive_fixnum_subtract(void)
{
POP_FIXNUMS(x,y)
box_signed_cell(x - y);
}
void primitive_fixnum_subtract_fast(void)
{
POP_FIXNUMS(x,y)
dpush(tag_fixnum(x - y));
}
/**
* Multiply two integers, and trap overflow.
* Thanks to David Blaikie (The_Vulture from freenode #java) for the hint.
*/
void primitive_fixnum_multiply(void)
{
POP_FIXNUMS(x,y)
if(x == 0 || y == 0)
dpush(tag_fixnum(0));
else
{
F_FIXNUM prod = x * y;
/* if this is not equal, we have overflow */
if(prod / x == y)
box_signed_cell(prod);
else
{
dpush(tag_bignum(
s48_bignum_multiply(
s48_fixnum_to_bignum(x),
s48_fixnum_to_bignum(y))));
}
}
}
void primitive_fixnum_divint(void)
{
POP_FIXNUMS(x,y)
box_signed_cell(x / y);
}
void primitive_fixnum_divfloat(void)
{
POP_FIXNUMS(x,y)
dpush(tag_float((double)x / (double)y));
}
void primitive_fixnum_divmod(void)
{
POP_FIXNUMS(x,y)
box_signed_cell(x / y);
box_signed_cell(x % y);
}
void primitive_fixnum_mod(void)
{
POP_FIXNUMS(x,y)
dpush(tag_fixnum(x % y));
}
void primitive_fixnum_and(void)
{
POP_FIXNUMS(x,y)
dpush(tag_fixnum(x & y));
}
void primitive_fixnum_or(void)
{
POP_FIXNUMS(x,y)
dpush(tag_fixnum(x | y));
}
void primitive_fixnum_xor(void)
{
POP_FIXNUMS(x,y)
dpush(tag_fixnum(x ^ y));
}
/*
* Note the hairy overflow check.
* 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.
*/
void primitive_fixnum_shift(void)
{
POP_FIXNUMS(x,y)
if(x == 0 || y == 0)
{
dpush(tag_fixnum(x));
return;
}
else if(y < 0)
{
if(y <= -WORD_SIZE)
dpush(x < 0 ? tag_fixnum(-1) : tag_fixnum(0));
else
dpush(tag_fixnum(x >> -y));
return;
}
else if(y < WORD_SIZE - TAG_BITS)
{
F_FIXNUM mask = -(1 << (WORD_SIZE - 1 - TAG_BITS - y));
if((x > 0 && (x & mask) == 0) || (x & mask) == mask)
{
dpush(tag_fixnum(x << y));
return;
}
}
dpush(tag_bignum(s48_bignum_arithmetic_shift(
s48_fixnum_to_bignum(x),y)));
}
void primitive_fixnum_less(void)
{
POP_FIXNUMS(x,y)
box_boolean(x < y);
}
void primitive_fixnum_lesseq(void)
{
POP_FIXNUMS(x,y)
box_boolean(x <= y);
}
void primitive_fixnum_greater(void)
{
POP_FIXNUMS(x,y)
box_boolean(x > y);
}
void primitive_fixnum_greatereq(void)
{
POP_FIXNUMS(x,y)
box_boolean(x >= y);
}
void primitive_fixnum_not(void)
{
drepl(tag_fixnum(~untag_fixnum_fast(dpeek())));
}
#define DEFBOX(name,type) \
void name (type integer) \
{ \
dpush(tag_integer(integer)); \
}
#define DEFUNBOX(name,type) \
type name(void) \
{ \
return to_fixnum(dpop()); \
}
DEFBOX(box_signed_1, signed char)
DEFBOX(box_signed_2, signed short)
DEFBOX(box_unsigned_1, unsigned char)
DEFBOX(box_unsigned_2, unsigned short)
DEFUNBOX(unbox_signed_1, signed char)
DEFUNBOX(unbox_signed_2, signed short)
DEFUNBOX(unbox_unsigned_1, unsigned char)
DEFUNBOX(unbox_unsigned_2, unsigned short)

39
vm/fixnum.h
View File

@ -1,39 +0,0 @@
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);
}
F_FIXNUM to_fixnum(CELL tagged);
void primitive_to_fixnum(void);
void primitive_fixnum_add(void);
void primitive_fixnum_subtract(void);
void primitive_fixnum_add_fast(void);
void primitive_fixnum_subtract_fast(void);
void primitive_fixnum_multiply(void);
void primitive_fixnum_divint(void);
void primitive_fixnum_divfloat(void);
void primitive_fixnum_divmod(void);
void primitive_fixnum_mod(void);
void primitive_fixnum_and(void);
void primitive_fixnum_or(void);
void primitive_fixnum_xor(void);
void primitive_fixnum_shift(void);
void primitive_fixnum_less(void);
void primitive_fixnum_lesseq(void);
void primitive_fixnum_greater(void);
void primitive_fixnum_greatereq(void);
void primitive_fixnum_not(void);
DLLEXPORT void box_signed_1(signed char integer);
DLLEXPORT void box_signed_2(signed short integer);
DLLEXPORT void box_unsigned_1(unsigned char integer);
DLLEXPORT void box_unsigned_2(unsigned short integer);
DLLEXPORT signed char unbox_signed_1(void);
DLLEXPORT signed short unbox_signed_2(void);
DLLEXPORT unsigned char unbox_unsigned_1(void);
DLLEXPORT unsigned short unbox_unsigned_2(void);

244
vm/float.c
View File

@ -1,244 +0,0 @@
#include "factor.h"
double to_float(CELL tagged)
{
F_RATIO* r;
double x;
double y;
switch(TAG(tagged))
{
case FIXNUM_TYPE:
return (double)untag_fixnum_fast(tagged);
case BIGNUM_TYPE:
return s48_bignum_to_double((F_ARRAY*)UNTAG(tagged));
case RATIO_TYPE:
r = (F_RATIO*)UNTAG(tagged);
x = to_float(r->numerator);
y = to_float(r->denominator);
return x / y;
case FLOAT_TYPE:
return ((F_FLOAT*)UNTAG(tagged))->n;
default:
type_error(FLOAT_TYPE,tagged);
return 0.0; /* can't happen */
}
}
void primitive_to_float(void)
{
maybe_gc(sizeof(F_FLOAT));
drepl(tag_float(to_float(dpeek())));
}
void primitive_str_to_float(void)
{
F_STRING* str;
char *c_str, *end;
double f;
maybe_gc(sizeof(F_FLOAT));
str = untag_string(dpeek());
c_str = to_char_string(str,true);
end = c_str;
f = strtod(c_str,&end);
if(end != c_str + string_capacity(str))
drepl(F);
else
drepl(tag_float(f));
}
void primitive_float_to_str(void)
{
char tmp[33];
maybe_gc(sizeof(F_FLOAT));
snprintf(tmp,32,"%.16g",to_float(dpop()));
tmp[32] = '\0';
box_char_string(tmp);
}
#define GC_AND_POP_FLOATS(x,y) \
double x, y; \
maybe_gc(sizeof(F_FLOAT)); \
y = untag_float_fast(dpop()); \
x = untag_float_fast(dpop());
void primitive_float_add(void)
{
GC_AND_POP_FLOATS(x,y);
dpush(tag_float(x + y));
}
void primitive_float_subtract(void)
{
GC_AND_POP_FLOATS(x,y);
dpush(tag_float(x - y));
}
void primitive_float_multiply(void)
{
GC_AND_POP_FLOATS(x,y);
dpush(tag_float(x * y));
}
void primitive_float_divfloat(void)
{
GC_AND_POP_FLOATS(x,y);
dpush(tag_float(x / y));
}
void primitive_float_mod(void)
{
GC_AND_POP_FLOATS(x,y);
dpush(tag_float(fmod(x,y)));
}
void primitive_float_less(void)
{
GC_AND_POP_FLOATS(x,y);
box_boolean(x < y);
}
void primitive_float_lesseq(void)
{
GC_AND_POP_FLOATS(x,y);
box_boolean(x <= y);
}
void primitive_float_greater(void)
{
GC_AND_POP_FLOATS(x,y);
box_boolean(x > y);
}
void primitive_float_greatereq(void)
{
GC_AND_POP_FLOATS(x,y);
box_boolean(x >= y);
}
void primitive_facos(void)
{
maybe_gc(sizeof(F_FLOAT));
drepl(tag_float(acos(to_float(dpeek()))));
}
void primitive_fasin(void)
{
maybe_gc(sizeof(F_FLOAT));
drepl(tag_float(asin(to_float(dpeek()))));
}
void primitive_fatan(void)
{
maybe_gc(sizeof(F_FLOAT));
drepl(tag_float(atan(to_float(dpeek()))));
}
void primitive_fatan2(void)
{
double x, y;
maybe_gc(sizeof(F_FLOAT));
y = to_float(dpop());
x = to_float(dpop());
dpush(tag_float(atan2(x,y)));
}
void primitive_fcos(void)
{
maybe_gc(sizeof(F_FLOAT));
drepl(tag_float(cos(to_float(dpeek()))));
}
void primitive_fexp(void)
{
maybe_gc(sizeof(F_FLOAT));
drepl(tag_float(exp(to_float(dpeek()))));
}
void primitive_fcosh(void)
{
maybe_gc(sizeof(F_FLOAT));
drepl(tag_float(cosh(to_float(dpeek()))));
}
void primitive_flog(void)
{
maybe_gc(sizeof(F_FLOAT));
drepl(tag_float(log(to_float(dpeek()))));
}
void primitive_fpow(void)
{
double x, y;
maybe_gc(sizeof(F_FLOAT));
y = to_float(dpop());
x = to_float(dpop());
dpush(tag_float(pow(x,y)));
}
void primitive_fsin(void)
{
maybe_gc(sizeof(F_FLOAT));
drepl(tag_float(sin(to_float(dpeek()))));
}
void primitive_fsinh(void)
{
maybe_gc(sizeof(F_FLOAT));
drepl(tag_float(sinh(to_float(dpeek()))));
}
void primitive_fsqrt(void)
{
maybe_gc(sizeof(F_FLOAT));
drepl(tag_float(sqrt(to_float(dpeek()))));
}
void primitive_float_bits(void)
{
FLOAT_BITS b;
b.x = (float)to_float(dpeek());
drepl(tag_cell(b.y));
}
void primitive_bits_float(void)
{
FLOAT_BITS b;
b.y = unbox_unsigned_4();
dpush(tag_float(b.x));
}
void primitive_double_bits(void)
{
DOUBLE_BITS b;
b.x = to_float(dpop());
box_unsigned_8(b.y);
}
void primitive_bits_double(void)
{
DOUBLE_BITS b;
b.y = unbox_unsigned_8();
dpush(tag_float(b.x));
}
#define DEFBOX(name,type) \
void name (type flo) \
{ \
dpush(tag_float(flo)); \
}
#define DEFUNBOX(name,type) \
type name(void) \
{ \
return to_float(dpop()); \
}
DEFBOX(box_float,float)
DEFUNBOX(unbox_float,float)
DEFBOX(box_double,double)
DEFUNBOX(unbox_double,double)

75
vm/float.h
View File

@ -1,75 +0,0 @@
typedef struct {
/* C sucks. */
union {
CELL header;
long long padding;
};
double n;
} F_FLOAT;
/* for punning */
typedef union {
double x;
u64 y;
} DOUBLE_BITS;
typedef union {
float x;
u32 y;
} FLOAT_BITS;
INLINE F_FLOAT* make_float(double n)
{
F_FLOAT* flo = allot_object(FLOAT_TYPE,sizeof(F_FLOAT));
flo->n = n;
return flo;
}
INLINE double untag_float_fast(CELL tagged)
{
return ((F_FLOAT*)UNTAG(tagged))->n;
}
INLINE CELL tag_float(double flo)
{
return RETAG(make_float(flo),FLOAT_TYPE);
}
double to_float(CELL tagged);
void primitive_to_float(void);
void primitive_str_to_float(void);
void primitive_float_to_str(void);
void primitive_float_to_bits(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_facos(void);
void primitive_fasin(void);
void primitive_fatan(void);
void primitive_fatan2(void);
void primitive_fcos(void);
void primitive_fexp(void);
void primitive_fcosh(void);
void primitive_flog(void);
void primitive_fpow(void);
void primitive_fsin(void);
void primitive_fsinh(void);
void primitive_fsqrt(void);
void primitive_float_bits(void);
void primitive_bits_float(void);
void primitive_double_bits(void);
void primitive_bits_double(void);
DLLEXPORT void box_float(float flo);
DLLEXPORT float unbox_float(void);
DLLEXPORT void box_double(double flo);
DLLEXPORT double unbox_double(void);

389
vm/gc.c
View File

@ -1,389 +0,0 @@
#include "factor.h"
/* Generational copying garbage collector */
CELL init_zone(ZONE *z, CELL size, CELL base)
{
z->base = z->here = base;
z->limit = z->base + size;
z->alarm = z->base + (size * 3) / 4;
return z->limit;
}
/* update this global variable. since it is stored in a non-volatile register,
we need to save its contents and re-initialize it when entering a callback,
and restore its contents when leaving the callback. see stack.c */
void update_cards_offset(void)
{
cards_offset = (CELL)cards - (heap_start >> CARD_BITS);
}
/* input parameters must be 8 byte aligned */
/* the heap layout is important:
- two semispaces: tenured and prior
- younger generations follow
there are two reasons for this:
- we can easily check if a pointer is in some generation or a younger one
- the nursery grows into the guard page, so allot() does not have to
check for out of memory, whereas allot_zone() (used by the GC) longjmp()s
back to collecting a higher generation */
void init_arena(CELL gens, CELL young_size, CELL aging_size)
{
int i;
CELL alloter;
CELL total_size = (gens - 1) * young_size + 2 * aging_size;
CELL cards_size = total_size / CARD_SIZE;
gen_count = gens;
generations = safe_malloc(sizeof(ZONE) * gen_count);
heap_start = (CELL)(alloc_bounded_block(total_size)->start);
heap_end = heap_start + total_size;
cards = safe_malloc(cards_size);
cards_end = cards + cards_size;
update_cards_offset();
alloter = heap_start;
alloter = init_zone(&tenured,aging_size,alloter);
alloter = init_zone(&prior,aging_size,alloter);
for(i = gen_count - 2; i >= 0; i--)
alloter = init_zone(&generations[i],young_size,alloter);
clear_cards(NURSERY,TENURED);
if(alloter != heap_start + total_size)
fatal_error("Oops",alloter);
heap_scan = false;
gc_time = 0;
minor_collections = 0;
cards_scanned = 0;
}
void collect_callframe_triple(CELL *callframe,
CELL *callframe_scan, CELL *callframe_end)
{
*callframe_scan -= *callframe;
*callframe_end -= *callframe;
copy_handle(callframe);
*callframe_scan += *callframe;
*callframe_end += *callframe;
}
void collect_stack(BOUNDED_BLOCK *region, CELL top)
{
CELL bottom = region->start;
CELL ptr;
for(ptr = bottom; ptr <= top; ptr += CELLS)
copy_handle((CELL*)ptr);
}
void collect_callstack(BOUNDED_BLOCK *region, CELL top)
{
CELL bottom = region->start;
CELL ptr;
for(ptr = bottom; ptr <= top; ptr += CELLS * 3)
collect_callframe_triple((CELL*)ptr,
(CELL*)ptr + 1, (CELL*)ptr + 2);
}
void collect_roots(void)
{
int i;
STACKS *stacks;
copy_handle(&T);
copy_handle(&bignum_zero);
copy_handle(&bignum_pos_one);
copy_handle(&bignum_neg_one);
collect_callframe_triple(&callframe,&callframe_scan,&callframe_end);
save_stacks();
stacks = stack_chain;
while(stacks)
{
collect_stack(stacks->data_region,stacks->data);
collect_stack(stacks->retain_region,stacks->retain);
collect_callstack(stacks->call_region,stacks->call);
if(stacks->next != NULL)
{
collect_callframe_triple(&stacks->callframe,
&stacks->callframe_scan,&stacks->callframe_end);
}
copy_handle(&stacks->catch_save);
stacks = stacks->next;
}
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)
{
void *newpointer;
if(newspace->here + size >= newspace->limit)
longjmp(gc_jmp,1);
newpointer = allot_zone(newspace,size);
memcpy(newpointer,pointer,size);
return newpointer;
}
INLINE CELL copy_object_impl(CELL pointer)
{
CELL newpointer = (CELL)copy_untagged_object((void*)UNTAG(pointer),
object_size(pointer));
/* install forwarding pointer */
put(UNTAG(pointer),RETAG(newpointer,GC_COLLECTED));
return newpointer;
}
/* follow a chain of forwarding pointers */
CELL resolve_forwarding(CELL untagged, CELL tag)
{
CELL header = get(untagged);
/* another forwarding pointer */
if(TAG(header) == GC_COLLECTED)
return resolve_forwarding(UNTAG(header),tag);
/* we've found the destination */
else
{
CELL pointer = RETAG(untagged,tag);
if(should_copy(untagged))
pointer = RETAG(copy_object_impl(pointer),tag);
return pointer;
}
}
/*
Given a pointer to a tagged pointer to oldspace, copy it to newspace.
If the object has already been copied, return the forwarding
pointer address without copying anything; otherwise, install
a new forwarding pointer.
*/
CELL copy_object(CELL pointer)
{
CELL tag;
CELL header;
if(pointer == F)
return F;
tag = TAG(pointer);
if(tag == FIXNUM_TYPE)
return pointer;
header = get(UNTAG(pointer));
if(TAG(header) == GC_COLLECTED)
return resolve_forwarding(UNTAG(header),tag);
else
return RETAG(copy_object_impl(pointer),tag);
}
INLINE void collect_object(CELL scan)
{
switch(untag_header(get(scan)))
{
case RATIO_TYPE:
collect_ratio((F_RATIO*)scan);
break;
case COMPLEX_TYPE:
collect_complex((F_COMPLEX*)scan);
break;
case WORD_TYPE:
collect_word((F_WORD*)scan);
break;
case ARRAY_TYPE:
case TUPLE_TYPE:
case QUOTATION_TYPE:
collect_array((F_ARRAY*)scan);
break;
case HASHTABLE_TYPE:
collect_hashtable((F_HASHTABLE*)scan);
break;
case VECTOR_TYPE:
collect_vector((F_VECTOR*)scan);
break;
case SBUF_TYPE:
collect_sbuf((F_SBUF*)scan);
break;
case DLL_TYPE:
collect_dll((DLL*)scan);
break;
case ALIEN_TYPE:
collect_alien((ALIEN*)scan);
break;
case WRAPPER_TYPE:
collect_wrapper((F_WRAPPER*)scan);
break;
}
}
CELL collect_next(CELL scan)
{
CELL size = untagged_object_size(scan);
collect_object(scan);
return scan + size;
}
void reset_generations(CELL from, CELL to)
{
CELL i;
for(i = from; i <= to; i++)
generations[i].here = generations[i].base;
clear_cards(from,to);
}
void begin_gc(CELL gen)
{
collecting_gen = gen;
collecting_gen_start = generations[gen].base;
if(gen == TENURED)
{
/* when collecting the oldest generation, rotate it
with the semispace */
ZONE z = generations[gen];
generations[gen] = prior;
prior = z;
generations[gen].here = generations[gen].base;
newspace = &generations[gen];
clear_cards(TENURED,TENURED);
}
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 = &generations[gen + 1];
}
}
void end_gc(CELL gen)
{
if(gen == TENURED)
{
/* we did a full collection; no more
old-to-new pointers remain since everything
is in tenured space */
unmark_cards(TENURED,TENURED);
/* all generations except tenured space are
now empty */
reset_generations(NURSERY,TENURED - 1);
fprintf(stderr,"*** Major GC (%ld minor, %ld cards)\n",
minor_collections,cards_scanned);
minor_collections = 0;
cards_scanned = 0;
}
else
{
/* we collected a younger generation. so the
next-oldest generation no longer has any
pointers into the younger generation (the
younger generation is empty!) */
unmark_cards(gen + 1,gen + 1);
/* all generations up to and including the one
collected are now empty */
reset_generations(NURSERY,gen);
minor_collections++;
}
}
/* collect gen and all younger generations */
void garbage_collection(CELL gen)
{
s64 start = current_millis();
CELL scan;
if(heap_scan)
critical_error("GC disabled during heap scan",gen);
/* we come back here if a generation is full */
if(setjmp(gc_jmp))
{
if(gen == TENURED)
{
/* oops, out of memory */
critical_error("Out of memory",0);
}
else
gen++;
}
begin_gc(gen);
/* initialize chase pointer */
scan = newspace->here;
/* collect objects referenced from stacks and environment */
collect_roots();
/* collect objects referenced from older generations */
collect_cards(gen);
/* collect literal objects referenced from compiled code */
collect_literals();
while(scan < newspace->here)
scan = collect_next(scan);
end_gc(gen);
gc_time += (current_millis() - start);
}
void primitive_gc(void)
{
CELL gen = to_fixnum(dpop());
if(gen <= NURSERY)
gen = NURSERY;
else if(gen >= TENURED)
gen = TENURED;
garbage_collection(gen);
}
/* WARNING: only call this from a context where all local variables
are also reachable via the GC roots. */
void maybe_gc(CELL size)
{
if(nursery.here + size > nursery.alarm)
{
CELL gen = NURSERY;
while(gen < TENURED)
{
ZONE *z = &generations[gen + 1];
if(z->here < z->alarm)
break;
gen++;
}
garbage_collection(gen);
}
}
void simple_gc(void)
{
maybe_gc(0);
}
void primitive_gc_time(void)
{
simple_gc();
dpush(tag_bignum(s48_long_long_to_bignum(gc_time)));
}

119
vm/gc.h
View File

@ -1,119 +0,0 @@
/* generational copying GC divides memory into zones */
typedef struct {
/* start of zone */
CELL base;
/* allocation pointer */
CELL here;
/* only for nursery: when it gets this full, call GC */
CELL alarm;
/* end of zone */
CELL limit;
} ZONE;
/* total number of generations. */
CELL gen_count;
/* the 0th generation is where new objects are allocated. */
#define NURSERY 0
/* the oldest generation */
#define TENURED (gen_count-1)
DLLEXPORT ZONE *generations;
/* used during garbage collection only */
ZONE *newspace;
#define tenured generations[TENURED]
#define nursery generations[NURSERY]
/* spare semi-space; rotates with tenured. */
ZONE prior;
INLINE bool in_zone(ZONE* z, CELL pointer)
{
return pointer >= z->base && pointer < z->limit;
}
CELL init_zone(ZONE *z, CELL size, CELL base);
void init_arena(CELL gen_count, CELL young_size, CELL aging_size);
/* statistics */
s64 gc_time;
CELL minor_collections;
CELL cards_scanned;
/* only meaningful during a GC */
CELL collecting_gen;
CELL collecting_gen_start;
/* test if the pointer is in generation being collected, or a younger one.
init_arena() arranges things so that the older generations are first,
so we have to check that the pointer occurs after the beginning of
the requested generation. */
#define COLLECTING_GEN(ptr) (collecting_gen_start <= ptr)
INLINE bool should_copy(CELL untagged)
{
if(collecting_gen == TENURED)
return !in_zone(newspace,untagged);
else
return(in_zone(&prior,untagged) || COLLECTING_GEN(untagged));
}
CELL copy_object(CELL pointer);
#define COPY_OBJECT(lvalue) if(should_copy(lvalue)) lvalue = copy_object(lvalue)
INLINE void copy_handle(CELL *handle)
{
COPY_OBJECT(*handle);
}
/* 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;
/* A heap walk allows useful things to be done, like finding all
references to an object for debugging purposes. */
CELL heap_scan_ptr;
/* GC is off during heap walking */
bool heap_scan;
INLINE void *allot_zone(ZONE *z, CELL a)
{
CELL h = z->here;
z->here = h + align8(a);
if(z->here > z->limit)
{
fprintf(stderr,"Nursery space exhausted\n");
factorbug();
}
allot_barrier(h);
return (void*)h;
}
INLINE void *allot(CELL a)
{
return allot_zone(&nursery,a);
}
/*
* It is up to the caller to fill in the object's fields in a meaningful
* fashion!
*/
INLINE void* allot_object(CELL type, CELL length)
{
CELL* object = allot(length);
*object = tag_header(type);
return object;
}
void update_cards_offset(void);
CELL collect_next(CELL scan);
void garbage_collection(CELL gen);
void primitive_gc(void);
void maybe_gc(CELL size);
DLLEXPORT void simple_gc(void);
void primitive_gc_time(void);

26
vm/hashtable.c
View File

@ -1,26 +0,0 @@
#include "factor.h"
void primitive_hashtable(void)
{
F_HASHTABLE* hash;
maybe_gc(0);
hash = allot_object(HASHTABLE_TYPE,sizeof(F_HASHTABLE));
hash->count = F;
hash->deleted = F;
hash->array = F;
dpush(tag_object(hash));
}
void fixup_hashtable(F_HASHTABLE* hashtable)
{
data_fixup(&hashtable->count);
data_fixup(&hashtable->deleted);
data_fixup(&hashtable->array);
}
void collect_hashtable(F_HASHTABLE* hashtable)
{
copy_handle(&hashtable->count);
copy_handle(&hashtable->deleted);
copy_handle(&hashtable->array);
}

14
vm/hashtable.h
View File

@ -1,14 +0,0 @@
typedef struct {
/* always tag_header(HASHTABLE_TYPE) */
CELL header;
/* tagged */
CELL count;
/* tagged */
CELL deleted;
/* tagged */
CELL array;
} F_HASHTABLE;
void primitive_hashtable(void);
void fixup_hashtable(F_HASHTABLE* hashtable);
void collect_hashtable(F_HASHTABLE* hashtable);

192
vm/image.c
View File

@ -24,7 +24,6 @@ void load_image(const char* filename, int literal_table)
{
fprintf(stderr,"Cannot open image file: %s\n",filename);
fprintf(stderr,"%s\n",strerror(errno));
usage();
exit(1);
}
@ -140,3 +139,194 @@ void primitive_save_image(void)
filename = untag_string(dpop());
save_image(to_char_string(filename,true));
}
void relocate_object(CELL relocating)
{
switch(untag_header(get(relocating)))
{
case RATIO_TYPE:
fixup_ratio((F_RATIO*)relocating);
break;
case COMPLEX_TYPE:
fixup_complex((F_COMPLEX*)relocating);
break;
case WORD_TYPE:
fixup_word((F_WORD*)relocating);
break;
case ARRAY_TYPE:
case TUPLE_TYPE:
case QUOTATION_TYPE:
fixup_array((F_ARRAY*)relocating);
break;
case HASHTABLE_TYPE:
fixup_hashtable((F_HASHTABLE*)relocating);
break;
case VECTOR_TYPE:
fixup_vector((F_VECTOR*)relocating);
break;
case STRING_TYPE:
rehash_string((F_STRING*)relocating);
break;
case SBUF_TYPE:
fixup_sbuf((F_SBUF*)relocating);
break;
case DLL_TYPE:
fixup_dll((DLL*)relocating);
break;
case ALIEN_TYPE:
fixup_alien((ALIEN*)relocating);
break;
case WRAPPER_TYPE:
fixup_wrapper((F_WRAPPER*)relocating);
break;
}
}
void relocate_data()
{
CELL relocating;
data_fixup(&userenv[BOOT_ENV]);
data_fixup(&userenv[GLOBAL_ENV]);
data_fixup(&T);
data_fixup(&bignum_zero);
data_fixup(&bignum_pos_one);
data_fixup(&bignum_neg_one);
for(relocating = tenured.base;
relocating < tenured.here;
relocating += untagged_object_size(relocating))
{
allot_barrier(relocating);
relocate_object(relocating);
}
for(relocating = compiling.base;
relocating < literal_top;
relocating += CELLS)
{
data_fixup((CELL*)relocating);
}
}
void undefined_symbol(void)
{
general_error(ERROR_UNDEFINED_SYMBOL,F,F,true);
}
CELL get_rel_symbol(F_REL* rel)
{
CELL arg = REL_ARGUMENT(rel);
F_ARRAY *pair = untag_array(get(compiling.base + arg * CELLS));
F_STRING *symbol = untag_string(get(AREF(pair,0)));
CELL library = get(AREF(pair,1));
DLL *dll = (library == F ? NULL : untag_dll(library));
CELL sym;
if(dll != NULL && !dll->dll)
return (CELL)undefined_symbol;
sym = (CELL)ffi_dlsym(dll,symbol,false);
if(!sym)
return (CELL)undefined_symbol;
return sym;
}
INLINE CELL compute_code_rel(F_REL *rel, CELL original)
{
switch(REL_TYPE(rel))
{
case F_PRIMITIVE:
return primitive_to_xt(REL_ARGUMENT(rel));
case F_DLSYM:
return get_rel_symbol(rel);
case F_ABSOLUTE:
return original + (compiling.base - code_relocation_base);
case F_CARDS:
return cards_offset;
default:
critical_error("Unsupported rel type",rel->type);
return -1;
}
}
INLINE CELL relocate_code_next(CELL relocating)
{
F_COMPILED* compiled = (F_COMPILED*)relocating;
F_REL* rel = (F_REL*)(
relocating + sizeof(F_COMPILED)
+ compiled->code_length);
F_REL* rel_end = (F_REL*)(
relocating + sizeof(F_COMPILED)
+ compiled->code_length
+ compiled->reloc_length);
if(compiled->header != COMPILED_HEADER)
critical_error("Wrong compiled header",relocating);
while(rel < rel_end)
{
CELL original;
CELL new_value;
code_fixup(&rel->offset);
switch(REL_CLASS(rel))
{
case REL_ABSOLUTE_CELL:
original = get(rel->offset);
break;
case REL_ABSOLUTE:
original = *(u32*)rel->offset;
break;
case REL_RELATIVE:
original = *(u32*)rel->offset - (rel->offset + sizeof(u32));
break;
case REL_2_2:
original = reloc_get_2_2(rel->offset);
break;
default:
critical_error("Unsupported rel class",REL_CLASS(rel));
return -1;
}
/* to_c_string can fill up the heap */
maybe_gc(0);
new_value = compute_code_rel(rel,original);
switch(REL_CLASS(rel))
{
case REL_ABSOLUTE_CELL:
put(rel->offset,new_value);
break;
case REL_ABSOLUTE:
*(u32*)rel->offset = new_value;
break;
case REL_RELATIVE:
*(u32*)rel->offset = new_value - (rel->offset + CELLS);
break;
case REL_2_2:
reloc_set_2_2(rel->offset,new_value);
break;
default:
critical_error("Unsupported rel class",REL_CLASS(rel));
return -1;
}
rel++;
}
return (CELL)rel_end;
}
void relocate_code()
{
/* start relocating from the end of the space reserved for literals */
CELL relocating = literal_max;
while(relocating < compiling.here)
relocating = relocate_code_next(relocating);
}

61
vm/image.h
View File

@ -40,3 +40,64 @@ void init_objects(HEADER *h);
void load_image(const char* file, int literal_size);
bool save_image(const char* file);
void primitive_save_image(void);
/* relocation base of currently loaded image's data heap */
CELL data_relocation_base;
INLINE void data_fixup(CELL *cell)
{
if(TAG(*cell) != FIXNUM_TYPE && *cell != F)
*cell += (tenured.base - data_relocation_base);
}
typedef enum {
/* arg is a primitive number */
F_PRIMITIVE,
/* arg is a pointer in the literal table hodling a cons where the
car is a symbol string, and the cdr is a dll */
F_DLSYM,
/* relocate an address to start of code heap */
F_ABSOLUTE,
/* store the offset of the card table from the data heap base */
F_CARDS
} F_RELTYPE;
#define REL_ABSOLUTE_CELL 0
#define REL_ABSOLUTE 1
#define REL_RELATIVE 2
#define REL_2_2 3
/* the rel type is built like a cell to avoid endian-specific code in
the compiler */
#define REL_TYPE(r) ((r)->type & 0x000000ff)
#define REL_CLASS(r) (((r)->type & 0x0000ff00) >> 8)
#define REL_ARGUMENT(r) (((r)->type & 0xffff0000) >> 16)
/* code relocation consists of a table of entries for each fixup */
typedef struct {
CELL type;
CELL offset;
} F_REL;
CELL code_relocation_base;
INLINE void code_fixup(CELL *cell)
{
*cell += (compiling.base - code_relocation_base);
}
void relocate_data();
void relocate_code();
/* on PowerPC, return the 32-bit literal being loaded at the code at the
given address */
INLINE CELL reloc_get_2_2(CELL cell)
{
return ((get(cell - CELLS) & 0xffff) << 16) | (get(cell) & 0xffff);
}
INLINE void reloc_set_2_2(CELL cell, CELL value)
{
put(cell - CELLS,((get(cell - CELLS) & ~0xffff) | ((value >> 16) & 0xffff)));
put(cell,((get(cell) & ~0xffff) | (value & 0xffff)));
}

166
vm/layouts.h Normal file
View File

@ -0,0 +1,166 @@
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))
/* must always be 16 bits */
#define CHARS ((signed)sizeof(u16))
#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 RETAG(cell,tag) ((CELL)(cell) | (tag))
#define UNTAG(cell) ((CELL)(cell) & ~TAG_MASK)
/*** Tags ***/
#define FIXNUM_TYPE 0
#define BIGNUM_TYPE 1
#define WORD_TYPE 2
#define OBJECT_TYPE 3
#define RATIO_TYPE 4
#define FLOAT_TYPE 5
#define COMPLEX_TYPE 6
#define WRAPPER_TYPE 7
#define HEADER_TYPE 7 /* anything less than or equal to this is a tag */
#define GC_COLLECTED 0 /* See gc.c */
/*** Header types ***/
#define ARRAY_TYPE 8
/* Canonical F object */
#define F_TYPE 9
#define F RETAG(0,OBJECT_TYPE)
#define HASHTABLE_TYPE 10
#define VECTOR_TYPE 11
#define STRING_TYPE 12
#define SBUF_TYPE 13
#define QUOTATION_TYPE 14
#define DLL_TYPE 15
#define ALIEN_TYPE 16
#define TUPLE_TYPE 17
#define BYTE_ARRAY_TYPE 18
#define TYPE_COUNT 19
typedef struct {
CELL header;
/* tagged */
CELL capacity;
} F_ARRAY;
typedef struct {
/* always tag_header(VECTOR_TYPE) */
CELL header;
/* tagged */
CELL top;
/* tagged */
CELL array;
} F_VECTOR;
typedef struct {
CELL header;
/* tagged num of chars */
CELL length;
/* tagged */
CELL hashcode;
} F_STRING;
typedef struct {
/* always tag_header(SBUF_TYPE) */
CELL header;
/* tagged */
CELL top;
/* tagged */
CELL string;
} F_SBUF;
typedef struct {
/* always tag_header(HASHTABLE_TYPE) */
CELL header;
/* tagged */
CELL count;
/* tagged */
CELL deleted;
/* tagged */
CELL array;
} F_HASHTABLE;
typedef struct {
/* TAGGED header */
CELL header;
/* TAGGED hashcode */
CELL hashcode;
/* TAGGED word name */
CELL name;
/* TAGGED word vocabulary */
CELL vocabulary;
/* TAGGED on-disk primitive number */
CELL primitive;
/* TAGGED parameter to xt; used for colon definitions */
CELL def;
/* TAGGED property hash for library code */
CELL props;
/* UNTAGGED execution token: jump here to execute word */
CELL xt;
} F_WORD;
typedef struct {
CELL header;
CELL object;
} F_WRAPPER;
typedef struct {
CELL header;
CELL numerator;
CELL denominator;
} F_RATIO;
typedef struct {
/* C sucks. */
union {
CELL header;
long long padding;
};
double n;
} F_FLOAT;
typedef struct {
CELL header;
CELL real;
CELL imaginary;
} F_COMPLEX;
typedef struct {
CELL header;
CELL alien;
CELL displacement;
bool expired;
} ALIEN;
typedef struct {
CELL header;
/* tagged string */
CELL path;
/* OS-specific handle */
void* dll;
} DLL;

10
vm/macosx/mach_signal.c → vm/mach_signal.c
View File

@ -7,9 +7,7 @@ Used under BSD license with permission from Paolo Bonzini and Bruno Haible,
see http://www.caddr.com/macho/archives/sbcl-devel/2005-3/4764.html */
#ifdef __APPLE__
#include "mach_signal.h"
#include "factor.h"
/* The following sources were used as a *reference* for this exception handling
code:
@ -43,15 +41,12 @@ catch_exception_raise (mach_port_t exception_port,
exception_data_t code,
mach_msg_type_number_t code_count)
{
#ifdef SIGSEGV_EXC_STATE_TYPE
SIGSEGV_EXC_STATE_TYPE exc_state;
#endif
SIGSEGV_THREAD_STATE_TYPE thread_state;
mach_msg_type_number_t state_count;
unsigned long sp;
/* See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/thread_get_state.html. */
#ifdef SIGSEGV_EXC_STATE_TYPE
state_count = SIGSEGV_EXC_STATE_COUNT;
if (thread_get_state (thread, SIGSEGV_EXC_STATE_FLAVOR,
(void *) &exc_state, &state_count)
@ -61,7 +56,6 @@ catch_exception_raise (mach_port_t exception_port,
is called. This shouldn't fail. */
return KERN_FAILURE;
}
#endif
state_count = SIGSEGV_THREAD_STATE_COUNT;
if (thread_get_state (thread, SIGSEGV_THREAD_STATE_FLAVOR,
@ -198,5 +192,3 @@ int mach_initialize ()
return 0;
}
#endif

24
vm/macosx/mach_signal.h → vm/mach_signal.h
View File

@ -1,5 +1,3 @@
#ifdef __APPLE__
#include <stdio.h>
#include <stdlib.h>
#include <errno.h>
@ -71,26 +69,4 @@ catch_exception_raise_state_identity (mach_port_t exception_port,
thread_state_t out_state,
mach_msg_type_number_t *out_state_count);
#ifdef __i386__
#define SIGSEGV_EXC_STATE_TYPE i386_exception_state_t
#define SIGSEGV_EXC_STATE_FLAVOR i386_EXCEPTION_STATE
#define SIGSEGV_EXC_STATE_COUNT i386_EXCEPTION_STATE_COUNT
#define SIGSEGV_THREAD_STATE_TYPE i386_thread_state_t
#define SIGSEGV_THREAD_STATE_FLAVOR i386_THREAD_STATE
#define SIGSEGV_THREAD_STATE_COUNT i386_THREAD_STATE_COUNT
#define SIGSEGV_STACK_POINTER(thr_state) (thr_state).esp
#define SIGSEGV_PROGRAM_COUNTER(thr_state) (thr_state).eip
#else
#define SIGSEGV_EXC_STATE_TYPE ppc_exception_state_t
#define SIGSEGV_EXC_STATE_FLAVOR PPC_EXCEPTION_STATE
#define SIGSEGV_EXC_STATE_COUNT PPC_EXCEPTION_STATE_COUNT
#define SIGSEGV_THREAD_STATE_TYPE ppc_thread_state_t
#define SIGSEGV_THREAD_STATE_FLAVOR PPC_THREAD_STATE
#define SIGSEGV_THREAD_STATE_COUNT PPC_THREAD_STATE_COUNT
#define SIGSEGV_STACK_POINTER(thr_state) (thr_state).r1
#define SIGSEGV_PROGRAM_COUNTER(thr_state) (thr_state).srr0
#endif
int mach_initialize ();
#endif

778
vm/math.c Normal file
View File

@ -0,0 +1,778 @@
#include "factor.h"
/* Fixnums */
F_FIXNUM to_fixnum(CELL tagged)
{
F_RATIO* r;
F_ARRAY* x;
F_ARRAY* y;
F_FLOAT* f;
switch(TAG(tagged))
{
case FIXNUM_TYPE:
return untag_fixnum_fast(tagged);
case BIGNUM_TYPE:
return (F_FIXNUM)s48_bignum_to_fixnum((F_ARRAY*)UNTAG(tagged));
case RATIO_TYPE:
r = (F_RATIO*)UNTAG(tagged);
x = to_bignum(r->numerator);
y = to_bignum(r->denominator);
return to_fixnum(tag_bignum(s48_bignum_quotient(x,y)));
case FLOAT_TYPE:
f = (F_FLOAT*)UNTAG(tagged);
return (F_FIXNUM)f->n;
default:
type_error(FIXNUM_TYPE,tagged);
return -1; /* can't happen */
}
}
void primitive_to_fixnum(void)
{
drepl(tag_fixnum(to_fixnum(dpeek())));
}
#define POP_FIXNUMS(x,y) \
F_FIXNUM x, y; \
y = untag_fixnum_fast(dpop()); \
x = untag_fixnum_fast(dpop());
/* The fixnum arithmetic operations defined in C are relatively slow.
The Factor compiler has optimized assembly intrinsics for all these
operations. */
void primitive_fixnum_add(void)
{
POP_FIXNUMS(x,y)
box_signed_cell(x + y);
}
void primitive_fixnum_add_fast(void)
{
POP_FIXNUMS(x,y)
dpush(tag_fixnum(x + y));
}
void primitive_fixnum_subtract(void)
{
POP_FIXNUMS(x,y)
box_signed_cell(x - y);
}
void primitive_fixnum_subtract_fast(void)
{
POP_FIXNUMS(x,y)
dpush(tag_fixnum(x - y));
}
/**
* Multiply two integers, and trap overflow.
* Thanks to David Blaikie (The_Vulture from freenode #java) for the hint.
*/
void primitive_fixnum_multiply(void)
{
POP_FIXNUMS(x,y)
if(x == 0 || y == 0)
dpush(tag_fixnum(0));
else
{
F_FIXNUM prod = x * y;
/* if this is not equal, we have overflow */
if(prod / x == y)
box_signed_cell(prod);
else
{
dpush(tag_bignum(
s48_bignum_multiply(
s48_fixnum_to_bignum(x),
s48_fixnum_to_bignum(y))));
}
}
}
void primitive_fixnum_divint(void)
{
POP_FIXNUMS(x,y)
box_signed_cell(x / y);
}
void primitive_fixnum_divfloat(void)
{
POP_FIXNUMS(x,y)
dpush(tag_float((double)x / (double)y));
}
void primitive_fixnum_divmod(void)
{
POP_FIXNUMS(x,y)
box_signed_cell(x / y);
box_signed_cell(x % y);
}
void primitive_fixnum_mod(void)
{
POP_FIXNUMS(x,y)
dpush(tag_fixnum(x % y));
}
void primitive_fixnum_and(void)
{
POP_FIXNUMS(x,y)
dpush(tag_fixnum(x & y));
}
void primitive_fixnum_or(void)
{
POP_FIXNUMS(x,y)
dpush(tag_fixnum(x | y));
}
void primitive_fixnum_xor(void)
{
POP_FIXNUMS(x,y)
dpush(tag_fixnum(x ^ y));
}
/*
* Note the hairy overflow check.
* 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.
*/
void primitive_fixnum_shift(void)
{
POP_FIXNUMS(x,y)
if(x == 0 || y == 0)
{
dpush(tag_fixnum(x));
return;
}
else if(y < 0)
{
if(y <= -WORD_SIZE)
dpush(x < 0 ? tag_fixnum(-1) : tag_fixnum(0));
else
dpush(tag_fixnum(x >> -y));
return;
}
else if(y < WORD_SIZE - TAG_BITS)
{
F_FIXNUM mask = -(1 << (WORD_SIZE - 1 - TAG_BITS - y));
if((x > 0 && (x & mask) == 0) || (x & mask) == mask)
{
dpush(tag_fixnum(x << y));
return;
}
}
dpush(tag_bignum(s48_bignum_arithmetic_shift(
s48_fixnum_to_bignum(x),y)));
}
void primitive_fixnum_less(void)
{
POP_FIXNUMS(x,y)
box_boolean(x < y);
}
void primitive_fixnum_lesseq(void)
{
POP_FIXNUMS(x,y)
box_boolean(x <= y);
}
void primitive_fixnum_greater(void)
{
POP_FIXNUMS(x,y)
box_boolean(x > y);
}
void primitive_fixnum_greatereq(void)
{
POP_FIXNUMS(x,y)
box_boolean(x >= y);
}
void primitive_fixnum_not(void)
{
drepl(tag_fixnum(~untag_fixnum_fast(dpeek())));
}
#define INT_DEFBOX(name,type) \
void name (type integer) \
{ \
dpush(tag_integer(integer)); \
}
#define INT_DEFUNBOX(name,type) \
type name(void) \
{ \
return to_fixnum(dpop()); \
}
INT_DEFBOX(box_signed_1, signed char)
INT_DEFBOX(box_signed_2, signed short)
INT_DEFBOX(box_unsigned_1, unsigned char)
INT_DEFBOX(box_unsigned_2, unsigned short)
INT_DEFUNBOX(unbox_signed_1, signed char)
INT_DEFUNBOX(unbox_signed_2, signed short)
INT_DEFUNBOX(unbox_unsigned_1, unsigned char)
INT_DEFUNBOX(unbox_unsigned_2, unsigned short)
/* Bignums */
CELL to_cell(CELL x)
{
switch(type_of(x))
{
case FIXNUM_TYPE:
return untag_fixnum_fast(x);
case BIGNUM_TYPE:
return s48_bignum_to_fixnum(untag_bignum_fast(x));
default:
type_error(BIGNUM_TYPE,x);
return 0;
}
}
F_ARRAY* to_bignum(CELL tagged)
{
F_RATIO* r;
F_ARRAY* x;
F_ARRAY* y;
F_FLOAT* f;
switch(type_of(tagged))
{
case FIXNUM_TYPE:
return s48_fixnum_to_bignum(untag_fixnum_fast(tagged));
case BIGNUM_TYPE:
return (F_ARRAY*)UNTAG(tagged);
case RATIO_TYPE:
r = (F_RATIO*)UNTAG(tagged);
x = to_bignum(r->numerator);
y = to_bignum(r->denominator);
return s48_bignum_quotient(x,y);
case FLOAT_TYPE:
f = (F_FLOAT*)UNTAG(tagged);
return s48_double_to_bignum(f->n);
default:
type_error(BIGNUM_TYPE,tagged);
return NULL; /* can't happen */
}
}
void primitive_to_bignum(void)
{
maybe_gc(0);
drepl(tag_bignum(to_bignum(dpeek())));
}
#define GC_AND_POP_BIGNUMS(x,y) \
F_ARRAY *x, *y; \
maybe_gc(0); \
y = untag_bignum_fast(dpop()); \
x = untag_bignum_fast(dpop());
void primitive_bignum_eq(void)
{
GC_AND_POP_BIGNUMS(x,y);
box_boolean(s48_bignum_equal_p(x,y));
}
void primitive_bignum_add(void)
{
GC_AND_POP_BIGNUMS(x,y);
dpush(tag_bignum(s48_bignum_add(x,y)));
}
void primitive_bignum_subtract(void)
{
GC_AND_POP_BIGNUMS(x,y);
dpush(tag_bignum(s48_bignum_subtract(x,y)));
}
void primitive_bignum_multiply(void)
{
GC_AND_POP_BIGNUMS(x,y);
dpush(tag_bignum(s48_bignum_multiply(x,y)));
}
void primitive_bignum_divint(void)
{
GC_AND_POP_BIGNUMS(x,y);
dpush(tag_bignum(s48_bignum_quotient(x,y)));
}
void primitive_bignum_divfloat(void)
{
GC_AND_POP_BIGNUMS(x,y);
dpush(tag_float(
s48_bignum_to_double(x) /
s48_bignum_to_double(y)));
}
void primitive_bignum_divmod(void)
{
F_ARRAY *q, *r;
GC_AND_POP_BIGNUMS(x,y);
s48_bignum_divide(x,y,&q,&r);
dpush(tag_bignum(q));
dpush(tag_bignum(r));
}
void primitive_bignum_mod(void)
{
GC_AND_POP_BIGNUMS(x,y);
dpush(tag_bignum(s48_bignum_remainder(x,y)));
}
void primitive_bignum_and(void)
{
GC_AND_POP_BIGNUMS(x,y);
dpush(tag_bignum(s48_bignum_bitwise_and(x,y)));
}
void primitive_bignum_or(void)
{
GC_AND_POP_BIGNUMS(x,y);
dpush(tag_bignum(s48_bignum_bitwise_ior(x,y)));
}
void primitive_bignum_xor(void)
{
GC_AND_POP_BIGNUMS(x,y);
dpush(tag_bignum(s48_bignum_bitwise_xor(x,y)));
}
void primitive_bignum_shift(void)
{
F_FIXNUM y;
F_ARRAY* x;
maybe_gc(0);
y = to_fixnum(dpop());
x = to_bignum(dpop());
dpush(tag_bignum(s48_bignum_arithmetic_shift(x,y)));
}
void primitive_bignum_less(void)
{
GC_AND_POP_BIGNUMS(x,y);
box_boolean(s48_bignum_compare(x,y) == bignum_comparison_less);
}
void primitive_bignum_lesseq(void)
{
GC_AND_POP_BIGNUMS(x,y);
switch(s48_bignum_compare(x,y))
{
case bignum_comparison_less:
case bignum_comparison_equal:
dpush(T);
break;
case bignum_comparison_greater:
dpush(F);
break;
default:
critical_error("s48_bignum_compare returns bogus value",0);
break;
}
}
void primitive_bignum_greater(void)
{
GC_AND_POP_BIGNUMS(x,y);
box_boolean(s48_bignum_compare(x,y) == bignum_comparison_greater);
}
void primitive_bignum_greatereq(void)
{
GC_AND_POP_BIGNUMS(x,y);
switch(s48_bignum_compare(x,y))
{
case bignum_comparison_less:
dpush(F);
break;
case bignum_comparison_equal:
case bignum_comparison_greater:
dpush(T);
break;
default:
critical_error("s48_bignum_compare returns bogus value",0);
break;
}
}
void primitive_bignum_not(void)
{
maybe_gc(0);
drepl(tag_bignum(s48_bignum_bitwise_not(
untag_bignum_fast(dpeek()))));
}
void box_signed_cell(F_FIXNUM integer)
{
dpush(tag_integer(integer));
}
F_FIXNUM unbox_signed_cell(void)
{
return to_fixnum(dpop());
}
void box_unsigned_cell(CELL cell)
{
dpush(tag_cell(cell));
}
F_FIXNUM unbox_unsigned_cell(void)
{
return to_cell(dpop());
}
void box_signed_4(s32 n)
{
dpush(tag_bignum(s48_long_to_bignum(n)));
}
s32 unbox_signed_4(void)
{
return to_fixnum(dpop());
}
void box_unsigned_4(u32 n)
{
dpush(tag_bignum(s48_ulong_to_bignum(n)));
}
u32 unbox_unsigned_4(void)
{
return to_cell(dpop());
}
void box_signed_8(s64 n)
{
dpush(tag_bignum(s48_long_long_to_bignum(n)));
}
s64 unbox_signed_8(void)
{
return s48_bignum_to_long_long(to_bignum(dpop()));
}
void box_unsigned_8(u64 n)
{
dpush(tag_bignum(s48_ulong_long_to_bignum(n)));
}
u64 unbox_unsigned_8(void)
{
return s48_bignum_to_ulong_long(to_bignum(dpop()));
}
/* Ratios */
/* Does not reduce to lowest terms, so should only be used by math
library implementation, to avoid breaking invariants. */
void primitive_from_fraction(void)
{
CELL numerator, denominator;
F_RATIO* ratio;
maybe_gc(0);
denominator = dpop();
numerator = dpop();
ratio = allot_object(RATIO_TYPE,sizeof(F_RATIO));
ratio->numerator = numerator;
ratio->denominator = denominator;
dpush(RETAG(ratio,RATIO_TYPE));
}
void fixup_ratio(F_RATIO* ratio)
{
data_fixup(&ratio->numerator);
data_fixup(&ratio->denominator);
}
void collect_ratio(F_RATIO* ratio)
{
copy_handle(&ratio->numerator);
copy_handle(&ratio->denominator);
}
/* Floats */
double to_float(CELL tagged)
{
F_RATIO* r;
double x;
double y;
switch(TAG(tagged))
{
case FIXNUM_TYPE:
return (double)untag_fixnum_fast(tagged);
case BIGNUM_TYPE:
return s48_bignum_to_double((F_ARRAY*)UNTAG(tagged));
case RATIO_TYPE:
r = (F_RATIO*)UNTAG(tagged);
x = to_float(r->numerator);
y = to_float(r->denominator);
return x / y;
case FLOAT_TYPE:
return ((F_FLOAT*)UNTAG(tagged))->n;
default:
type_error(FLOAT_TYPE,tagged);
return 0.0; /* can't happen */
}
}
void primitive_to_float(void)
{
maybe_gc(sizeof(F_FLOAT));
drepl(tag_float(to_float(dpeek())));
}
void primitive_str_to_float(void)
{
F_STRING* str;
char *c_str, *end;
double f;
maybe_gc(sizeof(F_FLOAT));
str = untag_string(dpeek());
c_str = to_char_string(str,true);
end = c_str;
f = strtod(c_str,&end);
if(end != c_str + string_capacity(str))
drepl(F);
else
drepl(tag_float(f));
}
void primitive_float_to_str(void)
{
char tmp[33];
maybe_gc(sizeof(F_FLOAT));
snprintf(tmp,32,"%.16g",to_float(dpop()));
tmp[32] = '\0';
box_char_string(tmp);
}
#define GC_AND_POP_FLOATS(x,y) \
double x, y; \
maybe_gc(sizeof(F_FLOAT)); \
y = untag_float_fast(dpop()); \
x = untag_float_fast(dpop());
void primitive_float_add(void)
{
GC_AND_POP_FLOATS(x,y);
dpush(tag_float(x + y));
}
void primitive_float_subtract(void)
{
GC_AND_POP_FLOATS(x,y);
dpush(tag_float(x - y));
}
void primitive_float_multiply(void)
{
GC_AND_POP_FLOATS(x,y);
dpush(tag_float(x * y));
}
void primitive_float_divfloat(void)
{
GC_AND_POP_FLOATS(x,y);
dpush(tag_float(x / y));
}
void primitive_float_mod(void)
{
GC_AND_POP_FLOATS(x,y);
dpush(tag_float(fmod(x,y)));
}
void primitive_float_less(void)
{
GC_AND_POP_FLOATS(x,y);
box_boolean(x < y);
}
void primitive_float_lesseq(void)
{
GC_AND_POP_FLOATS(x,y);
box_boolean(x <= y);
}
void primitive_float_greater(void)
{
GC_AND_POP_FLOATS(x,y);
box_boolean(x > y);
}
void primitive_float_greatereq(void)
{
GC_AND_POP_FLOATS(x,y);
box_boolean(x >= y);
}
void primitive_facos(void)
{
maybe_gc(sizeof(F_FLOAT));
drepl(tag_float(acos(to_float(dpeek()))));
}
void primitive_fasin(void)
{
maybe_gc(sizeof(F_FLOAT));
drepl(tag_float(asin(to_float(dpeek()))));
}
void primitive_fatan(void)
{
maybe_gc(sizeof(F_FLOAT));
drepl(tag_float(atan(to_float(dpeek()))));
}
void primitive_fatan2(void)
{
double x, y;
maybe_gc(sizeof(F_FLOAT));
y = to_float(dpop());
x = to_float(dpop());
dpush(tag_float(atan2(x,y)));
}
void primitive_fcos(void)
{
maybe_gc(sizeof(F_FLOAT));
drepl(tag_float(cos(to_float(dpeek()))));
}
void primitive_fexp(void)
{
maybe_gc(sizeof(F_FLOAT));
drepl(tag_float(exp(to_float(dpeek()))));
}
void primitive_fcosh(void)
{
maybe_gc(sizeof(F_FLOAT));
drepl(tag_float(cosh(to_float(dpeek()))));
}
void primitive_flog(void)
{
maybe_gc(sizeof(F_FLOAT));
drepl(tag_float(log(to_float(dpeek()))));
}
void primitive_fpow(void)
{
double x, y;
maybe_gc(sizeof(F_FLOAT));
y = to_float(dpop());
x = to_float(dpop());
dpush(tag_float(pow(x,y)));
}
void primitive_fsin(void)
{
maybe_gc(sizeof(F_FLOAT));
drepl(tag_float(sin(to_float(dpeek()))));
}
void primitive_fsinh(void)
{
maybe_gc(sizeof(F_FLOAT));
drepl(tag_float(sinh(to_float(dpeek()))));
}
void primitive_fsqrt(void)
{
maybe_gc(sizeof(F_FLOAT));
drepl(tag_float(sqrt(to_float(dpeek()))));
}
void primitive_float_bits(void)
{
FLOAT_BITS b;
b.x = (float)to_float(dpeek());
drepl(tag_cell(b.y));
}
void primitive_bits_float(void)
{
FLOAT_BITS b;
b.y = unbox_unsigned_4();
dpush(tag_float(b.x));
}
void primitive_double_bits(void)
{
DOUBLE_BITS b;
b.x = to_float(dpop());
box_unsigned_8(b.y);
}
void primitive_bits_double(void)
{
DOUBLE_BITS b;
b.y = unbox_unsigned_8();
dpush(tag_float(b.x));
}
#define FLO_DEFBOX(name,type) \
void name (type flo) \
{ \
dpush(tag_float(flo)); \
}
#define FLO_DEFUNBOX(name,type) \
type name(void) \
{ \
return to_float(dpop()); \
}
FLO_DEFBOX(box_float,float)
FLO_DEFUNBOX(unbox_float,float)
FLO_DEFBOX(box_double,double)
FLO_DEFUNBOX(unbox_double,double)
/* Complex numbers */
void primitive_from_rect(void)
{
CELL real, imaginary;
F_COMPLEX* complex;
maybe_gc(sizeof(F_COMPLEX));
imaginary = dpop();
real = dpop();
complex = allot_object(COMPLEX_TYPE,sizeof(F_COMPLEX));
complex->real = real;
complex->imaginary = imaginary;
dpush(RETAG(complex,COMPLEX_TYPE));
}
void fixup_complex(F_COMPLEX* complex)
{
data_fixup(&complex->real);
data_fixup(&complex->imaginary);
}
void collect_complex(F_COMPLEX* complex)
{
copy_handle(&complex->real);
copy_handle(&complex->imaginary);
}

187
vm/math.h Normal file
View File

@ -0,0 +1,187 @@
#define FIXNUM_MAX (((F_FIXNUM)1 << (WORD_SIZE - TAG_BITS - 1)) - 1)
#define FIXNUM_MIN (-((F_FIXNUM)1 << (WORD_SIZE - TAG_BITS - 1)))
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);
}
F_FIXNUM to_fixnum(CELL tagged);
void primitive_to_fixnum(void);
void primitive_fixnum_add(void);
void primitive_fixnum_subtract(void);
void primitive_fixnum_add_fast(void);
void primitive_fixnum_subtract_fast(void);
void primitive_fixnum_multiply(void);
void primitive_fixnum_divint(void);
void primitive_fixnum_divfloat(void);
void primitive_fixnum_divmod(void);
void primitive_fixnum_mod(void);
void primitive_fixnum_and(void);
void primitive_fixnum_or(void);
void primitive_fixnum_xor(void);
void primitive_fixnum_shift(void);
void primitive_fixnum_less(void);
void primitive_fixnum_lesseq(void);
void primitive_fixnum_greater(void);
void primitive_fixnum_greatereq(void);
void primitive_fixnum_not(void);
DLLEXPORT void box_signed_1(signed char integer);
DLLEXPORT void box_signed_2(signed short integer);
DLLEXPORT void box_unsigned_1(unsigned char integer);
DLLEXPORT void box_unsigned_2(unsigned short integer);
DLLEXPORT signed char unbox_signed_1(void);
DLLEXPORT signed short unbox_signed_2(void);
DLLEXPORT unsigned char unbox_unsigned_1(void);
DLLEXPORT unsigned short unbox_unsigned_2(void);
CELL bignum_zero;
CELL bignum_pos_one;
CELL bignum_neg_one;
INLINE F_ARRAY* untag_bignum_fast(CELL tagged)
{
return (F_ARRAY*)UNTAG(tagged);
}
INLINE CELL tag_bignum(F_ARRAY* bignum)
{
return RETAG(bignum,BIGNUM_TYPE);
}
CELL to_cell(CELL x);
F_ARRAY* to_bignum(CELL tagged);
void primitive_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_divfloat(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);
INLINE CELL tag_integer(F_FIXNUM x)
{
if(x < FIXNUM_MIN || x > FIXNUM_MAX)
return tag_bignum(s48_fixnum_to_bignum(x));
else
return tag_fixnum(x);
}
INLINE CELL tag_cell(CELL x)
{
if(x > FIXNUM_MAX)
return tag_bignum(s48_cell_to_bignum(x));
else
return tag_fixnum(x);
}
/* FFI calls this */
DLLEXPORT void box_signed_cell(F_FIXNUM integer);
DLLEXPORT F_FIXNUM unbox_signed_cell(void);
DLLEXPORT void box_unsigned_cell(CELL cell);
DLLEXPORT F_FIXNUM unbox_unsigned_cell(void);
DLLEXPORT void box_signed_4(s32 n);
DLLEXPORT s32 unbox_signed_4(void);
DLLEXPORT void box_unsigned_4(u32 n);
DLLEXPORT u32 unbox_unsigned_4(void);
DLLEXPORT void box_signed_8(s64 n);
DLLEXPORT s64 unbox_signed_8(void);
DLLEXPORT void box_unsigned_8(u64 n);
DLLEXPORT u64 unbox_unsigned_8(void);
void primitive_from_fraction(void);
void fixup_ratio(F_RATIO* ratio);
void collect_ratio(F_RATIO* ratio);
/* for punning */
typedef union {
double x;
u64 y;
} DOUBLE_BITS;
typedef union {
float x;
u32 y;
} FLOAT_BITS;
INLINE F_FLOAT* make_float(double n)
{
F_FLOAT* flo = allot_object(FLOAT_TYPE,sizeof(F_FLOAT));
flo->n = n;
return flo;
}
INLINE double untag_float_fast(CELL tagged)
{
return ((F_FLOAT*)UNTAG(tagged))->n;
}
INLINE CELL tag_float(double flo)
{
return RETAG(make_float(flo),FLOAT_TYPE);
}
double to_float(CELL tagged);
void primitive_to_float(void);
void primitive_str_to_float(void);
void primitive_float_to_str(void);
void primitive_float_to_bits(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_facos(void);
void primitive_fasin(void);
void primitive_fatan(void);
void primitive_fatan2(void);
void primitive_fcos(void);
void primitive_fexp(void);
void primitive_fcosh(void);
void primitive_flog(void);
void primitive_fpow(void);
void primitive_fsin(void);
void primitive_fsinh(void);
void primitive_fsqrt(void);
void primitive_float_bits(void);
void primitive_bits_float(void);
void primitive_double_bits(void);
void primitive_bits_double(void);
DLLEXPORT void box_float(float flo);
DLLEXPORT float unbox_float(void);
DLLEXPORT void box_double(double flo);
DLLEXPORT double unbox_double(void);
void primitive_from_rect(void);
void fixup_complex(F_COMPLEX* complex);
void collect_complex(F_COMPLEX* complex);

461
vm/memory.c
View File

@ -1,5 +1,13 @@
#include "factor.h"
void *safe_malloc(size_t size)
{
void *ptr = malloc(size);
if(ptr == 0)
fatal_error("malloc() failed", 0);
return ptr;
}
CELL object_size(CELL tagged)
{
if(tagged == F)
@ -185,3 +193,456 @@ void primitive_end_scan(void)
{
heap_scan = false;
}
/* scan all the objects in the card */
INLINE void collect_card(CARD *ptr, CELL here)
{
CARD c = *ptr;
CELL offset = (c & CARD_BASE_MASK);
CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + offset;
CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1);
if(offset == 0x7f)
{
if(c == 0xff)
critical_error("bad card",(CELL)ptr);
else
return;
}
while(card_scan < card_end && card_scan < here)
card_scan = collect_next(card_scan);
cards_scanned++;
}
INLINE void collect_gen_cards(CELL gen)
{
CARD *ptr = ADDR_TO_CARD(generations[gen].base);
CELL here = generations[gen].here;
CARD *last_card = ADDR_TO_CARD(here);
if(generations[gen].here == generations[gen].limit)
last_card--;
for(; ptr <= last_card; ptr++)
{
if(card_marked(*ptr))
collect_card(ptr,here);
}
}
void unmark_cards(CELL from, CELL to)
{
CARD *ptr = ADDR_TO_CARD(generations[from].base);
CARD *last_card = ADDR_TO_CARD(generations[to].here);
if(generations[to].here == generations[to].limit)
last_card--;
for(; ptr <= last_card; ptr++)
unmark_card(ptr);
}
void clear_cards(CELL from, CELL to)
{
/* NOTE: reverse order due to heap layout. */
CARD *last_card = ADDR_TO_CARD(generations[from].limit);
CARD *ptr = ADDR_TO_CARD(generations[to].base);
for(; ptr < last_card; ptr++)
clear_card(ptr);
}
/* scan cards in all generations older than the one being collected */
void collect_cards(CELL gen)
{
int i;
for(i = gen + 1; i < gen_count; i++)
collect_gen_cards(i);
}
/* Generational copying garbage collector */
CELL init_zone(ZONE *z, CELL size, CELL base)
{
z->base = z->here = base;
z->limit = z->base + size;
z->alarm = z->base + (size * 3) / 4;
return z->limit;
}
/* update this global variable. since it is stored in a non-volatile register,
we need to save its contents and re-initialize it when entering a callback,
and restore its contents when leaving the callback. see stack.c */
void update_cards_offset(void)
{
cards_offset = (CELL)cards - (heap_start >> CARD_BITS);
}
/* input parameters must be 8 byte aligned */
/* the heap layout is important:
- two semispaces: tenured and prior
- younger generations follow
there are two reasons for this:
- we can easily check if a pointer is in some generation or a younger one
- the nursery grows into the guard page, so allot() does not have to
check for out of memory, whereas allot_zone() (used by the GC) longjmp()s
back to collecting a higher generation */
void init_arena(CELL gens, CELL young_size, CELL aging_size)
{
int i;
CELL alloter;
CELL total_size = (gens - 1) * young_size + 2 * aging_size;
CELL cards_size = total_size / CARD_SIZE;
gen_count = gens;
generations = safe_malloc(sizeof(ZONE) * gen_count);
heap_start = (CELL)(alloc_bounded_block(total_size)->start);
heap_end = heap_start + total_size;
cards = safe_malloc(cards_size);
cards_end = cards + cards_size;
update_cards_offset();
alloter = heap_start;
alloter = init_zone(&tenured,aging_size,alloter);
alloter = init_zone(&prior,aging_size,alloter);
for(i = gen_count - 2; i >= 0; i--)
alloter = init_zone(&generations[i],young_size,alloter);
clear_cards(NURSERY,TENURED);
if(alloter != heap_start + total_size)
fatal_error("Oops",alloter);
heap_scan = false;
gc_time = 0;
minor_collections = 0;
cards_scanned = 0;
}
void collect_callframe_triple(CELL *callframe,
CELL *callframe_scan, CELL *callframe_end)
{
*callframe_scan -= *callframe;
*callframe_end -= *callframe;
copy_handle(callframe);
*callframe_scan += *callframe;
*callframe_end += *callframe;
}
void collect_stack(BOUNDED_BLOCK *region, CELL top)
{
CELL bottom = region->start;
CELL ptr;
for(ptr = bottom; ptr <= top; ptr += CELLS)
copy_handle((CELL*)ptr);
}
void collect_callstack(BOUNDED_BLOCK *region, CELL top)
{
CELL bottom = region->start;
CELL ptr;
for(ptr = bottom; ptr <= top; ptr += CELLS * 3)
collect_callframe_triple((CELL*)ptr,
(CELL*)ptr + 1, (CELL*)ptr + 2);
}
void collect_roots(void)
{
int i;
STACKS *stacks;
copy_handle(&T);
copy_handle(&bignum_zero);
copy_handle(&bignum_pos_one);
copy_handle(&bignum_neg_one);
collect_callframe_triple(&callframe,&callframe_scan,&callframe_end);
save_stacks();
stacks = stack_chain;
while(stacks)
{
collect_stack(stacks->data_region,stacks->data);
collect_stack(stacks->retain_region,stacks->retain);
collect_callstack(stacks->call_region,stacks->call);
if(stacks->next != NULL)
{
collect_callframe_triple(&stacks->callframe,
&stacks->callframe_scan,&stacks->callframe_end);
}
copy_handle(&stacks->catch_save);
stacks = stacks->next;
}
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)
{
void *newpointer;
if(newspace->here + size >= newspace->limit)
longjmp(gc_jmp,1);
newpointer = allot_zone(newspace,size);
memcpy(newpointer,pointer,size);
return newpointer;
}
INLINE CELL copy_object_impl(CELL pointer)
{
CELL newpointer = (CELL)copy_untagged_object((void*)UNTAG(pointer),
object_size(pointer));
/* install forwarding pointer */
put(UNTAG(pointer),RETAG(newpointer,GC_COLLECTED));
return newpointer;
}
/* follow a chain of forwarding pointers */
CELL resolve_forwarding(CELL untagged, CELL tag)
{
CELL header = get(untagged);
/* another forwarding pointer */
if(TAG(header) == GC_COLLECTED)
return resolve_forwarding(UNTAG(header),tag);
/* we've found the destination */
else
{
CELL pointer = RETAG(untagged,tag);
if(should_copy(untagged))
pointer = RETAG(copy_object_impl(pointer),tag);
return pointer;
}
}
/*
Given a pointer to a tagged pointer to oldspace, copy it to newspace.
If the object has already been copied, return the forwarding
pointer address without copying anything; otherwise, install
a new forwarding pointer.
*/
CELL copy_object(CELL pointer)
{
CELL tag;
CELL header;
if(pointer == F)
return F;
tag = TAG(pointer);
if(tag == FIXNUM_TYPE)
return pointer;
header = get(UNTAG(pointer));
if(TAG(header) == GC_COLLECTED)
return resolve_forwarding(UNTAG(header),tag);
else
return RETAG(copy_object_impl(pointer),tag);
}
INLINE void collect_object(CELL scan)
{
switch(untag_header(get(scan)))
{
case RATIO_TYPE:
collect_ratio((F_RATIO*)scan);
break;
case COMPLEX_TYPE:
collect_complex((F_COMPLEX*)scan);
break;
case WORD_TYPE:
collect_word((F_WORD*)scan);
break;
case ARRAY_TYPE:
case TUPLE_TYPE:
case QUOTATION_TYPE:
collect_array((F_ARRAY*)scan);
break;
case HASHTABLE_TYPE:
collect_hashtable((F_HASHTABLE*)scan);
break;
case VECTOR_TYPE:
collect_vector((F_VECTOR*)scan);
break;
case SBUF_TYPE:
collect_sbuf((F_SBUF*)scan);
break;
case DLL_TYPE:
collect_dll((DLL*)scan);
break;
case ALIEN_TYPE:
collect_alien((ALIEN*)scan);
break;
case WRAPPER_TYPE:
collect_wrapper((F_WRAPPER*)scan);
break;
}
}
CELL collect_next(CELL scan)
{
CELL size = untagged_object_size(scan);
collect_object(scan);
return scan + size;
}
void reset_generations(CELL from, CELL to)
{
CELL i;
for(i = from; i <= to; i++)
generations[i].here = generations[i].base;
clear_cards(from,to);
}
void begin_gc(CELL gen)
{
collecting_gen = gen;
collecting_gen_start = generations[gen].base;
if(gen == TENURED)
{
/* when collecting the oldest generation, rotate it
with the semispace */
ZONE z = generations[gen];
generations[gen] = prior;
prior = z;
generations[gen].here = generations[gen].base;
newspace = &generations[gen];
clear_cards(TENURED,TENURED);
}
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 = &generations[gen + 1];
}
}
void end_gc(CELL gen)
{
if(gen == TENURED)
{
/* we did a full collection; no more
old-to-new pointers remain since everything
is in tenured space */
unmark_cards(TENURED,TENURED);
/* all generations except tenured space are
now empty */
reset_generations(NURSERY,TENURED - 1);
fprintf(stderr,"*** Major GC (%ld minor, %ld cards)\n",
minor_collections,cards_scanned);
minor_collections = 0;
cards_scanned = 0;
}
else
{
/* we collected a younger generation. so the
next-oldest generation no longer has any
pointers into the younger generation (the
younger generation is empty!) */
unmark_cards(gen + 1,gen + 1);
/* all generations up to and including the one
collected are now empty */
reset_generations(NURSERY,gen);
minor_collections++;
}
}
/* collect gen and all younger generations */
void garbage_collection(CELL gen)
{
s64 start = current_millis();
CELL scan;
if(heap_scan)
critical_error("GC disabled during heap scan",gen);
/* we come back here if a generation is full */
if(setjmp(gc_jmp))
{
if(gen == TENURED)
{
/* oops, out of memory */
critical_error("Out of memory",0);
}
else
gen++;
}
begin_gc(gen);
/* initialize chase pointer */
scan = newspace->here;
/* collect objects referenced from stacks and environment */
collect_roots();
/* collect objects referenced from older generations */
collect_cards(gen);
/* collect literal objects referenced from compiled code */
collect_literals();
while(scan < newspace->here)
scan = collect_next(scan);
end_gc(gen);
gc_time += (current_millis() - start);
}
void primitive_gc(void)
{
CELL gen = to_fixnum(dpop());
if(gen <= NURSERY)
gen = NURSERY;
else if(gen >= TENURED)
gen = TENURED;
garbage_collection(gen);
}
/* WARNING: only call this from a context where all local variables
are also reachable via the GC roots. */
void maybe_gc(CELL size)
{
if(nursery.here + size > nursery.alarm)
{
CELL gen = NURSERY;
while(gen < TENURED)
{
ZONE *z = &generations[gen + 1];
if(z->here < z->alarm)
break;
gen++;
}
garbage_collection(gen);
}
}
void simple_gc(void)
{
maybe_gc(0);
}
void primitive_gc_time(void)
{
simple_gc();
dpush(tag_bignum(s48_long_long_to_bignum(gc_time)));
}

235
vm/memory.h
View File

@ -1,3 +1,5 @@
void *safe_malloc(size_t size);
typedef struct {
CELL start;
CELL size;
@ -35,44 +37,6 @@ INLINE CELL align8(CELL a)
return (a + 7) & ~7;
}
#define TAG_MASK 7
#define TAG_BITS 3
#define TAG(cell) ((CELL)(cell) & TAG_MASK)
#define RETAG(cell,tag) ((CELL)(cell) | (tag))
#define UNTAG(cell) ((CELL)(cell) & ~TAG_MASK)
/*** Tags ***/
#define FIXNUM_TYPE 0
#define BIGNUM_TYPE 1
#define WORD_TYPE 2
#define OBJECT_TYPE 3
#define RATIO_TYPE 4
#define FLOAT_TYPE 5
#define COMPLEX_TYPE 6
#define WRAPPER_TYPE 7
#define HEADER_TYPE 7 /* anything less than or equal to this is a tag */
#define GC_COLLECTED 0 /* See gc.c */
/*** Header types ***/
#define ARRAY_TYPE 8
/* Canonical F object */
#define F_TYPE 9
#define F RETAG(0,OBJECT_TYPE)
#define HASHTABLE_TYPE 10
#define VECTOR_TYPE 11
#define STRING_TYPE 12
#define SBUF_TYPE 13
#define QUOTATION_TYPE 14
#define DLL_TYPE 15
#define ALIEN_TYPE 16
#define TUPLE_TYPE 17
#define BYTE_ARRAY_TYPE 18
#define TYPE_COUNT 19
/* Canonical T object. It's just a word */
CELL T;
@ -133,3 +97,198 @@ void primitive_clone(void);
void primitive_begin_scan(void);
void primitive_next_object(void);
void primitive_end_scan(void);
CELL heap_start;
CELL heap_end;
/* 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.
*/
#define CARD_MARK_MASK 0x80
#define CARD_BASE_MASK 0x7f
typedef u8 CARD;
CARD *cards;
CARD *cards_end;
/* A card is 16 bytes (128 bits), 5 address bits per card.
it is important that 7 bits is sufficient to represent every
offset within the card */
#define CARD_SIZE 128
#define CARD_BITS 7
#define ADDR_CARD_MASK (CARD_SIZE-1)
INLINE CARD card_marked(CARD c)
{
return c & CARD_MARK_MASK;
}
INLINE void unmark_card(CARD *c)
{
*c &= CARD_BASE_MASK;
}
INLINE void clear_card(CARD *c)
{
*c = CARD_BASE_MASK; /* invalid value */
}
INLINE u8 card_base(CARD c)
{
return c & CARD_BASE_MASK;
}
#define ADDR_TO_CARD(a) (CARD*)(((CELL)a >> CARD_BITS) + cards_offset)
#define CARD_TO_ADDR(c) (CELL*)(((CELL)c - cards_offset)<<CARD_BITS)
/* this is an inefficient write barrier. compiled definitions use a more
efficient one hand-coded in assembly. 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)
{
CARD *c = ADDR_TO_CARD(address);
*c |= CARD_MARK_MASK;
}
/* we need to remember the first object allocated in the card */
INLINE void allot_barrier(CELL address)
{
CARD *ptr = ADDR_TO_CARD(address);
CARD c = *ptr;
CELL b = card_base(c);
CELL a = (address & ADDR_CARD_MASK);
*ptr = (card_marked(c) | ((b < a) ? b : a));
}
void unmark_cards(CELL from, CELL to);
void clear_cards(CELL from, CELL to);
void collect_cards(CELL gen);
/* generational copying GC divides memory into zones */
typedef struct {
/* start of zone */
CELL base;
/* allocation pointer */
CELL here;
/* only for nursery: when it gets this full, call GC */
CELL alarm;
/* end of zone */
CELL limit;
} ZONE;
/* total number of generations. */
CELL gen_count;
/* the 0th generation is where new objects are allocated. */
#define NURSERY 0
/* the oldest generation */
#define TENURED (gen_count-1)
DLLEXPORT ZONE *generations;
/* used during garbage collection only */
ZONE *newspace;
#define tenured generations[TENURED]
#define nursery generations[NURSERY]
/* spare semi-space; rotates with tenured. */
ZONE prior;
/* compiled code */
ZONE compiling;
INLINE bool in_zone(ZONE* z, CELL pointer)
{
return pointer >= z->base && pointer < z->limit;
}
CELL init_zone(ZONE *z, CELL size, CELL base);
void init_arena(CELL gen_count, CELL young_size, CELL aging_size);
/* statistics */
s64 gc_time;
CELL minor_collections;
CELL cards_scanned;
/* only meaningful during a GC */
CELL collecting_gen;
CELL collecting_gen_start;
/* test if the pointer is in generation being collected, or a younger one.
init_arena() arranges things so that the older generations are first,
so we have to check that the pointer occurs after the beginning of
the requested generation. */
#define COLLECTING_GEN(ptr) (collecting_gen_start <= ptr)
INLINE bool should_copy(CELL untagged)
{
if(collecting_gen == TENURED)
return !in_zone(newspace,untagged);
else
return(in_zone(&prior,untagged) || COLLECTING_GEN(untagged));
}
CELL copy_object(CELL pointer);
#define COPY_OBJECT(lvalue) if(should_copy(lvalue)) lvalue = copy_object(lvalue)
INLINE void copy_handle(CELL *handle)
{
COPY_OBJECT(*handle);
}
/* 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;
/* A heap walk allows useful things to be done, like finding all
references to an object for debugging purposes. */
CELL heap_scan_ptr;
/* GC is off during heap walking */
bool heap_scan;
INLINE void *allot_zone(ZONE *z, CELL a)
{
CELL h = z->here;
z->here = h + align8(a);
if(z->here > z->limit)
{
fprintf(stderr,"Nursery space exhausted\n");
factorbug();
}
allot_barrier(h);
return (void*)h;
}
INLINE void *allot(CELL a)
{
return allot_zone(&nursery,a);
}
/*
* It is up to the caller to fill in the object's fields in a meaningful
* fashion!
*/
INLINE void* allot_object(CELL type, CELL length)
{
CELL* object = allot(length);
*object = tag_header(type);
return object;
}
void update_cards_offset(void);
CELL collect_next(CELL scan);
void garbage_collection(CELL gen);
void primitive_gc(void);
void maybe_gc(CELL size);
DLLEXPORT void simple_gc(void);
void primitive_gc_time(void);

97
vm/misc.c
View File

@ -1,97 +0,0 @@
#include "factor.h"
void *safe_malloc(size_t size)
{
void *ptr = malloc(size);
if(ptr == 0)
fatal_error("malloc() failed", 0);
return ptr;
}
void primitive_exit(void)
{
exit(to_fixnum(dpop()));
}
void primitive_os_env(void)
{
char *name, *value;
maybe_gc(0);
name = pop_char_string();
value = getenv(name);
if(value == NULL)
dpush(F);
else
box_char_string(getenv(name));
}
void primitive_eq(void)
{
box_boolean(dpop() == dpop());
}
#ifdef WIN32
s64 current_millis(void)
{
FILETIME t;
GetSystemTimeAsFileTime(&t);
return (((s64)t.dwLowDateTime | (s64)t.dwHighDateTime<<32) - EPOCH_OFFSET)
/ 10000;
}
#else
s64 current_millis(void)
{
struct timeval t;
gettimeofday(&t,NULL);
return (s64)t.tv_sec * 1000 + t.tv_usec/1000;
}
#endif
void primitive_millis(void)
{
maybe_gc(0);
dpush(tag_bignum(s48_long_long_to_bignum(current_millis())));
}
#ifdef WIN32
// frees memory allocated by win32 api calls
char *buffer_to_c_string(char *buffer)
{
int capacity = strlen(buffer);
F_STRING *_c_str = allot_string(capacity / CHARS + 1);
u8 *c_str = (u8*)(_c_str + 1);
strcpy(c_str, buffer);
LocalFree(buffer);
return (char*)c_str;
}
F_STRING *get_error_message()
{
DWORD id = GetLastError();
return from_c_string(error_message(id));
}
char *error_message(DWORD id)
{
char *buffer;
int index;
FormatMessage(
FORMAT_MESSAGE_ALLOCATE_BUFFER |
FORMAT_MESSAGE_FROM_SYSTEM,
NULL,
id,
MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
(LPTSTR) &buffer,
0, NULL);
// strip whitespace from end
index = strlen(buffer) - 1;
while(index >= 0 && isspace(buffer[index]))
buffer[index--] = 0;
return buffer_to_c_string(buffer);
}
#endif

11
vm/misc.h
View File

@ -1,11 +0,0 @@
void *safe_malloc(size_t size);
void primitive_exit(void);
void primitive_os_env(void);
void primitive_eq(void);
s64 current_millis(void);
void primitive_millis(void);
#ifdef WIN32
char *buffer_to_c_string(char *buffer);
F_STRING *get_error_message(void);
DLLEXPORT char *error_message(DWORD id);
#endif

1
vm/os-freebsd.h Normal file
View File

@ -0,0 +1 @@
#define FACTOR_OS_STRING "freebsd"

9
vm/unix/run.c → vm/os-genunix.c
View File

@ -1,13 +1,16 @@
#include "../factor.h"
#include "factor.h"
void platform_run(void)
{
run_toplevel();
}
void early_init(void) {}
const char *default_image_path(void)
{
return "factor.image";
}
void init_signals(void)
{
unix_init_signals();
}

3
vm/os-genunix.h Normal file
View File

@ -0,0 +1,3 @@
void init_signals(void);
INLINE void early_init(void) {}
const char *default_image_path(void);

1
vm/os-linux.h Normal file
View File

@ -0,0 +1 @@
#define FACTOR_OS_STRING "linux"

8
vm/os-macosx-ppc.h Normal file
View File

@ -0,0 +1,8 @@
#define SIGSEGV_EXC_STATE_TYPE ppc_exception_state_t
#define SIGSEGV_EXC_STATE_FLAVOR PPC_EXCEPTION_STATE
#define SIGSEGV_EXC_STATE_COUNT PPC_EXCEPTION_STATE_COUNT
#define SIGSEGV_THREAD_STATE_TYPE ppc_thread_state_t
#define SIGSEGV_THREAD_STATE_FLAVOR PPC_THREAD_STATE
#define SIGSEGV_THREAD_STATE_COUNT PPC_THREAD_STATE_COUNT
#define SIGSEGV_STACK_POINTER(thr_state) (thr_state).r1
#define SIGSEGV_PROGRAM_COUNTER(thr_state) (thr_state).srr0

8
vm/os-macosx-x86.h Normal file
View File

@ -0,0 +1,8 @@
#define SIGSEGV_EXC_STATE_TYPE i386_exception_state_t
#define SIGSEGV_EXC_STATE_FLAVOR i386_EXCEPTION_STATE
#define SIGSEGV_EXC_STATE_COUNT i386_EXCEPTION_STATE_COUNT
#define SIGSEGV_THREAD_STATE_TYPE i386_thread_state_t
#define SIGSEGV_THREAD_STATE_FLAVOR i386_THREAD_STATE
#define SIGSEGV_THREAD_STATE_COUNT i386_THREAD_STATE_COUNT
#define SIGSEGV_STACK_POINTER(thr_state) (thr_state).esp
#define SIGSEGV_PROGRAM_COUNTER(thr_state) (thr_state).eip

4
vm/os-macosx.h Normal file
View File

@ -0,0 +1,4 @@
#define FACTOR_OS_STRING "macosx"
void init_signals(void);
void early_init(void);
const char *default_image_path(void);

9
vm/macosx/run.m → vm/os-macosx.m
View File

@ -1,6 +1,5 @@
/* Cocoa exception handling and default image path for Mac OS X */
#include "factor.h"
#include "../factor.h"
#import "Foundation/NSAutoreleasePool.h"
#import "Foundation/NSBundle.h"
#import "Foundation/NSException.h"
@ -47,3 +46,9 @@ const char *default_image_path(void)
NSString *image = [[bundle resourcePath] stringByAppendingString:@"/factor.image"];
return [image cString];
}
void init_signals(void)
{
unix_init_signals();
mach_initialize();
}

1
vm/os-solaris.h Normal file
View File

@ -0,0 +1 @@
#define FACTOR_OS_STRING "solaris"

241
vm/os-unix.c Normal file
View File

@ -0,0 +1,241 @@
#include "factor.h"
static void *null_dll;
s64 current_millis(void)
{
struct timeval t;
gettimeofday(&t,NULL);
return (s64)t.tv_sec * 1000 + t.tv_usec/1000;
}
void init_ffi(void)
{
null_dll = dlopen(NULL,RTLD_LAZY);
}
void ffi_dlopen(DLL *dll, bool error)
{
void *dllptr = dlopen(to_char_string(untag_string(dll->path),true), RTLD_LAZY);
if(dllptr == NULL)
{
if(error)
{
general_error(ERROR_FFI,tag_object(
from_char_string(dlerror())),F,true);
}
else
dll->dll = NULL;
return;
}
dll->dll = dllptr;
}
void *ffi_dlsym(DLL *dll, F_STRING *symbol, bool error)
{
void *handle = (dll == NULL ? null_dll : dll->dll);
void *sym = dlsym(handle,to_char_string(symbol,true));
if(sym == NULL)
{
if(error)
{
general_error(ERROR_FFI,tag_object(
from_char_string(dlerror())),F,true);
}
return NULL;
}
return sym;
}
void ffi_dlclose(DLL *dll)
{
if(dlclose(dll->dll))
{
general_error(ERROR_FFI,tag_object(
from_char_string(dlerror())),F,true);
}
dll->dll = NULL;
}
void primitive_stat(void)
{
struct stat sb;
F_STRING* path;
maybe_gc(0);
path = untag_string(dpop());
if(stat(to_char_string(path,true),&sb) < 0)
dpush(F);
else
{
CELL dirp = tag_boolean(S_ISDIR(sb.st_mode));
CELL mode = tag_fixnum(sb.st_mode & ~S_IFMT);
CELL size = tag_bignum(s48_long_long_to_bignum(sb.st_size));
CELL mtime = tag_integer(sb.st_mtime);
dpush(make_array_4(dirp,mode,size,mtime));
}
}
void primitive_read_dir(void)
{
F_STRING *path;
DIR* dir;
F_ARRAY *result;
CELL result_count = 0;
maybe_gc(0);
result = array(ARRAY_TYPE,100,F);
path = untag_string(dpop());
dir = opendir(to_char_string(path,true));
if(dir != NULL)
{
struct dirent* file;
while((file = readdir(dir)) != NULL)
{
CELL name = tag_object(from_char_string(file->d_name));
if(result_count == array_capacity(result))
{
result = resize_array(result,
result_count * 2,F);
}
put(AREF(result,result_count),name);
result_count++;
}
closedir(dir);
}
result = resize_array(result,result_count,F);
dpush(tag_object(result));
}
void primitive_cwd(void)
{
char wd[MAXPATHLEN];
maybe_gc(0);
if(getcwd(wd,MAXPATHLEN) == NULL)
io_error();
box_char_string(wd);
}
void primitive_cd(void)
{
maybe_gc(0);
chdir(pop_char_string());
}
BOUNDED_BLOCK *alloc_bounded_block(CELL size)
{
int pagesize = getpagesize();
char *array = mmap((void*)0,pagesize + size + pagesize,
PROT_READ | PROT_WRITE | PROT_EXEC,
MAP_ANON | MAP_PRIVATE,-1,0);
if(array == NULL)
fatal_error("Cannot allocate memory region",0);
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);
BOUNDED_BLOCK *retval = safe_malloc(sizeof(BOUNDED_BLOCK));
retval->start = (CELL)(array + pagesize);
retval->size = size;
return retval;
}
void dealloc_bounded_block(BOUNDED_BLOCK *block)
{
int pagesize = getpagesize();
int retval = munmap((void*)(block->start - pagesize),
pagesize + block->size + pagesize);
if(retval)
fatal_error("Failed to unmap region",0);
free(block);
}
// this function tests if a given faulting location is in a poison page. The
// page address is taken from area + round_up_to_page_size(area_size) +
// pagesize*offset
static bool in_page(void *fault, void *i_area, CELL area_size, int offset)
{
const int pagesize = getpagesize();
intptr_t area = (intptr_t) i_area;
area += pagesize * ((area_size + (pagesize - 1)) / pagesize);
area += offset * pagesize;
const int page = area / pagesize;
const int fault_page = (intptr_t)fault / pagesize;
return page == fault_page;
}
void signal_handler(int signal, siginfo_t* siginfo, void* uap)
{
if(in_page(siginfo->si_addr, (void *) ds_bot, 0, -1))
general_error(ERROR_DS_UNDERFLOW,F,F,false);
else if(in_page(siginfo->si_addr, (void *) ds_bot, ds_size, 0))
general_error(ERROR_DS_OVERFLOW,F,F,false);
else if(in_page(siginfo->si_addr, (void *) rs_bot, 0, -1))
general_error(ERROR_RS_UNDERFLOW,F,F,false);
else if(in_page(siginfo->si_addr, (void *) rs_bot, rs_size, 0))
general_error(ERROR_RS_OVERFLOW,F,F,false);
else if(in_page(siginfo->si_addr, (void *) cs_bot, 0, -1))
general_error(ERROR_CS_UNDERFLOW,F,F,false);
else if(in_page(siginfo->si_addr, (void *) cs_bot, cs_size, 0))
general_error(ERROR_CS_OVERFLOW,F,F,false);
else
signal_error(signal);
}
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);
}
void unix_init_signals(void)
{
struct sigaction custom_sigaction;
struct sigaction ign_sigaction;
sigemptyset(&custom_sigaction.sa_mask);
custom_sigaction.sa_sigaction = signal_handler;
custom_sigaction.sa_flags = SA_SIGINFO;
sigaction_safe(SIGABRT,&custom_sigaction,NULL);
sigaction_safe(SIGFPE,&custom_sigaction,NULL);
sigaction_safe(SIGBUS,&custom_sigaction,NULL);
sigaction_safe(SIGQUIT,&custom_sigaction,NULL);
sigaction_safe(SIGSEGV,&custom_sigaction,NULL);
sigaction_safe(SIGILL,&custom_sigaction,NULL);
sigemptyset(&ign_sigaction.sa_mask);
ign_sigaction.sa_handler = SIG_IGN;
sigaction_safe(SIGPIPE,&ign_sigaction,NULL);
}
void reset_stdio(void)
{
fcntl(0,F_SETFL,0);
fcntl(1,F_SETFL,0);
}

31
vm/os-unix.h Normal file
View File

@ -0,0 +1,31 @@
#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>
#define DLLEXPORT
#define SETJMP(jmpbuf) sigsetjmp(jmpbuf,1)
#define LONGJMP siglongjmp
#define JMP_BUF sigjmp_buf
void init_ffi(void);
void ffi_dlopen(DLL *dll, bool error);
void *ffi_dlsym(DLL *dll, F_STRING *symbol, bool error);
void ffi_dlclose(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);
void primitive_open_file(void);
void primitive_stat(void);
void primitive_read_dir(void);
void primitive_cwd(void);
void primitive_cd(void);
s64 current_millis(void);
void reset_stdio(void);

234
vm/os-windows.c Normal file
View File

@ -0,0 +1,234 @@
#include "factor.h"
// frees memory allocated by win32 api calls
char *buffer_to_c_string(char *buffer)
{
int capacity = strlen(buffer);
F_STRING *_c_str = allot_string(capacity / CHARS + 1);
u8 *c_str = (u8*)(_c_str + 1);
strcpy(c_str, buffer);
LocalFree(buffer);
return (char*)c_str;
}
F_STRING *get_error_message()
{
DWORD id = GetLastError();
return from_c_string(error_message(id));
}
char *error_message(DWORD id)
{
char *buffer;
int index;
FormatMessage(
FORMAT_MESSAGE_ALLOCATE_BUFFER |
FORMAT_MESSAGE_FROM_SYSTEM,
NULL,
id,
MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
(LPTSTR) &buffer,
0, NULL);
// strip whitespace from end
index = strlen(buffer) - 1;
while(index >= 0 && isspace(buffer[index]))
buffer[index--] = 0;
return buffer_to_c_string(buffer);
}
s64 current_millis(void)
{
FILETIME t;
GetSystemTimeAsFileTime(&t);
return (((s64)t.dwLowDateTime | (s64)t.dwHighDateTime<<32) - EPOCH_OFFSET)
/ 10000;
}
void ffi_dlopen (DLL *dll, bool error)
{
HMODULE module;
char *path = to_c_string(untag_string(dll->path),true);
module = LoadLibrary(path);
if (!module)
{
dll->dll = NULL;
if(error)
general_error(ERROR_FFI, tag_object(get_error_message()),true);
else
return;
}
dll->dll = module;
}
void *ffi_dlsym (DLL *dll, F_STRING *symbol, bool error)
{
void *sym = GetProcAddress(dll ? (HMODULE)dll->dll : GetModuleHandle(NULL),
to_c_string(symbol,true));
if (!sym)
{
if(error)
general_error(ERROR_FFI, tag_object(get_error_message()),true);
else
return NULL;
}
return sym;
}
void ffi_dlclose (DLL *dll)
{
FreeLibrary((HMODULE)dll->dll);
dll->dll = NULL;
}
void primitive_stat(void)
{
F_STRING *path;
WIN32_FILE_ATTRIBUTE_DATA st;
maybe_gc(0);
path = untag_string(dpop());
if(!GetFileAttributesEx(to_c_string(path,true), GetFileExInfoStandard, &st))
{
dpush(F);
}
else
{
CELL dirp = tag_boolean(st.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY);
CELL size = tag_bignum(s48_long_long_to_bignum(
(s64)st.nFileSizeLow | (s64)st.nFileSizeHigh << 32));
CELL mtime = tag_integer((int)
((*(s64*)&st.ftLastWriteTime - EPOCH_OFFSET) / 10000000));
dpush(make_array_4(dirp,tag_fixnum(0),size,mtime));
}
}
void primitive_read_dir(void)
{
F_STRING *path;
HANDLE dir;
WIN32_FIND_DATA find_data;
F_ARRAY *result;
CELL result_count = 0;
maybe_gc(0);
result = array(ARRAY_TYPE,100,F);
path = untag_string(dpop());
if (INVALID_HANDLE_VALUE != (dir = FindFirstFile(".\\*", &find_data)))
{
do
{
CELL name = tag_object(from_c_string(
find_data.cFileName));
if(result_count == array_capacity(result))
{
result = resize_array(result,
result_count * 2,F);
}
put(AREF(result,result_count),name);
result_count++;
}
while (FindNextFile(dir, &find_data));
CloseHandle(dir);
}
result = resize_array(result,result_count,F);
dpush(tag_object(result));
}
void primitive_cwd(void)
{
char buf[MAX_PATH];
maybe_gc(0);
if(!GetCurrentDirectory(MAX_PATH, buf))
io_error();
box_c_string(buf);
}
void primitive_cd(void)
{
maybe_gc(0);
SetCurrentDirectory(pop_c_string());
}
BOUNDED_BLOCK *alloc_bounded_block(CELL size)
{
SYSTEM_INFO si;
char *mem;
DWORD ignore;
GetSystemInfo(&si);
if((mem = (char *)VirtualAlloc(NULL, si.dwPageSize*2 + size, MEM_COMMIT, PAGE_EXECUTE_READWRITE)) == 0)
fatal_error("VirtualAlloc() failed in alloc_bounded_block()",0);
if (!VirtualProtect(mem, si.dwPageSize, PAGE_NOACCESS, &ignore))
fatal_error("Cannot allocate low guard page", (CELL)mem);
if (!VirtualProtect(mem+size+si.dwPageSize, si.dwPageSize, PAGE_NOACCESS, &ignore))
fatal_error("Cannot allocate high guard page", (CELL)mem);
BOUNDED_BLOCK *block = safe_malloc(sizeof(BOUNDED_BLOCK));
block->start = (int)mem + si.dwPageSize;
block->size = size;
return block;
}
void dealloc_bounded_block(BOUNDED_BLOCK *block)
{
SYSTEM_INFO si;
GetSystemInfo(&si);
if(!VirtualFree((void*)(block->start - si.dwPageSize), 0, MEM_RELEASE))
fatal_error("VirtualFree() failed",0);
free(block);
}
/* SEH support. Proceed with caution. */
typedef long exception_handler_t(
void *rec, void *frame, void *context, void *dispatch);
typedef struct exception_record {
struct exception_record *next_handler;
void *handler_func;
} exception_record_t;
void seh_call(void (*func)(), exception_handler_t *handler)
{
exception_record_t record;
asm("mov %%fs:0, %0" : "=r" (record.next_handler));
asm("mov %0, %%fs:0" : : "r" (&record));
record.handler_func = handler;
func();
asm("mov %0, %%fs:0" : "=r" (record.next_handler));
}
static long exception_handler(void *rec, void *frame, void *ctx, void *dispatch)
{
signal_error(SIGSEGV);
}
void platform_run(void)
{
seh_call(run_toplevel, exception_handler);
}
const char *default_image_path(void)
{
return "factor.image";
}

35
vm/os-windows.h Normal file
View File

@ -0,0 +1,35 @@
#include <windows.h>
#include <ctype.h>
#define FACTOR_OS_STRING "windows"
#define DLLEXPORT __declspec(dllexport)
#define SETJMP setjmp
#define LONGJMP longjmp
#define JMP_BUF jmp_buf
/* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */
#define EPOCH_OFFSET 0x019db1ded53e8000LL
char *buffer_to_c_string(char *buffer);
F_STRING *get_error_message(void);
DLLEXPORT char *error_message(DWORD id);
INLINE void init_ffi(void) {}
void ffi_dlopen(DLL *dll, bool error);
void *ffi_dlsym(DLL *dll, F_STRING *symbol, bool error);
void ffi_dlclose(DLL *dll);
void primitive_open_file(void);
void primitive_stat(void);
void primitive_read_dir(void);
void primitive_cwd(void);
void primitive_cd(void);
INLINE void init_signals(void) {}
INLINE void early_init(void) {}
const char *default_image_path(void);
s64 current_millis(void);
INLINE void reset_stdio(void) {}

71
vm/platform.h
View File

@ -1,3 +1,5 @@
#define INLINE inline static
#if defined(i386) || defined(__i386) || defined(__i386__) || defined(WIN32)
#define FACTOR_X86
#elif defined(__POWERPC__) || defined(__ppc__) || defined(_ARCH_PPC)
@ -6,47 +8,40 @@
#define FACTOR_AMD64
#endif
#ifdef __APPLE__
/* Horray for Mach-O */
#define MANGLE(sym) _##sym
#else
#define MANGLE(sym) sym
#endif
#if defined(FACTOR_X86)
#define FACTOR_CPU_STRING "x86"
#elif defined(FACTOR_PPC)
#define FACTOR_CPU_STRING "ppc"
#elif defined(FACTOR_AMD64)
#define FACTOR_CPU_STRING "amd64"
#else
#define FACTOR_CPU_STRING "unknown"
#endif
#ifdef WINDOWS
#define FACTOR_OS_STRING "windows"
#elif defined(__FreeBSD__)
#define FACTOR_OS_STRING "freebsd"
#elif defined(linux)
#define FACTOR_OS_STRING "linux"
#elif defined(__APPLE__)
#define FACTOR_OS_STRING "macosx"
#elif defined(__sun)
#define FACTOR_OS_STRING "solaris"
#include "os-windows.h"
#else
#define FACTOR_OS_STRING "unix"
#include "os-unix.h"
#ifdef __APPLE__
#include "os-macosx.h"
#include "mach_signal.h"
#ifdef FACTOR_X86
#include "os-macosx-x86.h"
#elif defined(FACTOR_PPC)
#include "os-macosx-ppc.h"
#endif
#else
#include "os-genunix.h"
#ifdef __FreeBSD__
#include "os-freebsd.h"
#elif defined(linux)
#include "os-linux.h"
#elif defined(__sun)
#include "os-solaris.h"
#else
#error "Unsupported OS"
#endif
#endif
#endif
#if defined(WIN32)
#define DLLEXPORT __declspec(dllexport)
#define SETJMP setjmp
#define LONGJMP longjmp
#define JMP_BUF jmp_buf
#ifdef FACTOR_X86
#include "cpu-x86.h"
#elif defined(FACTOR_PPC)
#include "cpu-ppc.h"
#elif defined(FACTOR_AMD64)
#include "cpu-amd64.h"
#else
#define DLLEXPORT
#define SETJMP(jmpbuf) sigsetjmp(jmpbuf,1)
#define LONGJMP siglongjmp
#define JMP_BUF sigjmp_buf
#error "Unsupported CPU"
#endif
#define INLINE inline static

30
vm/ratio.c
View File

@ -1,30 +0,0 @@
#include "factor.h"
/* Does not reduce to lowest terms, so should only be used by math
library implementation, to avoid breaking invariants. */
void primitive_from_fraction(void)
{
CELL numerator, denominator;
F_RATIO* ratio;
maybe_gc(0);
denominator = dpop();
numerator = dpop();
ratio = allot_object(RATIO_TYPE,sizeof(F_RATIO));
ratio->numerator = numerator;
ratio->denominator = denominator;
dpush(RETAG(ratio,RATIO_TYPE));
}
void fixup_ratio(F_RATIO* ratio)
{
data_fixup(&ratio->numerator);
data_fixup(&ratio->denominator);
}
void collect_ratio(F_RATIO* ratio)
{
copy_handle(&ratio->numerator);
copy_handle(&ratio->denominator);
}

9
vm/ratio.h
View File

@ -1,9 +0,0 @@
typedef struct {
CELL header;
CELL numerator;
CELL denominator;
} F_RATIO;
void primitive_from_fraction(void);
void fixup_ratio(F_RATIO* ratio);
void collect_ratio(F_RATIO* ratio);

192
vm/relocate.c
View File

@ -1,192 +0,0 @@
#include "factor.h"
void relocate_object(CELL relocating)
{
switch(untag_header(get(relocating)))
{
case RATIO_TYPE:
fixup_ratio((F_RATIO*)relocating);
break;
case COMPLEX_TYPE:
fixup_complex((F_COMPLEX*)relocating);
break;
case WORD_TYPE:
fixup_word((F_WORD*)relocating);
break;
case ARRAY_TYPE:
case TUPLE_TYPE:
case QUOTATION_TYPE:
fixup_array((F_ARRAY*)relocating);
break;
case HASHTABLE_TYPE:
fixup_hashtable((F_HASHTABLE*)relocating);
break;
case VECTOR_TYPE:
fixup_vector((F_VECTOR*)relocating);
break;
case STRING_TYPE:
rehash_string((F_STRING*)relocating);
break;
case SBUF_TYPE:
fixup_sbuf((F_SBUF*)relocating);
break;
case DLL_TYPE:
fixup_dll((DLL*)relocating);
break;
case ALIEN_TYPE:
fixup_alien((ALIEN*)relocating);
break;
case WRAPPER_TYPE:
fixup_wrapper((F_WRAPPER*)relocating);
break;
}
}
void relocate_data()
{
CELL relocating;
data_fixup(&userenv[BOOT_ENV]);
data_fixup(&userenv[GLOBAL_ENV]);
data_fixup(&T);
data_fixup(&bignum_zero);
data_fixup(&bignum_pos_one);
data_fixup(&bignum_neg_one);
for(relocating = tenured.base;
relocating < tenured.here;
relocating += untagged_object_size(relocating))
{
allot_barrier(relocating);
relocate_object(relocating);
}
for(relocating = compiling.base;
relocating < literal_top;
relocating += CELLS)
{
data_fixup((CELL*)relocating);
}
}
void undefined_symbol(void)
{
general_error(ERROR_UNDEFINED_SYMBOL,F,F,true);
}
CELL get_rel_symbol(F_REL* rel)
{
CELL arg = REL_ARGUMENT(rel);
F_ARRAY *pair = untag_array(get(compiling.base + arg * CELLS));
F_STRING *symbol = untag_string(get(AREF(pair,0)));
CELL library = get(AREF(pair,1));
DLL *dll = (library == F ? NULL : untag_dll(library));
CELL sym;
if(dll != NULL && !dll->dll)
return (CELL)undefined_symbol;
sym = (CELL)ffi_dlsym(dll,symbol,false);
if(!sym)
return (CELL)undefined_symbol;
return sym;
}
INLINE CELL compute_code_rel(F_REL *rel, CELL original)
{
switch(REL_TYPE(rel))
{
case F_PRIMITIVE:
return primitive_to_xt(REL_ARGUMENT(rel));
case F_DLSYM:
return get_rel_symbol(rel);
case F_ABSOLUTE:
return original + (compiling.base - code_relocation_base);
case F_CARDS:
return cards_offset;
default:
critical_error("Unsupported rel type",rel->type);
return -1;
}
}
INLINE CELL relocate_code_next(CELL relocating)
{
F_COMPILED* compiled = (F_COMPILED*)relocating;
F_REL* rel = (F_REL*)(
relocating + sizeof(F_COMPILED)
+ compiled->code_length);
F_REL* rel_end = (F_REL*)(
relocating + sizeof(F_COMPILED)
+ compiled->code_length
+ compiled->reloc_length);
if(compiled->header != COMPILED_HEADER)
critical_error("Wrong compiled header",relocating);
while(rel < rel_end)
{
CELL original;
CELL new_value;
code_fixup(&rel->offset);
switch(REL_CLASS(rel))
{
case REL_ABSOLUTE_CELL:
original = get(rel->offset);
break;
case REL_ABSOLUTE:
original = *(u32*)rel->offset;
break;
case REL_RELATIVE:
original = *(u32*)rel->offset - (rel->offset + sizeof(u32));
break;
case REL_2_2:
original = reloc_get_2_2(rel->offset);
break;
default:
critical_error("Unsupported rel class",REL_CLASS(rel));
return -1;
}
/* to_c_string can fill up the heap */
maybe_gc(0);
new_value = compute_code_rel(rel,original);
switch(REL_CLASS(rel))
{
case REL_ABSOLUTE_CELL:
put(rel->offset,new_value);
break;
case REL_ABSOLUTE:
*(u32*)rel->offset = new_value;
break;
case REL_RELATIVE:
*(u32*)rel->offset = new_value - (rel->offset + CELLS);
break;
case REL_2_2:
reloc_set_2_2(rel->offset,new_value);
break;
default:
critical_error("Unsupported rel class",REL_CLASS(rel));
return -1;
}
rel++;
}
return (CELL)rel_end;
}
void relocate_code()
{
/* start relocating from the end of the space reserved for literals */
CELL relocating = literal_max;
while(relocating < compiling.here)
relocating = relocate_code_next(relocating);
}

60
vm/relocate.h
View File

@ -1,60 +0,0 @@
/* relocation base of currently loaded image's data heap */
CELL data_relocation_base;
INLINE void data_fixup(CELL *cell)
{
if(TAG(*cell) != FIXNUM_TYPE && *cell != F)
*cell += (tenured.base - data_relocation_base);
}
typedef enum {
/* arg is a primitive number */
F_PRIMITIVE,
/* arg is a pointer in the literal table hodling a cons where the
car is a symbol string, and the cdr is a dll */
F_DLSYM,
/* relocate an address to start of code heap */
F_ABSOLUTE,
/* store the offset of the card table from the data heap base */
F_CARDS
} F_RELTYPE;
#define REL_ABSOLUTE_CELL 0
#define REL_ABSOLUTE 1
#define REL_RELATIVE 2
#define REL_2_2 3
/* the rel type is built like a cell to avoid endian-specific code in
the compiler */
#define REL_TYPE(r) ((r)->type & 0x000000ff)
#define REL_CLASS(r) (((r)->type & 0x0000ff00) >> 8)
#define REL_ARGUMENT(r) (((r)->type & 0xffff0000) >> 16)
/* code relocation consists of a table of entries for each fixup */
typedef struct {
CELL type;
CELL offset;
} F_REL;
CELL code_relocation_base;
INLINE void code_fixup(CELL *cell)
{
*cell += (compiling.base - code_relocation_base);
}
void relocate_data();
void relocate_code();
/* on PowerPC, return the 32-bit literal being loaded at the code at the
given address */
INLINE CELL reloc_get_2_2(CELL cell)
{
return ((get(cell - CELLS) & 0xffff) << 16) | (get(cell) & 0xffff);
}
INLINE void reloc_set_2_2(CELL cell, CELL value)
{
put(cell - CELLS,((get(cell - CELLS) & ~0xffff) | ((value >> 16) & 0xffff)));
put(cell,((get(cell) & ~0xffff) | (value & 0xffff)));
}

145
vm/run.c
View File

@ -159,3 +159,148 @@ void primitive_setenv(void)
CELL value = dpop();
userenv[e] = value;
}
void primitive_exit(void)
{
exit(to_fixnum(dpop()));
}
void primitive_os_env(void)
{
char *name, *value;
maybe_gc(0);
name = pop_char_string();
value = getenv(name);
if(value == NULL)
dpush(F);
else
box_char_string(getenv(name));
}
void primitive_eq(void)
{
box_boolean(dpop() == dpop());
}
void primitive_millis(void)
{
maybe_gc(0);
dpush(tag_bignum(s48_long_long_to_bignum(current_millis())));
}
void fatal_error(char* msg, CELL tagged)
{
fprintf(stderr,"Fatal error: %s %ld\n",msg,tagged);
exit(1);
}
void critical_error(char* msg, CELL tagged)
{
fprintf(stderr,"Critical error: %s %ld\n",msg,tagged);
factorbug();
}
void early_error(CELL error)
{
if(userenv[BREAK_ENV] == F)
{
/* Crash at startup */
fprintf(stderr,"Error during startup: ");
print_obj(error);
fprintf(stderr,"\n");
factorbug();
}
}
void throw_error(CELL error, bool keep_stacks)
{
early_error(error);
throwing = true;
thrown_error = error;
thrown_keep_stacks = keep_stacks;
thrown_ds = ds;
thrown_rs = rs;
/* Return to run() method */
LONGJMP(stack_chain->toplevel,1);
}
void primitive_throw(void)
{
throw_error(dpop(),true);
}
void primitive_die(void)
{
factorbug();
}
void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2, bool keep_stacks)
{
throw_error(make_array_4(userenv[ERROR_ENV],
tag_fixnum(error),arg1,arg2),keep_stacks);
}
/* It is not safe to access 'ds' from a signal handler, so we just not
touch it */
void signal_error(int signal)
{
general_error(ERROR_SIGNAL,tag_fixnum(signal),F,false);
}
void type_error(CELL type, CELL tagged)
{
general_error(ERROR_TYPE,tag_fixnum(type),tagged,true);
}
void init_compiler(CELL size)
{
compiling.base = compiling.here = (CELL)(alloc_bounded_block(size)->start);
if(compiling.base == 0)
fatal_error("Cannot allocate code heap",size);
compiling.limit = compiling.base + size;
last_flush = compiling.base;
}
void primitive_compiled_offset(void)
{
box_unsigned_cell(compiling.here);
}
void primitive_set_compiled_offset(void)
{
CELL offset = unbox_unsigned_cell();
compiling.here = offset;
if(compiling.here >= compiling.limit)
{
fprintf(stderr,"Code space exhausted\n");
factorbug();
}
}
void primitive_add_literal(void)
{
CELL object = dpeek();
CELL offset = literal_top;
put(literal_top,object);
literal_top += CELLS;
if(literal_top >= literal_max)
critical_error("Too many compiled literals",literal_top);
drepl(tag_cell(offset));
}
void primitive_flush_icache(void)
{
flush_icache((void*)last_flush,compiling.here - last_flush);
last_flush = compiling.here;
}
void collect_literals(void)
{
CELL i;
for(i = compiling.base; i < literal_top; i += CELLS)
copy_handle((CELL*)i);
}

136
vm/run.h
View File

@ -1,3 +1,15 @@
/* Callstack top pointer */
CELL cs;
/* TAGGED currently executing quotation */
CELL callframe;
/* UNTAGGED currently executing word in quotation */
CELL callframe_scan;
/* UNTAGGED end of quotation */
CELL callframe_end;
#define USER_ENV 32
#define CARD_OFF_ENV 1 /* for compiling set-slot */
@ -22,60 +34,6 @@
/* TAGGED user environment data; see getenv/setenv prims */
DLLEXPORT CELL userenv[USER_ENV];
INLINE CELL dpop(void)
{
CELL value = get(ds);
ds -= CELLS;
return value;
}
INLINE void drepl(CELL top)
{
put(ds,top);
}
INLINE void dpush(CELL top)
{
ds += CELLS;
put(ds,top);
}
INLINE CELL dpeek(void)
{
return get(ds);
}
INLINE CELL dpeek2(void)
{
return get(ds - CELLS);
}
INLINE CELL cpop(void)
{
CELL value = get(cs);
cs -= CELLS;
return value;
}
INLINE void cpush(CELL top)
{
cs += CELLS;
put(cs,top);
}
INLINE CELL rpop(void)
{
CELL value = get(rs);
rs -= CELLS;
return value;
}
INLINE void rpush(CELL top)
{
rs += CELLS;
put(rs,top);
}
void call(CELL quot);
void handle_error();
@ -92,3 +50,73 @@ void primitive_ifte(void);
void primitive_dispatch(void);
void primitive_getenv(void);
void primitive_setenv(void);
void primitive_exit(void);
void primitive_os_env(void);
void primitive_eq(void);
void primitive_millis(void);
/* Runtime errors */
typedef enum
{
ERROR_EXPIRED,
ERROR_IO,
ERROR_UNDEFINED_WORD,
ERROR_TYPE,
ERROR_SIGNAL,
ERROR_NEGATIVE_ARRAY_SIZE,
ERROR_C_STRING,
ERROR_FFI,
ERROR_HEAP_SCAN,
ERROR_UNDEFINED_SYMBOL,
ERROR_USER_INTERRUPT,
ERROR_DS_UNDERFLOW,
ERROR_DS_OVERFLOW,
ERROR_RS_UNDERFLOW,
ERROR_RS_OVERFLOW,
ERROR_CS_UNDERFLOW,
ERROR_CS_OVERFLOW,
ERROR_OBJECTIVE_C
} F_ERRORTYPE;
/* Are we throwing an error? */
bool throwing;
/* When throw_error throws an error, it sets this global and
longjmps back to the top-level. */
CELL thrown_error;
CELL thrown_keep_stacks;
/* Since longjmp restores registers, we must save all these values. */
CELL thrown_ds;
CELL thrown_rs;
void fatal_error(char* msg, CELL tagged);
void critical_error(char* msg, CELL tagged);
void throw_error(CELL error, bool keep_stacks);
void early_error(CELL error);
void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2, bool keep_stacks);
void signal_error(int signal);
void type_error(CELL type, CELL tagged);
void primitive_throw(void);
void primitive_die(void);
/* The compiled code heap is structured into blocks. */
typedef struct
{
CELL header; /* = COMPILED_HEADER */
CELL code_length;
CELL reloc_length; /* see relocate.h */
} F_COMPILED;
#define COMPILED_HEADER 0x01c3babe
CELL literal_top;
CELL literal_max;
void init_compiler(CELL size);
void primitive_compiled_offset(void);
void primitive_set_compiled_offset(void);
void primitive_add_literal(void);
void collect_literals(void);
CELL last_flush;
void primitive_flush_icache(void);

1909
vm/s48_bignum.c
View File

File diff suppressed because it is too large Load Diff

156
vm/s48_bignum.h
View File

@ -1,156 +0,0 @@
/* -*-C-*-
$Id: s48_bignum.h,v 1.13 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. */
/* External Interface to Bignum Code */
/* The `unsigned long' type is used for the conversion procedures
`bignum_to_long' and `long_to_bignum'. Older implementations of C
don't support this type; if you have such an implementation you can
disable these procedures using the following flag (alternatively
you could write alternate versions that don't require this type). */
/* #define BIGNUM_NO_ULONG */
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
};
typedef void * bignum_procedure_context;
int s48_bignum_equal_p(bignum_type, bignum_type);
enum bignum_comparison s48_bignum_test(bignum_type);
enum bignum_comparison s48_bignum_compare(bignum_type, bignum_type);
bignum_type s48_bignum_add(bignum_type, bignum_type);
bignum_type s48_bignum_subtract(bignum_type, bignum_type);
bignum_type s48_bignum_negate(bignum_type);
bignum_type s48_bignum_multiply(bignum_type, bignum_type);
void
s48_bignum_divide(bignum_type numerator, bignum_type denominator,
bignum_type * quotient, bignum_type * remainder);
bignum_type s48_bignum_quotient(bignum_type, bignum_type);
bignum_type s48_bignum_remainder(bignum_type, bignum_type);
DLLEXPORT bignum_type s48_fixnum_to_bignum(F_FIXNUM);
DLLEXPORT bignum_type s48_cell_to_bignum(CELL);
DLLEXPORT bignum_type s48_long_to_bignum(long);
DLLEXPORT bignum_type s48_long_long_to_bignum(s64 n);
DLLEXPORT bignum_type s48_ulong_long_to_bignum(u64 n);
DLLEXPORT bignum_type s48_ulong_to_bignum(unsigned long);
DLLEXPORT bignum_type s48_fixnum_pair_to_bignum(CELL x, F_FIXNUM y);
F_FIXNUM s48_bignum_to_fixnum(bignum_type);
CELL s48_bignum_to_cell(bignum_type);
long s48_bignum_to_long(bignum_type);
unsigned long s48_bignum_to_ulong(bignum_type);
s64 s48_bignum_to_long_long(bignum_type);
u64 s48_bignum_to_ulong_long(bignum_type);
bignum_type s48_double_to_bignum(double);
double s48_bignum_to_double(bignum_type);
int s48_bignum_fits_in_word_p(bignum_type, long word_length,
int twos_complement_p);
bignum_type s48_bignum_length_in_bits(bignum_type);
bignum_type s48_bignum_length_upper_limit(void);
bignum_type s48_digit_stream_to_bignum
(unsigned int n_digits,
unsigned int (*producer(bignum_procedure_context)),
bignum_procedure_context context,
unsigned int radix,
int negative_p);
long s48_bignum_max_digit_stream_radix(void);
/* Added bitwise operators. */
DLLEXPORT bignum_type s48_bignum_bitwise_not(bignum_type),
s48_bignum_arithmetic_shift(bignum_type, long),
s48_bignum_bitwise_and(bignum_type, bignum_type),
s48_bignum_bitwise_ior(bignum_type, bignum_type),
s48_bignum_bitwise_xor(bignum_type, bignum_type);
int s48_bignum_oddp(bignum_type);
long s48_bignum_bit_count(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 bignum_allocate(bignum_length_type, int);
bignum_type bignum_allocate_zeroed(bignum_length_type, int);
bignum_type bignum_shorten_length(bignum_type, bignum_length_type);
bignum_type bignum_trim(bignum_type);
bignum_type bignum_copy(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);
/* Unused
void bignum_destructive_zero(bignum_type);
*/
/* Added for bitwise operations. */
bignum_type bignum_magnitude_ash(bignum_type arg1, long 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);
long bignum_unsigned_logcount(bignum_type arg);
int bignum_unsigned_logbitp(int shift, bignum_type bignum);

29
vm/sbuf.c
View File

@ -1,29 +0,0 @@
#include "factor.h"
F_SBUF* sbuf(F_FIXNUM capacity)
{
F_SBUF* sbuf;
if(capacity < 0)
general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_integer(capacity),F,true);
sbuf = allot_object(SBUF_TYPE,sizeof(F_SBUF));
sbuf->top = tag_fixnum(0);
sbuf->string = tag_object(string(capacity,'\0'));
return sbuf;
}
void primitive_sbuf(void)
{
CELL size = to_fixnum(dpeek());
maybe_gc(sizeof(F_SBUF) + string_size(size));
drepl(tag_object(sbuf(size)));
}
void fixup_sbuf(F_SBUF* sbuf)
{
data_fixup(&sbuf->string);
}
void collect_sbuf(F_SBUF* sbuf)
{
copy_handle(&sbuf->string);
}

13
vm/sbuf.h
View File

@ -1,13 +0,0 @@
typedef struct {
/* always tag_header(SBUF_TYPE) */
CELL header;
/* tagged */
CELL top;
/* tagged */
CELL string;
} F_SBUF;
F_SBUF* sbuf(F_FIXNUM capacity);
void primitive_sbuf(void);
void fixup_sbuf(F_SBUF* sbuf);
void collect_sbuf(F_SBUF* sbuf);

5
vm/signal.h
View File

@ -1,5 +0,0 @@
#ifndef WIN32
void signal_handler(int signal, siginfo_t* siginfo, void* uap);
void dump_stack_signal(int signal, siginfo_t* siginfo, void* uap);
#endif
void init_signals(void);

54
vm/stack.h
View File

@ -1,3 +1,57 @@
INLINE CELL dpop(void)
{
CELL value = get(ds);
ds -= CELLS;
return value;
}
INLINE void drepl(CELL top)
{
put(ds,top);
}
INLINE void dpush(CELL top)
{
ds += CELLS;
put(ds,top);
}
INLINE CELL dpeek(void)
{
return get(ds);
}
INLINE CELL dpeek2(void)
{
return get(ds - CELLS);
}
INLINE CELL cpop(void)
{
CELL value = get(cs);
cs -= CELLS;
return value;
}
INLINE void cpush(CELL top)
{
cs += CELLS;
put(cs,top);
}
INLINE CELL rpop(void)
{
CELL value = get(rs);
rs -= CELLS;
return value;
}
INLINE void rpush(CELL top)
{
rs += CELLS;
put(rs,top);
}
typedef struct _STACKS {
/* current datastack top pointer */
CELL data;

220
vm/string.c
View File

@ -1,220 +0,0 @@
#include "factor.h"
/* untagged */
F_STRING* allot_string(F_FIXNUM capacity)
{
F_STRING* string;
if(capacity < 0)
general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_integer(capacity),F,true);
string = allot_object(STRING_TYPE,
sizeof(F_STRING) + (capacity + 1) * CHARS);
/* strings are null-terminated in memory, even though they also
have a length field. The null termination allows us to add
the sizeof(F_STRING) to a Factor string to get a C-style
UTF16 string for C library calls. */
cput(SREF(string,capacity),(u16)'\0');
string->length = tag_fixnum(capacity);
string->hashcode = F;
return string;
}
/* call this after constructing a string */
void rehash_string(F_STRING* str)
{
s32 hash = 0;
CELL i;
CELL capacity = string_capacity(str);
for(i = 0; i < capacity; i++)
hash = (31*hash + string_nth(str,i));
str->hashcode = (s32)tag_fixnum(hash);
}
void primitive_rehash_string(void)
{
rehash_string(untag_string(dpop()));
}
/* untagged */
F_STRING *string(F_FIXNUM capacity, CELL fill)
{
CELL i;
F_STRING* string = allot_string(capacity);
for(i = 0; i < capacity; i++)
cput(SREF(string,i),fill);
rehash_string(string);
return string;
}
void primitive_string(void)
{
CELL initial = to_cell(dpop());
F_FIXNUM length = to_fixnum(dpop());
maybe_gc(string_size(length));
dpush(tag_object(string(length,initial)));
}
F_STRING* resize_string(F_STRING* string, F_FIXNUM capacity, u16 fill)
{
/* later on, do an optimization: if end of array is here, just grow */
CELL i;
CELL to_copy = string_capacity(string);
if(capacity < to_copy)
to_copy = capacity;
F_STRING* new_string = allot_string(capacity);
memcpy(new_string + 1,string + 1,to_copy * CHARS);
for(i = to_copy; i < capacity; i++)
cput(SREF(new_string,i),fill);
return new_string;
}
void primitive_resize_string(void)
{
F_STRING* string;
CELL capacity = to_fixnum(dpeek2());
maybe_gc(string_size(capacity));
string = untag_string_fast(dpop());
drepl(tag_object(resize_string(string,capacity,0)));
}
/* 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) \
{ \
F_STRING* s = allot_string(length); \
CELL i; \
for(i = 0; i < length; i++) \
{ \
cput(SREF(s,i),(utype)*string); \
string++; \
} \
rehash_string(s); \
return s; \
} \
void primitive_memory_to_##type##_string(void) \
{ \
CELL length = unbox_unsigned_cell(); \
type *string = (type*)unbox_unsigned_cell(); \
dpush(tag_object(memory_to_##type##_string(string,length))); \
} \
F_STRING *from_##type##_string(const type *str) \
{ \
CELL length = 0; \
type *scan = str; \
while(*scan++) length++; \
return memory_to_##type##_string((type*)str,length); \
} \
void box_##type##_string(const type *str) \
{ \
dpush(str ? tag_object(from_##type##_string(str)) : F); \
} \
void primitive_alien_to_##type##_string(void) \
{ \
maybe_gc(0); \
drepl(tag_object(from_##type##_string(alien_offset(dpeek())))); \
}
MEMORY_TO_STRING(char,u8)
MEMORY_TO_STRING(u16,u16)
void check_string(F_STRING *s, CELL max)
{
CELL capacity = string_capacity(s);
CELL i;
for(i = 0; i < capacity; i++)
{
u16 ch = string_nth(s,i);
if(ch == '\0' || ch >= (1 << (max * 8)))
general_error(ERROR_C_STRING,tag_object(s),F,true);
}
}
F_ARRAY *allot_c_string(CELL capacity, CELL size)
{
return allot_array(BYTE_ARRAY_TYPE,capacity * size / CELLS + 1);
}
#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_unsigned_cell(); \
F_STRING *str = untag_string(dpop()); \
type##_string_to_memory(str,address); \
} \
F_ARRAY *string_to_##type##_alien(F_STRING *s, bool check) \
{ \
CELL capacity = string_capacity(s); \
F_ARRAY *_c_str; \
if(check) check_string(s,sizeof(type)); \
_c_str = allot_c_string(capacity,sizeof(type)); \
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) \
{ \
if(sizeof(type) == sizeof(u16)) \
{ \
if(check) check_string(s,sizeof(type)); \
return (type*)(s + 1); \
} \
else \
return (type*)(string_to_##type##_alien(s,check) + 1); \
} \
type *pop_##type##_string(void) \
{ \
return to_##type##_string(untag_string(dpop()),true); \
} \
type *unbox_##type##_string(void) \
{ \
if(type_of(dpeek()) == STRING_TYPE) \
return pop_##type##_string(); \
else \
return unbox_alien(); \
} \
void primitive_string_to_##type##_alien(void) \
{ \
CELL string, t; \
maybe_gc(0); \
string = dpeek(); \
t = type_of(string); \
if(t != ALIEN_TYPE && t != BYTE_ARRAY_TYPE && t != F_TYPE) \
drepl(tag_object(string_to_##type##_alien(untag_string(string),true))); \
}
STRING_TO_MEMORY(char);
STRING_TO_MEMORY(u16);
void primitive_char_slot(void)
{
F_STRING* string = untag_string_fast(dpop());
CELL index = untag_fixnum_fast(dpop());
dpush(tag_fixnum(string_nth(string,index)));
}
void primitive_set_char_slot(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);
}

81
vm/string.h
View File

@ -1,81 +0,0 @@
typedef struct {
CELL header;
/* tagged num of chars */
CELL length;
/* tagged */
CELL hashcode;
} F_STRING;
#define SREF(string,index) ((CELL)string + sizeof(F_STRING) + index * CHARS)
INLINE F_STRING* untag_string_fast(CELL tagged)
{
return (F_STRING*)UNTAG(tagged);
}
INLINE F_STRING* untag_string(CELL tagged)
{
type_check(STRING_TYPE,tagged);
return untag_string_fast(tagged);
}
INLINE CELL string_capacity(F_STRING* str)
{
return untag_fixnum_fast(str->length);
}
INLINE CELL string_size(CELL size)
{
return align8(sizeof(F_STRING) + (size + 1) * CHARS);
}
F_STRING* allot_string(F_FIXNUM capacity);
void rehash_string(F_STRING* str);
void primitive_rehash_string(void);
F_STRING* string(F_FIXNUM capacity, CELL fill);
void primitive_string(void);
F_STRING *resize_string(F_STRING *string, F_FIXNUM capacity, u16 fill);
void primitive_resize_string(void);
F_STRING *memory_to_char_string(const char *string, CELL length);
void primitive_memory_to_char_string(void);
F_STRING *from_char_string(const char *c_string);
DLLEXPORT void box_char_string(const char *c_string);
void primitive_alien_to_char_string(void);
F_STRING *memory_to_u16_string(const u16 *string, CELL length);
void primitive_memory_to_u16_string(void);
F_STRING *from_u16_string(const u16 *c_string);
DLLEXPORT void box_u16_string(const u16 *c_string);
void primitive_alien_to_u16_string(void);
void char_string_to_memory(F_STRING *s, char *string);
void primitive_char_string_to_memory(void);
F_ARRAY *string_to_char_alien(F_STRING *s, bool check);
char* to_char_string(F_STRING *s, bool check);
char *pop_char_string(void);
DLLEXPORT char *unbox_char_string(void);
void primitive_string_to_char_alien(void);
void u16_string_to_memory(F_STRING *s, u16 *string);
void primitive_u16_string_to_memory(void);
F_ARRAY *string_to_u16_alien(F_STRING *s, bool check);
u16* to_u16_string(F_STRING *s, bool check);
u16 *pop_u16_string(void);
DLLEXPORT u16 *unbox_u16_string(void);
void primitive_string_to_u16_alien(void);
/* untagged & unchecked */
INLINE CELL string_nth(F_STRING* string, CELL index)
{
return cget(SREF(string,index));
}
/* untagged & unchecked */
INLINE void set_string_nth(F_STRING* string, CELL index, u16 value)
{
cput(SREF(string,index),value);
}
void primitive_char_slot(void);
void primitive_set_char_slot(void);

563
vm/types.c Normal file
View File

@ -0,0 +1,563 @@
#include "factor.h"
/* FFI calls this */
void box_boolean(bool value)
{
dpush(value ? T : F);
}
/* FFI calls this */
bool unbox_boolean(void)
{
return (dpop() != F);
}
/* the array is full of undefined data, and must be correctly filled before the
next GC. size is in cells */
F_ARRAY *allot_array(CELL type, F_FIXNUM capacity)
{
F_ARRAY *array;
if(capacity < 0)
general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_integer(capacity),F,true);
array = allot_object(type,array_size(capacity));
array->capacity = tag_fixnum(capacity);
return array;
}
/* make a new array with an initial element */
F_ARRAY *array(CELL type, F_FIXNUM capacity, CELL fill)
{
int i;
F_ARRAY* array = allot_array(type, capacity);
for(i = 0; i < capacity; i++)
put(AREF(array,i),fill);
return array;
}
/* size is in bytes this time */
F_ARRAY *byte_array(F_FIXNUM size)
{
F_FIXNUM byte_size = (size + sizeof(CELL) - 1) / sizeof(CELL);
return array(BYTE_ARRAY_TYPE,byte_size,0);
}
/* push a new array on the stack */
void primitive_array(void)
{
CELL initial;
F_FIXNUM size;
maybe_gc(0);
initial = dpop();
size = to_fixnum(dpop());
dpush(tag_object(array(ARRAY_TYPE,size,initial)));
}
/* push a new tuple on the stack */
void primitive_tuple(void)
{
CELL class;
F_FIXNUM size;
F_ARRAY *tuple;
maybe_gc(0);
size = to_fixnum(dpop());
class = dpop();
tuple = array(TUPLE_TYPE,size,F);
put(AREF(tuple,0),class);
dpush(tag_object(tuple));
}
/* push a new byte on the stack */
void primitive_byte_array(void)
{
F_FIXNUM size = to_fixnum(dpop());
maybe_gc(0);
dpush(tag_object(byte_array(size)));
}
/* push a new quotation on the stack */
void primitive_quotation(void)
{
F_FIXNUM size;
maybe_gc(0);
size = to_fixnum(dpop());
dpush(tag_object(array(QUOTATION_TYPE,size,F)));
}
CELL make_array_2(CELL v1, CELL v2)
{
F_ARRAY *a = array(ARRAY_TYPE,2,F);
put(AREF(a,0),v1);
put(AREF(a,1),v2);
return tag_object(a);
}
CELL make_array_4(CELL v1, CELL v2, CELL v3, CELL v4)
{
F_ARRAY *a = array(ARRAY_TYPE,4,F);
put(AREF(a,0),v1);
put(AREF(a,1),v2);
put(AREF(a,2),v3);
put(AREF(a,3),v4);
return tag_object(a);
}
F_ARRAY* resize_array(F_ARRAY* array, F_FIXNUM capacity, CELL fill)
{
int i;
F_ARRAY* new_array;
CELL to_copy = array_capacity(array);
if(capacity < to_copy)
to_copy = capacity;
new_array = allot_array(untag_header(array->header),capacity);
memcpy(new_array + 1,array + 1,to_copy * CELLS);
for(i = to_copy; i < capacity; i++)
put(AREF(new_array,i),fill);
return new_array;
}
void primitive_resize_array(void)
{
F_ARRAY* array;
F_FIXNUM capacity = to_fixnum(dpeek2());
maybe_gc(array_size(capacity));
array = untag_array(dpop());
drepl(tag_object(resize_array(array,capacity,F)));
}
void primitive_array_to_tuple(void)
{
CELL array = dpeek();
type_check(ARRAY_TYPE,array);
array = clone(array);
put(SLOT(UNTAG(array),0),tag_header(TUPLE_TYPE));
drepl(array);
}
void primitive_tuple_to_array(void)
{
CELL tuple = dpeek();
type_check(TUPLE_TYPE,tuple);
tuple = clone(tuple);
put(SLOT(UNTAG(tuple),0),tag_header(ARRAY_TYPE));
drepl(tuple);
}
/* image loading */
void fixup_array(F_ARRAY* array)
{
int i = 0; CELL capacity = array_capacity(array);
for(i = 0; i < capacity; i++)
data_fixup((void*)AREF(array,i));
}
/* GC */
void collect_array(F_ARRAY* array)
{
int i = 0; CELL capacity = array_capacity(array);
for(i = 0; i < capacity; i++)
copy_handle((void*)AREF(array,i));
}
F_VECTOR* vector(F_FIXNUM capacity)
{
F_VECTOR* vector = allot_object(VECTOR_TYPE,sizeof(F_VECTOR));
vector->top = tag_fixnum(0);
vector->array = tag_object(array(ARRAY_TYPE,capacity,F));
return vector;
}
void primitive_vector(void)
{
CELL size = to_fixnum(dpeek());
maybe_gc(array_size(size) + sizeof(F_VECTOR));
drepl(tag_object(vector(size)));
}
void primitive_array_to_vector(void)
{
F_ARRAY *array;
F_VECTOR *vector;
maybe_gc(sizeof(F_VECTOR));
array = untag_array(dpeek());
vector = allot_object(VECTOR_TYPE,sizeof(F_VECTOR));
vector->top = array->capacity;
vector->array = tag_object(array);
drepl(tag_object(vector));
}
void fixup_vector(F_VECTOR* vector)
{
data_fixup(&vector->array);
}
void collect_vector(F_VECTOR* vector)
{
copy_handle(&vector->array);
}
/* untagged */
F_STRING* allot_string(F_FIXNUM capacity)
{
F_STRING* string;
if(capacity < 0)
general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_integer(capacity),F,true);
string = allot_object(STRING_TYPE,
sizeof(F_STRING) + (capacity + 1) * CHARS);
/* strings are null-terminated in memory, even though they also
have a length field. The null termination allows us to add
the sizeof(F_STRING) to a Factor string to get a C-style
UTF16 string for C library calls. */
cput(SREF(string,capacity),(u16)'\0');
string->length = tag_fixnum(capacity);
string->hashcode = F;
return string;
}
/* call this after constructing a string */
void rehash_string(F_STRING* str)
{
s32 hash = 0;
CELL i;
CELL capacity = string_capacity(str);
for(i = 0; i < capacity; i++)
hash = (31*hash + string_nth(str,i));
str->hashcode = (s32)tag_fixnum(hash);
}
void primitive_rehash_string(void)
{
rehash_string(untag_string(dpop()));
}
/* untagged */
F_STRING *string(F_FIXNUM capacity, CELL fill)
{
CELL i;
F_STRING* string = allot_string(capacity);
for(i = 0; i < capacity; i++)
cput(SREF(string,i),fill);
rehash_string(string);
return string;
}
void primitive_string(void)
{
CELL initial = to_cell(dpop());
F_FIXNUM length = to_fixnum(dpop());
maybe_gc(string_size(length));
dpush(tag_object(string(length,initial)));
}
F_STRING* resize_string(F_STRING* string, F_FIXNUM capacity, u16 fill)
{
/* later on, do an optimization: if end of array is here, just grow */
CELL i;
CELL to_copy = string_capacity(string);
if(capacity < to_copy)
to_copy = capacity;
F_STRING* new_string = allot_string(capacity);
memcpy(new_string + 1,string + 1,to_copy * CHARS);
for(i = to_copy; i < capacity; i++)
cput(SREF(new_string,i),fill);
return new_string;
}
void primitive_resize_string(void)
{
F_STRING* string;
CELL capacity = to_fixnum(dpeek2());
maybe_gc(string_size(capacity));
string = untag_string_fast(dpop());
drepl(tag_object(resize_string(string,capacity,0)));
}
/* 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) \
{ \
F_STRING* s = allot_string(length); \
CELL i; \
for(i = 0; i < length; i++) \
{ \
cput(SREF(s,i),(utype)*string); \
string++; \
} \
rehash_string(s); \
return s; \
} \
void primitive_memory_to_##type##_string(void) \
{ \
CELL length = unbox_unsigned_cell(); \
type *string = (type*)unbox_unsigned_cell(); \
dpush(tag_object(memory_to_##type##_string(string,length))); \
} \
F_STRING *from_##type##_string(const type *str) \
{ \
CELL length = 0; \
type *scan = str; \
while(*scan++) length++; \
return memory_to_##type##_string((type*)str,length); \
} \
void box_##type##_string(const type *str) \
{ \
dpush(str ? tag_object(from_##type##_string(str)) : F); \
} \
void primitive_alien_to_##type##_string(void) \
{ \
maybe_gc(0); \
drepl(tag_object(from_##type##_string(alien_offset(dpeek())))); \
}
MEMORY_TO_STRING(char,u8)
MEMORY_TO_STRING(u16,u16)
void check_string(F_STRING *s, CELL max)
{
CELL capacity = string_capacity(s);
CELL i;
for(i = 0; i < capacity; i++)
{
u16 ch = string_nth(s,i);
if(ch == '\0' || ch >= (1 << (max * 8)))
general_error(ERROR_C_STRING,tag_object(s),F,true);
}
}
F_ARRAY *allot_c_string(CELL capacity, CELL size)
{
return allot_array(BYTE_ARRAY_TYPE,capacity * size / CELLS + 1);
}
#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_unsigned_cell(); \
F_STRING *str = untag_string(dpop()); \
type##_string_to_memory(str,address); \
} \
F_ARRAY *string_to_##type##_alien(F_STRING *s, bool check) \
{ \
CELL capacity = string_capacity(s); \
F_ARRAY *_c_str; \
if(check) check_string(s,sizeof(type)); \
_c_str = allot_c_string(capacity,sizeof(type)); \
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) \
{ \
if(sizeof(type) == sizeof(u16)) \
{ \
if(check) check_string(s,sizeof(type)); \
return (type*)(s + 1); \
} \
else \
return (type*)(string_to_##type##_alien(s,check) + 1); \
} \
type *pop_##type##_string(void) \
{ \
return to_##type##_string(untag_string(dpop()),true); \
} \
type *unbox_##type##_string(void) \
{ \
if(type_of(dpeek()) == STRING_TYPE) \
return pop_##type##_string(); \
else \
return unbox_alien(); \
} \
void primitive_string_to_##type##_alien(void) \
{ \
CELL string, t; \
maybe_gc(0); \
string = dpeek(); \
t = type_of(string); \
if(t != ALIEN_TYPE && t != BYTE_ARRAY_TYPE && t != F_TYPE) \
drepl(tag_object(string_to_##type##_alien(untag_string(string),true))); \
}
STRING_TO_MEMORY(char);
STRING_TO_MEMORY(u16);
void primitive_char_slot(void)
{
F_STRING* string = untag_string_fast(dpop());
CELL index = untag_fixnum_fast(dpop());
dpush(tag_fixnum(string_nth(string,index)));
}
void primitive_set_char_slot(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);
}
F_SBUF* sbuf(F_FIXNUM capacity)
{
F_SBUF* sbuf;
if(capacity < 0)
general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_integer(capacity),F,true);
sbuf = allot_object(SBUF_TYPE,sizeof(F_SBUF));
sbuf->top = tag_fixnum(0);
sbuf->string = tag_object(string(capacity,'\0'));
return sbuf;
}
void primitive_sbuf(void)
{
CELL size = to_fixnum(dpeek());
maybe_gc(sizeof(F_SBUF) + string_size(size));
drepl(tag_object(sbuf(size)));
}
void fixup_sbuf(F_SBUF* sbuf)
{
data_fixup(&sbuf->string);
}
void collect_sbuf(F_SBUF* sbuf)
{
copy_handle(&sbuf->string);
}
void primitive_hashtable(void)
{
F_HASHTABLE* hash;
maybe_gc(0);
hash = allot_object(HASHTABLE_TYPE,sizeof(F_HASHTABLE));
hash->count = F;
hash->deleted = F;
hash->array = F;
dpush(tag_object(hash));
}
void fixup_hashtable(F_HASHTABLE* hashtable)
{
data_fixup(&hashtable->count);
data_fixup(&hashtable->deleted);
data_fixup(&hashtable->array);
}
void collect_hashtable(F_HASHTABLE* hashtable)
{
copy_handle(&hashtable->count);
copy_handle(&hashtable->deleted);
copy_handle(&hashtable->array);
}
/* When a word is executed we jump to the value of the xt field. However this
value is an unportable function pointer, so in the image we store a primitive
number that indexes a list of xts. */
void update_xt(F_WORD* word)
{
word->xt = primitive_to_xt(to_fixnum(word->primitive));
}
/* <word> ( name vocabulary -- word ) */
void primitive_word(void)
{
F_WORD *word;
CELL name, vocabulary;
maybe_gc(sizeof(F_WORD));
vocabulary = dpop();
name = dpop();
word = allot_object(WORD_TYPE,sizeof(F_WORD));
word->hashcode = tag_fixnum((CELL)word); /* initial address */
word->name = name;
word->vocabulary = vocabulary;
word->primitive = tag_fixnum(0);
word->def = F;
word->props = F;
word->xt = (CELL)undefined;
dpush(tag_word(word));
}
void primitive_update_xt(void)
{
update_xt(untag_word(dpop()));
}
void primitive_word_compiledp(void)
{
F_WORD* word = untag_word(dpop());
box_boolean(word->xt != (CELL)docol && word->xt != (CELL)dosym);
}
void fixup_word(F_WORD* word)
{
data_fixup(&word->primitive);
/* If this is a compiled word, relocate the code pointer. Otherwise,
reset it based on the primitive number of the word. */
if(word->xt >= code_relocation_base
&& word->xt < code_relocation_base
- compiling.base + compiling.limit)
code_fixup(&word->xt);
else
update_xt(word);
data_fixup(&word->name);
data_fixup(&word->vocabulary);
data_fixup(&word->def);
data_fixup(&word->props);
}
void collect_word(F_WORD* word)
{
copy_handle(&word->name);
copy_handle(&word->vocabulary);
copy_handle(&word->def);
copy_handle(&word->props);
}
void primitive_wrapper(void)
{
F_WRAPPER *wrapper;
maybe_gc(sizeof(F_WRAPPER));
wrapper = allot_object(WRAPPER_TYPE,sizeof(F_WRAPPER));
wrapper->object = dpeek();
drepl(tag_wrapper(wrapper));
}
void fixup_wrapper(F_WRAPPER *wrapper)
{
data_fixup(&wrapper->object);
}
void collect_wrapper(F_WRAPPER *wrapper)
{
copy_handle(&wrapper->object);
}

191
vm/types.h Normal file
View File

@ -0,0 +1,191 @@
INLINE CELL tag_boolean(CELL untagged)
{
return (untagged == false ? F : T);
}
DLLEXPORT void box_boolean(bool value);
DLLEXPORT bool unbox_boolean(void);
INLINE F_ARRAY* untag_array_fast(CELL tagged)
{
return (F_ARRAY*)UNTAG(tagged);
}
INLINE F_ARRAY* untag_array(CELL tagged)
{
type_check(ARRAY_TYPE,tagged);
return untag_array_fast(tagged);
}
INLINE F_ARRAY* untag_byte_array_fast(CELL tagged)
{
return (F_ARRAY*)UNTAG(tagged);
}
INLINE CELL array_size(CELL size)
{
return align8(sizeof(F_ARRAY) + size * CELLS);
}
F_ARRAY *allot_array(CELL type, F_FIXNUM capacity);
F_ARRAY *array(CELL type, F_FIXNUM capacity, CELL fill);
F_ARRAY *byte_array(F_FIXNUM size);
CELL make_array_2(CELL v1, CELL v2);
CELL make_array_4(CELL v1, CELL v2, CELL v3, CELL v4);
void primitive_array(void);
void primitive_tuple(void);
void primitive_byte_array(void);
void primitive_quotation(void);
F_ARRAY *resize_array(F_ARRAY* array, F_FIXNUM capacity, CELL fill);
void primitive_resize_array(void);
void primitive_array_to_tuple(void);
void primitive_tuple_to_array(void);
#define AREF(array,index) ((CELL)(array) + sizeof(F_ARRAY) + (index) * CELLS)
#define UNAREF(array,ptr) (((CELL)(ptr)-(CELL)(array)-sizeof(F_ARRAY)) / CELLS)
INLINE CELL array_capacity(F_ARRAY* array)
{
return untag_fixnum_fast(array->capacity);
}
void fixup_array(F_ARRAY* array);
void collect_array(F_ARRAY* array);
INLINE F_VECTOR* untag_vector(CELL tagged)
{
type_check(VECTOR_TYPE,tagged);
return (F_VECTOR*)UNTAG(tagged);
}
F_VECTOR* vector(F_FIXNUM capacity);
void primitive_vector(void);
void primitive_array_to_vector(void);
void fixup_vector(F_VECTOR* vector);
void collect_vector(F_VECTOR* vector);
#define SREF(string,index) ((CELL)string + sizeof(F_STRING) + index * CHARS)
INLINE F_STRING* untag_string_fast(CELL tagged)
{
return (F_STRING*)UNTAG(tagged);
}
INLINE F_STRING* untag_string(CELL tagged)
{
type_check(STRING_TYPE,tagged);
return untag_string_fast(tagged);
}
INLINE CELL string_capacity(F_STRING* str)
{
return untag_fixnum_fast(str->length);
}
INLINE CELL string_size(CELL size)
{
return align8(sizeof(F_STRING) + (size + 1) * CHARS);
}
F_STRING* allot_string(F_FIXNUM capacity);
void rehash_string(F_STRING* str);
void primitive_rehash_string(void);
F_STRING* string(F_FIXNUM capacity, CELL fill);
void primitive_string(void);
F_STRING *resize_string(F_STRING *string, F_FIXNUM capacity, u16 fill);
void primitive_resize_string(void);
F_STRING *memory_to_char_string(const char *string, CELL length);
void primitive_memory_to_char_string(void);
F_STRING *from_char_string(const char *c_string);
DLLEXPORT void box_char_string(const char *c_string);
void primitive_alien_to_char_string(void);
F_STRING *memory_to_u16_string(const u16 *string, CELL length);
void primitive_memory_to_u16_string(void);
F_STRING *from_u16_string(const u16 *c_string);
DLLEXPORT void box_u16_string(const u16 *c_string);
void primitive_alien_to_u16_string(void);
void char_string_to_memory(F_STRING *s, char *string);
void primitive_char_string_to_memory(void);
F_ARRAY *string_to_char_alien(F_STRING *s, bool check);
char* to_char_string(F_STRING *s, bool check);
char *pop_char_string(void);
DLLEXPORT char *unbox_char_string(void);
void primitive_string_to_char_alien(void);
void u16_string_to_memory(F_STRING *s, u16 *string);
void primitive_u16_string_to_memory(void);
F_ARRAY *string_to_u16_alien(F_STRING *s, bool check);
u16* to_u16_string(F_STRING *s, bool check);
u16 *pop_u16_string(void);
DLLEXPORT u16 *unbox_u16_string(void);
void primitive_string_to_u16_alien(void);
/* untagged & unchecked */
INLINE CELL string_nth(F_STRING* string, CELL index)
{
return cget(SREF(string,index));
}
/* untagged & unchecked */
INLINE void set_string_nth(F_STRING* string, CELL index, u16 value)
{
cput(SREF(string,index),value);
}
void primitive_char_slot(void);
void primitive_set_char_slot(void);
F_SBUF* sbuf(F_FIXNUM capacity);
void primitive_sbuf(void);
void fixup_sbuf(F_SBUF* sbuf);
void collect_sbuf(F_SBUF* sbuf);
void primitive_hashtable(void);
void fixup_hashtable(F_HASHTABLE* hashtable);
void collect_hashtable(F_HASHTABLE* hashtable);
typedef void (*XT)(F_WORD *word);
INLINE F_WORD *untag_word_fast(CELL tagged)
{
return (F_WORD*)UNTAG(tagged);
}
INLINE F_WORD *untag_word(CELL tagged)
{
type_check(WORD_TYPE,tagged);
return untag_word_fast(tagged);
}
INLINE CELL tag_word(F_WORD *word)
{
return RETAG(word,WORD_TYPE);
}
void update_xt(F_WORD* word);
void primitive_word(void);
void primitive_update_xt(void);
void primitive_word_compiledp(void);
void fixup_word(F_WORD* word);
void collect_word(F_WORD* word);
INLINE F_WRAPPER *untag_wrapper_fast(CELL tagged)
{
return (F_WRAPPER*)UNTAG(tagged);
}
INLINE CELL tag_wrapper(F_WRAPPER *wrapper)
{
return RETAG(wrapper,WRAPPER_TYPE);
}
void primitive_wrapper(void);
void fixup_wrapper(F_WRAPPER *wrapper);
void collect_wrapper(F_WRAPPER *wrapper);

55
vm/unix/ffi.c
View File

@ -1,55 +0,0 @@
#include "../factor.h"
static void *null_dll;
void init_ffi(void)
{
null_dll = dlopen(NULL,RTLD_LAZY);
}
void ffi_dlopen(DLL *dll, bool error)
{
void *dllptr = dlopen(to_char_string(untag_string(dll->path),true), RTLD_LAZY);
if(dllptr == NULL)
{
if(error)
{
general_error(ERROR_FFI,tag_object(
from_char_string(dlerror())),F,true);
}
else
dll->dll = NULL;
return;
}
dll->dll = dllptr;
}
void *ffi_dlsym(DLL *dll, F_STRING *symbol, bool error)
{
void *handle = (dll == NULL ? null_dll : dll->dll);
void *sym = dlsym(handle,to_char_string(symbol,true));
if(sym == NULL)
{
if(error)
{
general_error(ERROR_FFI,tag_object(
from_char_string(dlerror())),F,true);
}
return NULL;
}
return sym;
}
void ffi_dlclose(DLL *dll)
{
if(dlclose(dll->dll))
{
general_error(ERROR_FFI,tag_object(
from_char_string(dlerror())),F,true);
}
dll->dll = NULL;
}

75
vm/unix/file.c
View File

@ -1,75 +0,0 @@
#include "../factor.h"
void primitive_stat(void)
{
struct stat sb;
F_STRING* path;
maybe_gc(0);
path = untag_string(dpop());
if(stat(to_char_string(path,true),&sb) < 0)
dpush(F);
else
{
CELL dirp = tag_boolean(S_ISDIR(sb.st_mode));
CELL mode = tag_fixnum(sb.st_mode & ~S_IFMT);
CELL size = tag_bignum(s48_long_long_to_bignum(sb.st_size));
CELL mtime = tag_integer(sb.st_mtime);
dpush(make_array_4(dirp,mode,size,mtime));
}
}
void primitive_read_dir(void)
{
F_STRING *path;
DIR* dir;
F_ARRAY *result;
CELL result_count = 0;
maybe_gc(0);
result = array(ARRAY_TYPE,100,F);
path = untag_string(dpop());
dir = opendir(to_char_string(path,true));
if(dir != NULL)
{
struct dirent* file;
while((file = readdir(dir)) != NULL)
{
CELL name = tag_object(from_char_string(file->d_name));
if(result_count == array_capacity(result))
{
result = resize_array(result,
result_count * 2,F);
}
put(AREF(result,result_count),name);
result_count++;
}
closedir(dir);
}
result = resize_array(result,result_count,F);
dpush(tag_object(result));
}
void primitive_cwd(void)
{
char wd[MAXPATHLEN];
maybe_gc(0);
if(getcwd(wd,MAXPATHLEN) == NULL)
io_error();
box_char_string(wd);
}
void primitive_cd(void)
{
maybe_gc(0);
chdir(pop_char_string());
}

36
vm/unix/icache.S
View File

@ -1,36 +0,0 @@
#include "../platform.h"
/* Thanks to Joshua Grams for this code.
On PowerPC processors, we must flush the instruction cache manually
after writing to the code heap.
Callable from C as
void flush_icache(void *start, int len)
This function is called from compiler.c. */
#ifdef FACTOR_PPC
/* IN: 3 = start, 4 = len */
.globl MANGLE(flush_icache)
MANGLE(flush_icache):
/* 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
#endif

39
vm/unix/memory.c
View File

@ -1,39 +0,0 @@
#include "../factor.h"
BOUNDED_BLOCK *alloc_bounded_block(CELL size)
{
int pagesize = getpagesize();
char *array = mmap((void*)0,pagesize + size + pagesize,
PROT_READ | PROT_WRITE | PROT_EXEC,
MAP_ANON | MAP_PRIVATE,-1,0);
if(array == NULL)
fatal_error("Cannot allocate memory region",0);
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);
BOUNDED_BLOCK *retval = safe_malloc(sizeof(BOUNDED_BLOCK));
retval->start = (CELL)(array + pagesize);
retval->size = size;
return retval;
}
void dealloc_bounded_block(BOUNDED_BLOCK *block)
{
int pagesize = getpagesize();
int retval = munmap((void*)(block->start - pagesize),
pagesize + block->size + pagesize);
if(retval)
fatal_error("Failed to unmap region",0);
free(block);
}

68
vm/unix/signal.c
View File

@ -1,68 +0,0 @@
#include "../factor.h"
#include "../macosx/mach_signal.h"
// this function tests if a given faulting location is in a poison page. The
// page address is taken from area + round_up_to_page_size(area_size) +
// pagesize*offset
static bool in_page(void *fault, void *i_area, CELL area_size, int offset)
{
const int pagesize = getpagesize();
intptr_t area = (intptr_t) i_area;
area += pagesize * ((area_size + (pagesize - 1)) / pagesize);
area += offset * pagesize;
const int page = area / pagesize;
const int fault_page = (intptr_t)fault / pagesize;
return page == fault_page;
}
void signal_handler(int signal, siginfo_t* siginfo, void* uap)
{
if(in_page(siginfo->si_addr, (void *) ds_bot, 0, -1))
general_error(ERROR_DS_UNDERFLOW,F,F,false);
else if(in_page(siginfo->si_addr, (void *) ds_bot, ds_size, 0))
general_error(ERROR_DS_OVERFLOW,F,F,false);
else if(in_page(siginfo->si_addr, (void *) rs_bot, 0, -1))
general_error(ERROR_RS_UNDERFLOW,F,F,false);
else if(in_page(siginfo->si_addr, (void *) rs_bot, rs_size, 0))
general_error(ERROR_RS_OVERFLOW,F,F,false);
else if(in_page(siginfo->si_addr, (void *) cs_bot, 0, -1))
general_error(ERROR_CS_UNDERFLOW,F,F,false);
else if(in_page(siginfo->si_addr, (void *) cs_bot, cs_size, 0))
general_error(ERROR_CS_OVERFLOW,F,F,false);
else
signal_error(signal);
}
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);
}
void init_signals(void)
{
struct sigaction custom_sigaction;
struct sigaction ign_sigaction;
sigemptyset(&custom_sigaction.sa_mask);
custom_sigaction.sa_sigaction = signal_handler;
custom_sigaction.sa_flags = SA_SIGINFO;
sigaction_safe(SIGABRT,&custom_sigaction,NULL);
sigaction_safe(SIGFPE,&custom_sigaction,NULL);
sigaction_safe(SIGBUS,&custom_sigaction,NULL);
sigaction_safe(SIGQUIT,&custom_sigaction,NULL);
sigaction_safe(SIGSEGV,&custom_sigaction,NULL);
sigaction_safe(SIGILL,&custom_sigaction,NULL);
sigemptyset(&ign_sigaction.sa_mask);
ign_sigaction.sa_handler = SIG_IGN;
sigaction_safe(SIGPIPE,&ign_sigaction,NULL);
#ifdef __APPLE__
mach_initialize();
#endif
}

38
vm/vector.c
View File

@ -1,38 +0,0 @@
#include "factor.h"
F_VECTOR* vector(F_FIXNUM capacity)
{
F_VECTOR* vector = allot_object(VECTOR_TYPE,sizeof(F_VECTOR));
vector->top = tag_fixnum(0);
vector->array = tag_object(array(ARRAY_TYPE,capacity,F));
return vector;
}
void primitive_vector(void)
{
CELL size = to_fixnum(dpeek());
maybe_gc(array_size(size) + sizeof(F_VECTOR));
drepl(tag_object(vector(size)));
}
void primitive_array_to_vector(void)
{
F_ARRAY *array;
F_VECTOR *vector;
maybe_gc(sizeof(F_VECTOR));
array = untag_array(dpeek());
vector = allot_object(VECTOR_TYPE,sizeof(F_VECTOR));
vector->top = array->capacity;
vector->array = tag_object(array);
drepl(tag_object(vector));
}
void fixup_vector(F_VECTOR* vector)
{
data_fixup(&vector->array);
}
void collect_vector(F_VECTOR* vector)
{
copy_handle(&vector->array);
}

21
vm/vector.h
View File

@ -1,21 +0,0 @@
typedef struct {
/* always tag_header(VECTOR_TYPE) */
CELL header;
/* tagged */
CELL top;
/* tagged */
CELL array;
} F_VECTOR;
INLINE F_VECTOR* untag_vector(CELL tagged)
{
type_check(VECTOR_TYPE,tagged);
return (F_VECTOR*)UNTAG(tagged);
}
F_VECTOR* vector(F_FIXNUM capacity);
void primitive_vector(void);
void primitive_array_to_vector(void);
void fixup_vector(F_VECTOR* vector);
void collect_vector(F_VECTOR* vector);

46
vm/windows/ffi.c
View File

@ -1,46 +0,0 @@
#include "../factor.h"
void init_ffi (void)
{
}
void ffi_dlopen (DLL *dll, bool error)
{
HMODULE module;
char *path = to_c_string(untag_string(dll->path),true);
module = LoadLibrary(path);
if (!module)
{
dll->dll = NULL;
if(error)
general_error(ERROR_FFI, tag_object(get_error_message()),true);
else
return;
}
dll->dll = module;
}
void *ffi_dlsym (DLL *dll, F_STRING *symbol, bool error)
{
void *sym = GetProcAddress(dll ? (HMODULE)dll->dll : GetModuleHandle(NULL),
to_c_string(symbol,true));
if (!sym)
{
if(error)
general_error(ERROR_FFI, tag_object(get_error_message()),true);
else
return NULL;
}
return sym;
}
void ffi_dlclose (DLL *dll)
{
FreeLibrary((HMODULE)dll->dll);
dll->dll = NULL;
}

79
vm/windows/file.c
View File

@ -1,79 +0,0 @@
#include "../factor.h"
void primitive_stat(void)
{
F_STRING *path;
WIN32_FILE_ATTRIBUTE_DATA st;
maybe_gc(0);
path = untag_string(dpop());
if(!GetFileAttributesEx(to_c_string(path,true), GetFileExInfoStandard, &st))
{
dpush(F);
}
else
{
CELL dirp = tag_boolean(st.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY);
CELL size = tag_bignum(s48_long_long_to_bignum(
(s64)st.nFileSizeLow | (s64)st.nFileSizeHigh << 32));
CELL mtime = tag_integer((int)
((*(s64*)&st.ftLastWriteTime - EPOCH_OFFSET) / 10000000));
dpush(make_array_4(dirp,tag_fixnum(0),size,mtime));
}
}
void primitive_read_dir(void)
{
F_STRING *path;
HANDLE dir;
WIN32_FIND_DATA find_data;
F_ARRAY *result;
CELL result_count = 0;
maybe_gc(0);
result = array(ARRAY_TYPE,100,F);
path = untag_string(dpop());
if (INVALID_HANDLE_VALUE != (dir = FindFirstFile(".\\*", &find_data)))
{
do
{
CELL name = tag_object(from_c_string(
find_data.cFileName));
if(result_count == array_capacity(result))
{
result = resize_array(result,
result_count * 2,F);
}
put(AREF(result,result_count),name);
result_count++;
}
while (FindNextFile(dir, &find_data));
CloseHandle(dir);
}
result = resize_array(result,result_count,F);
dpush(tag_object(result));
}
void primitive_cwd(void)
{
char buf[MAX_PATH];
maybe_gc(0);
if(!GetCurrentDirectory(MAX_PATH, buf))
io_error();
box_c_string(buf);
}
void primitive_cd(void)
{
maybe_gc(0);
SetCurrentDirectory(pop_c_string());
}

35
vm/windows/memory.c
View File

@ -1,35 +0,0 @@
#include "../factor.h"
BOUNDED_BLOCK *alloc_bounded_block(CELL size)
{
SYSTEM_INFO si;
char *mem;
DWORD ignore;
GetSystemInfo(&si);
if((mem = (char *)VirtualAlloc(NULL, si.dwPageSize*2 + size, MEM_COMMIT, PAGE_EXECUTE_READWRITE)) == 0)
fatal_error("VirtualAlloc() failed in alloc_bounded_block()",0);
if (!VirtualProtect(mem, si.dwPageSize, PAGE_NOACCESS, &ignore))
fatal_error("Cannot allocate low guard page", (CELL)mem);
if (!VirtualProtect(mem+size+si.dwPageSize, si.dwPageSize, PAGE_NOACCESS, &ignore))
fatal_error("Cannot allocate high guard page", (CELL)mem);
BOUNDED_BLOCK *block = safe_malloc(sizeof(BOUNDED_BLOCK));
block->start = (int)mem + si.dwPageSize;
block->size = size;
return block;
}
void dealloc_bounded_block(BOUNDED_BLOCK *block)
{
SYSTEM_INFO si;
GetSystemInfo(&si);
if(!VirtualFree((void*)(block->start - si.dwPageSize), 0, MEM_RELEASE))
fatal_error("VirtualFree() failed",0);
free(block);
}

3
vm/windows/misc.c
View File

@ -1,3 +0,0 @@
#include "../factor.h"
void init_signals() { }

37
vm/windows/run.c
View File

@ -1,37 +0,0 @@
#include "../factor.h"
/* SEH support. Proceed with caution. */
typedef long exception_handler_t(
void *rec, void *frame, void *context, void *dispatch);
typedef struct exception_record {
struct exception_record *next_handler;
void *handler_func;
} exception_record_t;
void seh_call(void (*func)(), exception_handler_t *handler)
{
exception_record_t record;
asm("mov %%fs:0, %0" : "=r" (record.next_handler));
asm("mov %0, %%fs:0" : : "r" (&record));
record.handler_func = handler;
func();
asm("mov %0, %%fs:0" : "=r" (record.next_handler));
}
static long exception_handler(void *rec, void *frame, void *ctx, void *dispatch)
{
signal_error(SIGSEGV);
}
void platform_run(void)
{
seh_call(run_toplevel, exception_handler);
}
void early_init(void) {}
const char *default_image_path(void)
{
return "factor.image";
}

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