From 6d21c52ac94fdc31bb5df7f07ccc88086cfd7ef7 Mon Sep 17 00:00:00 2001 From: slava Date: Fri, 7 Jul 2006 04:07:18 +0000 Subject: [PATCH] Big runtime cleanup --- Makefile | 139 +- README.txt | 19 +- TODO.FACTOR.txt | 3 - contrib/README.txt | 6 +- vm/Config.freebsd | 4 + vm/Config.linux | 4 + vm/Config.linux.ppc | 3 + vm/Config.macosx | 3 + vm/Config.macosx.ppc | 2 + vm/Config.ppc | 1 + vm/Config.solaris | 4 + vm/Config.unix | 1 + vm/Config.windows | 3 + vm/alien.c | 54 + vm/alien.h | 20 +- vm/array.c | 154 --- vm/array.h | 54 - vm/bignum.c | 1967 ++++++++++++++++++++++++--- vm/bignum.h | 209 ++- vm/{s48_bignumint.h => bignumint.h} | 0 vm/boolean.c | 13 - vm/boolean.h | 7 - vm/cards.c | 66 - vm/cards.h | 71 - vm/compiler.c | 50 - vm/compiler.h | 30 - vm/complex.c | 28 - vm/complex.h | 9 - vm/cpu-amd64.h | 7 + vm/cpu-ppc.h | 7 + vm/cpu-x86.h | 7 + vm/debug.c | 11 +- vm/dll.c | 55 - vm/dll.h | 26 - vm/error.c | 67 - vm/error.h | 41 - vm/factor.c | 23 - vm/factor.h | 113 +- vm/file.h | 7 - vm/fixnum.c | 220 --- vm/fixnum.h | 39 - vm/float.c | 244 ---- vm/float.h | 75 - vm/gc.c | 389 ------ vm/gc.h | 119 -- vm/hashtable.c | 26 - vm/hashtable.h | 14 - vm/image.c | 192 ++- vm/image.h | 61 + vm/layouts.h | 166 +++ vm/{macosx => }/mach_signal.c | 10 +- vm/{macosx => }/mach_signal.h | 24 - vm/math.c | 778 +++++++++++ vm/math.h | 187 +++ vm/memory.c | 461 +++++++ vm/memory.h | 235 +++- vm/misc.c | 97 -- vm/misc.h | 11 - vm/os-freebsd.h | 1 + vm/{unix/run.c => os-genunix.c} | 9 +- vm/os-genunix.h | 3 + vm/os-linux.h | 1 + vm/os-macosx-ppc.h | 8 + vm/os-macosx-x86.h | 8 + vm/os-macosx.h | 4 + vm/{macosx/run.m => os-macosx.m} | 9 +- vm/os-solaris.h | 1 + vm/os-unix.c | 241 ++++ vm/os-unix.h | 31 + vm/os-windows.c | 234 ++++ vm/os-windows.h | 35 + vm/platform.h | 71 +- vm/ratio.c | 30 - vm/ratio.h | 9 - vm/relocate.c | 192 --- vm/relocate.h | 60 - vm/run.c | 145 ++ vm/run.h | 136 +- vm/s48_bignum.c | 1909 -------------------------- vm/s48_bignum.h | 156 --- vm/sbuf.c | 29 - vm/sbuf.h | 13 - vm/signal.h | 5 - vm/stack.h | 54 + vm/string.c | 220 --- vm/string.h | 81 -- vm/types.c | 563 ++++++++ vm/types.h | 191 +++ vm/unix/ffi.c | 55 - vm/unix/file.c | 75 - vm/unix/icache.S | 36 - vm/unix/memory.c | 39 - vm/unix/signal.c | 68 - vm/vector.c | 38 - vm/vector.h | 21 - vm/windows/ffi.c | 46 - vm/windows/file.c | 79 -- vm/windows/memory.c | 35 - vm/windows/misc.c | 3 - vm/windows/run.c | 37 - vm/word.c | 68 - vm/word.h | 43 - vm/wrapper.c | 22 - vm/wrapper.h | 18 - 104 files changed, 5830 insertions(+), 5938 deletions(-) create mode 100644 vm/Config.freebsd create mode 100644 vm/Config.linux create mode 100644 vm/Config.linux.ppc create mode 100644 vm/Config.macosx create mode 100644 vm/Config.macosx.ppc create mode 100644 vm/Config.ppc create mode 100644 vm/Config.solaris create mode 100644 vm/Config.unix create mode 100644 vm/Config.windows delete mode 100644 vm/array.c delete mode 100644 vm/array.h rename vm/{s48_bignumint.h => bignumint.h} (100%) delete mode 100644 vm/boolean.c delete mode 100644 vm/boolean.h delete mode 100644 vm/cards.c delete mode 100644 vm/cards.h delete mode 100644 vm/compiler.c delete mode 100644 vm/compiler.h delete mode 100644 vm/complex.c delete mode 100644 vm/complex.h create mode 100644 vm/cpu-amd64.h create mode 100644 vm/cpu-ppc.h create mode 100644 vm/cpu-x86.h delete mode 100644 vm/dll.c delete mode 100644 vm/dll.h delete mode 100644 vm/error.c delete mode 100644 vm/error.h delete mode 100644 vm/file.h delete mode 100644 vm/fixnum.c delete mode 100644 vm/fixnum.h delete mode 100644 vm/float.c delete mode 100644 vm/float.h delete mode 100644 vm/gc.c delete mode 100644 vm/gc.h delete mode 100644 vm/hashtable.c delete mode 100644 vm/hashtable.h create mode 100644 vm/layouts.h rename vm/{macosx => }/mach_signal.c (98%) rename vm/{macosx => }/mach_signal.h (77%) create mode 100644 vm/math.c create mode 100644 vm/math.h delete mode 100644 vm/misc.c delete mode 100644 vm/misc.h create mode 100644 vm/os-freebsd.h rename vm/{unix/run.c => os-genunix.c} (61%) create mode 100644 vm/os-genunix.h create mode 100644 vm/os-linux.h create mode 100644 vm/os-macosx-ppc.h create mode 100644 vm/os-macosx-x86.h create mode 100644 vm/os-macosx.h rename vm/{macosx/run.m => os-macosx.m} (91%) create mode 100644 vm/os-solaris.h create mode 100644 vm/os-unix.c create mode 100644 vm/os-unix.h create mode 100644 vm/os-windows.c create mode 100644 vm/os-windows.h delete mode 100644 vm/ratio.c delete mode 100644 vm/ratio.h delete mode 100644 vm/relocate.c delete mode 100644 vm/relocate.h delete mode 100644 vm/s48_bignum.c delete mode 100644 vm/s48_bignum.h delete mode 100644 vm/sbuf.c delete mode 100644 vm/sbuf.h delete mode 100644 vm/signal.h delete mode 100644 vm/string.c delete mode 100644 vm/string.h create mode 100644 vm/types.c create mode 100644 vm/types.h delete mode 100644 vm/unix/ffi.c delete mode 100644 vm/unix/file.c delete mode 100644 vm/unix/icache.S delete mode 100644 vm/unix/memory.c delete mode 100644 vm/unix/signal.c delete mode 100644 vm/vector.c delete mode 100644 vm/vector.h delete mode 100644 vm/windows/ffi.c delete mode 100644 vm/windows/file.c delete mode 100644 vm/windows/memory.c delete mode 100644 vm/windows/misc.c delete mode 100644 vm/windows/run.c delete mode 100644 vm/word.c delete mode 100644 vm/word.h delete mode 100644 vm/wrapper.c delete mode 100644 vm/wrapper.h diff --git a/Makefile b/Makefile index 1d60d7292b..b288fee44b 100644 --- a/Makefile +++ b/Makefile @@ -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) - diff --git a/README.txt b/README.txt index 6ebb76605a..1310d862cf 100644 --- a/README.txt +++ b/README.txt @@ -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 diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index da56811841..0691aeb4d3 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -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: diff --git a/contrib/README.txt b/contrib/README.txt index 0bb151e248..d00a473964 100644 --- a/contrib/README.txt +++ b/contrib/README.txt @@ -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) diff --git a/vm/Config.freebsd b/vm/Config.freebsd new file mode 100644 index 0000000000..4ff6241d7d --- /dev/null +++ b/vm/Config.freebsd @@ -0,0 +1,4 @@ +include vm/Config.unix +PLAF_OBJS += vm/genunix.o +CFLAGS += -export-dynamic -pthread +LIBS = -ldl -lm $(X11_UI_LIBS) diff --git a/vm/Config.linux b/vm/Config.linux new file mode 100644 index 0000000000..ed2a04820f --- /dev/null +++ b/vm/Config.linux @@ -0,0 +1,4 @@ +include vm/Config.unix +PLAF_OBJS += vm/genunix.o +CFLAGS += -export-dynamic +LIBS = -ldl -lm $(X11_UI_LIBS) diff --git a/vm/Config.linux.ppc b/vm/Config.linux.ppc new file mode 100644 index 0000000000..1ee3b35c9a --- /dev/null +++ b/vm/Config.linux.ppc @@ -0,0 +1,3 @@ +include vm/Config.linux +include vm/Config.ppc +CFLAGS += -mregnames diff --git a/vm/Config.macosx b/vm/Config.macosx new file mode 100644 index 0000000000..e7d2267d38 --- /dev/null +++ b/vm/Config.macosx @@ -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 diff --git a/vm/Config.macosx.ppc b/vm/Config.macosx.ppc new file mode 100644 index 0000000000..d31bb54f00 --- /dev/null +++ b/vm/Config.macosx.ppc @@ -0,0 +1,2 @@ +include vm/Config.macosx +include vm/Config.ppc diff --git a/vm/Config.ppc b/vm/Config.ppc new file mode 100644 index 0000000000..8b6fb9980b --- /dev/null +++ b/vm/Config.ppc @@ -0,0 +1 @@ +PLAF_OBJS += vm/cpu-ppc.o diff --git a/vm/Config.solaris b/vm/Config.solaris new file mode 100644 index 0000000000..f2d4afa462 --- /dev/null +++ b/vm/Config.solaris @@ -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) diff --git a/vm/Config.unix b/vm/Config.unix new file mode 100644 index 0000000000..821ea8394f --- /dev/null +++ b/vm/Config.unix @@ -0,0 +1 @@ +PLAF_OBJS = vm/os-unix.o diff --git a/vm/Config.windows b/vm/Config.windows new file mode 100644 index 0000000000..155b8cf343 --- /dev/null +++ b/vm/Config.windows @@ -0,0 +1,3 @@ +CFLAGS += -DWINDOWS +LIBS = -lm +PLAF_SUFFIX = .exe diff --git a/vm/alien.c b/vm/alien.c index cd8baf2276..5832c020bc 100644 --- a/vm/alien.c +++ b/vm/alien.c @@ -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); +} diff --git a/vm/alien.h b/vm/alien.h index f4051d3795..b1de7a6fe8 100644 --- a/vm/alien.h +++ b/vm/alien.h @@ -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); diff --git a/vm/array.c b/vm/array.c deleted file mode 100644 index 2379b1d3c6..0000000000 --- a/vm/array.c +++ /dev/null @@ -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)); -} diff --git a/vm/array.h b/vm/array.h deleted file mode 100644 index c8c05645a3..0000000000 --- a/vm/array.h +++ /dev/null @@ -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); diff --git a/vm/bignum.c b/vm/bignum.c index d6f860bf6c..5d6126fbab 100644 --- a/vm/bignum.c +++ b/vm/bignum.c @@ -1,250 +1,1909 @@ +/* :tabSize=2:indentSize=2:noTabs=true: + +$Id: s48_bignum.c,v 1.12 2005/12/21 02:36:52 spestov Exp $ + +Copyright (c) 1989-94 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. */ + +/* Changes for Scheme 48: + * - Converted to ANSI. + * - Added bitwise operations. + * - Added s48_ to the beginning of all externally visible names. + * - Cached the bignum representations of -1, 0, and 1. + */ + +/* Changes for Factor: + * - Add s48_ prefix to file names + * - Adapt s48_bignumint.h for Factor memory manager + * - Add more bignum <-> C type conversions + */ + #include "factor.h" +#include +#include +#include /* abort */ +#include -CELL to_cell(CELL x) +/* Exports */ + +int +s48_bignum_equal_p(bignum_type x, bignum_type y) { - 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; - } + return + ((BIGNUM_ZERO_P (x)) + ? (BIGNUM_ZERO_P (y)) + : ((! (BIGNUM_ZERO_P (y))) + && ((BIGNUM_NEGATIVE_P (x)) + ? (BIGNUM_NEGATIVE_P (y)) + : (! (BIGNUM_NEGATIVE_P (y)))) + && (bignum_equal_p_unsigned (x, y)))); } -F_ARRAY* to_bignum(CELL tagged) +enum bignum_comparison +s48_bignum_test(bignum_type bignum) { - 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 */ - } + return + ((BIGNUM_ZERO_P (bignum)) + ? bignum_comparison_equal + : (BIGNUM_NEGATIVE_P (bignum)) + ? bignum_comparison_less + : bignum_comparison_greater); } -void primitive_to_bignum(void) +enum bignum_comparison +s48_bignum_compare(bignum_type x, bignum_type y) { - maybe_gc(0); - drepl(tag_bignum(to_bignum(dpeek()))); + return + ((BIGNUM_ZERO_P (x)) + ? ((BIGNUM_ZERO_P (y)) + ? bignum_comparison_equal + : (BIGNUM_NEGATIVE_P (y)) + ? bignum_comparison_greater + : bignum_comparison_less) + : (BIGNUM_ZERO_P (y)) + ? ((BIGNUM_NEGATIVE_P (x)) + ? bignum_comparison_less + : bignum_comparison_greater) + : (BIGNUM_NEGATIVE_P (x)) + ? ((BIGNUM_NEGATIVE_P (y)) + ? (bignum_compare_unsigned (y, x)) + : (bignum_comparison_less)) + : ((BIGNUM_NEGATIVE_P (y)) + ? (bignum_comparison_greater) + : (bignum_compare_unsigned (x, y)))); } -#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) +bignum_type +s48_bignum_add(bignum_type x, bignum_type y) { - GC_AND_POP_BIGNUMS(x,y); - box_boolean(s48_bignum_equal_p(x,y)); + return + ((BIGNUM_ZERO_P (x)) + ? (BIGNUM_MAYBE_COPY (y)) + : (BIGNUM_ZERO_P (y)) + ? (BIGNUM_MAYBE_COPY (x)) + : ((BIGNUM_NEGATIVE_P (x)) + ? ((BIGNUM_NEGATIVE_P (y)) + ? (bignum_add_unsigned (x, y, 1)) + : (bignum_subtract_unsigned (y, x))) + : ((BIGNUM_NEGATIVE_P (y)) + ? (bignum_subtract_unsigned (x, y)) + : (bignum_add_unsigned (x, y, 0))))); } -void primitive_bignum_add(void) +bignum_type +s48_bignum_subtract(bignum_type x, bignum_type y) { - GC_AND_POP_BIGNUMS(x,y); - dpush(tag_bignum(s48_bignum_add(x,y))); + return + ((BIGNUM_ZERO_P (x)) + ? ((BIGNUM_ZERO_P (y)) + ? (BIGNUM_MAYBE_COPY (y)) + : (bignum_new_sign (y, (! (BIGNUM_NEGATIVE_P (y)))))) + : ((BIGNUM_ZERO_P (y)) + ? (BIGNUM_MAYBE_COPY (x)) + : ((BIGNUM_NEGATIVE_P (x)) + ? ((BIGNUM_NEGATIVE_P (y)) + ? (bignum_subtract_unsigned (y, x)) + : (bignum_add_unsigned (x, y, 1))) + : ((BIGNUM_NEGATIVE_P (y)) + ? (bignum_add_unsigned (x, y, 0)) + : (bignum_subtract_unsigned (x, y)))))); } -void primitive_bignum_subtract(void) +bignum_type +s48_bignum_negate(bignum_type x) { - GC_AND_POP_BIGNUMS(x,y); - dpush(tag_bignum(s48_bignum_subtract(x,y))); + return + ((BIGNUM_ZERO_P (x)) + ? (BIGNUM_MAYBE_COPY (x)) + : (bignum_new_sign (x, (! (BIGNUM_NEGATIVE_P (x)))))); } -void primitive_bignum_multiply(void) +bignum_type +s48_bignum_multiply(bignum_type x, bignum_type y) { - GC_AND_POP_BIGNUMS(x,y); - dpush(tag_bignum(s48_bignum_multiply(x,y))); + bignum_length_type x_length = (BIGNUM_LENGTH (x)); + bignum_length_type y_length = (BIGNUM_LENGTH (y)); + int negative_p = + ((BIGNUM_NEGATIVE_P (x)) + ? (! (BIGNUM_NEGATIVE_P (y))) + : (BIGNUM_NEGATIVE_P (y))); + if (BIGNUM_ZERO_P (x)) + return (BIGNUM_MAYBE_COPY (x)); + if (BIGNUM_ZERO_P (y)) + return (BIGNUM_MAYBE_COPY (y)); + if (x_length == 1) + { + bignum_digit_type digit = (BIGNUM_REF (x, 0)); + if (digit == 1) + return (bignum_maybe_new_sign (y, negative_p)); + if (digit < BIGNUM_RADIX_ROOT) + return (bignum_multiply_unsigned_small_factor (y, digit, negative_p)); + } + if (y_length == 1) + { + bignum_digit_type digit = (BIGNUM_REF (y, 0)); + if (digit == 1) + return (bignum_maybe_new_sign (x, negative_p)); + if (digit < BIGNUM_RADIX_ROOT) + return (bignum_multiply_unsigned_small_factor (x, digit, negative_p)); + } + return (bignum_multiply_unsigned (x, y, negative_p)); } -void primitive_bignum_divint(void) +void +s48_bignum_divide(bignum_type numerator, bignum_type denominator, + bignum_type * quotient, bignum_type * remainder) { - GC_AND_POP_BIGNUMS(x,y); - dpush(tag_bignum(s48_bignum_quotient(x,y))); + if (BIGNUM_ZERO_P (denominator)) + { + raise(SIGFPE); + return; + } + if (BIGNUM_ZERO_P (numerator)) + { + (*quotient) = (BIGNUM_MAYBE_COPY (numerator)); + (*remainder) = (BIGNUM_MAYBE_COPY (numerator)); + } + else + { + int r_negative_p = (BIGNUM_NEGATIVE_P (numerator)); + int q_negative_p = + ((BIGNUM_NEGATIVE_P (denominator)) ? (! r_negative_p) : r_negative_p); + switch (bignum_compare_unsigned (numerator, denominator)) + { + case bignum_comparison_equal: + { + (*quotient) = (BIGNUM_ONE (q_negative_p)); + (*remainder) = (BIGNUM_ZERO ()); + break; + } + case bignum_comparison_less: + { + (*quotient) = (BIGNUM_ZERO ()); + (*remainder) = (BIGNUM_MAYBE_COPY (numerator)); + break; + } + case bignum_comparison_greater: + { + if ((BIGNUM_LENGTH (denominator)) == 1) + { + bignum_digit_type digit = (BIGNUM_REF (denominator, 0)); + if (digit == 1) + { + (*quotient) = + (bignum_maybe_new_sign (numerator, q_negative_p)); + (*remainder) = (BIGNUM_ZERO ()); + break; + } + else if (digit < BIGNUM_RADIX_ROOT) + { + bignum_divide_unsigned_small_denominator + (numerator, digit, + quotient, remainder, + q_negative_p, r_negative_p); + break; + } + else + { + bignum_divide_unsigned_medium_denominator + (numerator, digit, + quotient, remainder, + q_negative_p, r_negative_p); + break; + } + } + bignum_divide_unsigned_large_denominator + (numerator, denominator, + quotient, remainder, + q_negative_p, r_negative_p); + break; + } + } + } } -void primitive_bignum_divfloat(void) +bignum_type +s48_bignum_quotient(bignum_type numerator, bignum_type denominator) { - GC_AND_POP_BIGNUMS(x,y); - dpush(tag_float( - s48_bignum_to_double(x) / - s48_bignum_to_double(y))); + if (BIGNUM_ZERO_P (denominator)) + { + raise(SIGFPE); + return (BIGNUM_OUT_OF_BAND); + } + if (BIGNUM_ZERO_P (numerator)) + return (BIGNUM_MAYBE_COPY (numerator)); + { + int q_negative_p = + ((BIGNUM_NEGATIVE_P (denominator)) + ? (! (BIGNUM_NEGATIVE_P (numerator))) + : (BIGNUM_NEGATIVE_P (numerator))); + switch (bignum_compare_unsigned (numerator, denominator)) + { + case bignum_comparison_equal: + return (BIGNUM_ONE (q_negative_p)); + case bignum_comparison_less: + return (BIGNUM_ZERO ()); + case bignum_comparison_greater: + default: /* to appease gcc -Wall */ + { + bignum_type quotient; + if ((BIGNUM_LENGTH (denominator)) == 1) + { + bignum_digit_type digit = (BIGNUM_REF (denominator, 0)); + if (digit == 1) + return (bignum_maybe_new_sign (numerator, q_negative_p)); + if (digit < BIGNUM_RADIX_ROOT) + bignum_divide_unsigned_small_denominator + (numerator, digit, + ("ient), ((bignum_type *) 0), + q_negative_p, 0); + else + bignum_divide_unsigned_medium_denominator + (numerator, digit, + ("ient), ((bignum_type *) 0), + q_negative_p, 0); + } + else + bignum_divide_unsigned_large_denominator + (numerator, denominator, + ("ient), ((bignum_type *) 0), + q_negative_p, 0); + return (quotient); + } + } + } } -void primitive_bignum_divmod(void) +bignum_type +s48_bignum_remainder(bignum_type numerator, bignum_type denominator) { - 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)); + if (BIGNUM_ZERO_P (denominator)) + { + raise(SIGFPE); + return (BIGNUM_OUT_OF_BAND); + } + if (BIGNUM_ZERO_P (numerator)) + return (BIGNUM_MAYBE_COPY (numerator)); + switch (bignum_compare_unsigned (numerator, denominator)) + { + case bignum_comparison_equal: + return (BIGNUM_ZERO ()); + case bignum_comparison_less: + return (BIGNUM_MAYBE_COPY (numerator)); + case bignum_comparison_greater: + default: /* to appease gcc -Wall */ + { + bignum_type remainder; + if ((BIGNUM_LENGTH (denominator)) == 1) + { + bignum_digit_type digit = (BIGNUM_REF (denominator, 0)); + if (digit == 1) + return (BIGNUM_ZERO ()); + if (digit < BIGNUM_RADIX_ROOT) + return + (bignum_remainder_unsigned_small_denominator + (numerator, digit, (BIGNUM_NEGATIVE_P (numerator)))); + bignum_divide_unsigned_medium_denominator + (numerator, digit, + ((bignum_type *) 0), (&remainder), + 0, (BIGNUM_NEGATIVE_P (numerator))); + } + else + bignum_divide_unsigned_large_denominator + (numerator, denominator, + ((bignum_type *) 0), (&remainder), + 0, (BIGNUM_NEGATIVE_P (numerator))); + return (remainder); + } + } } -void primitive_bignum_mod(void) +#define FOO_TO_BIGNUM(name,type,utype) \ + bignum_type s48_##name##_to_bignum(type n) \ + { \ + int negative_p; \ + bignum_digit_type result_digits [BIGNUM_DIGITS_FOR(type)]; \ + bignum_digit_type * end_digits = result_digits; \ + /* Special cases win when these small constants are cached. */ \ + if (n == 0) return (BIGNUM_ZERO ()); \ + if (n == 1) return (BIGNUM_ONE (0)); \ + if (n == -1) return (BIGNUM_ONE (1)); \ + { \ + utype accumulator = ((negative_p = (n < 0)) ? (-n) : n); \ + do \ + { \ + (*end_digits++) = (accumulator & BIGNUM_DIGIT_MASK); \ + accumulator >>= BIGNUM_DIGIT_LENGTH; \ + } \ + while (accumulator != 0); \ + } \ + { \ + bignum_type result = \ + (bignum_allocate ((end_digits - result_digits), negative_p)); \ + bignum_digit_type * scan_digits = result_digits; \ + bignum_digit_type * scan_result = (BIGNUM_START_PTR (result)); \ + while (scan_digits < end_digits) \ + (*scan_result++) = (*scan_digits++); \ + return (result); \ + } \ + } + +FOO_TO_BIGNUM(cell,CELL,CELL) +FOO_TO_BIGNUM(fixnum,F_FIXNUM,CELL) +FOO_TO_BIGNUM(long,long,unsigned long) +FOO_TO_BIGNUM(ulong,unsigned long,unsigned long) +FOO_TO_BIGNUM(long_long,s64,u64) +FOO_TO_BIGNUM(ulong_long,u64,u64) + +/* this is inefficient; its only used for fixnum multiplication overflow so +it probaly does not matter */ +bignum_type s48_fixnum_pair_to_bignum(CELL x, F_FIXNUM y) { - GC_AND_POP_BIGNUMS(x,y); - dpush(tag_bignum(s48_bignum_remainder(x,y))); + return s48_bignum_add( + s48_bignum_arithmetic_shift( + s48_fixnum_to_bignum(y), + sizeof(unsigned long) * 8), + s48_cell_to_bignum(x)); } -void primitive_bignum_and(void) +#define BIGNUM_TO_FOO(name,type,utype) \ + type s48_bignum_to_##name(bignum_type bignum) \ + { \ + if (BIGNUM_ZERO_P (bignum)) \ + return (0); \ + { \ + utype accumulator = 0; \ + bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); \ + bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); \ + while (start < scan) \ + accumulator = ((accumulator << BIGNUM_DIGIT_LENGTH) + (*--scan)); \ + return ((BIGNUM_NEGATIVE_P (bignum)) ? (-((type)accumulator)) : accumulator); \ + } \ + } + +BIGNUM_TO_FOO(cell,CELL,CELL); +BIGNUM_TO_FOO(fixnum,F_FIXNUM,CELL); +BIGNUM_TO_FOO(long,long,unsigned long) +BIGNUM_TO_FOO(ulong,unsigned long,unsigned long) +BIGNUM_TO_FOO(long_long,s64,u64) +BIGNUM_TO_FOO(ulong_long,u64,u64) + +double +s48_bignum_to_double(bignum_type bignum) { - GC_AND_POP_BIGNUMS(x,y); - dpush(tag_bignum(s48_bignum_bitwise_and(x,y))); + if (BIGNUM_ZERO_P (bignum)) + return (0); + { + double accumulator = 0; + bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); + bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); + while (start < scan) + accumulator = ((accumulator * BIGNUM_RADIX) + (*--scan)); + return ((BIGNUM_NEGATIVE_P (bignum)) ? (-accumulator) : accumulator); + } } -void primitive_bignum_or(void) -{ - GC_AND_POP_BIGNUMS(x,y); - dpush(tag_bignum(s48_bignum_bitwise_ior(x,y))); +#define DTB_WRITE_DIGIT(factor) \ +{ \ + significand *= (factor); \ + digit = ((bignum_digit_type) significand); \ + (*--scan) = digit; \ + significand -= ((double) digit); \ } -void primitive_bignum_xor(void) +bignum_type +s48_double_to_bignum(double x) { - GC_AND_POP_BIGNUMS(x,y); - dpush(tag_bignum(s48_bignum_bitwise_xor(x,y))); + int exponent; + double significand = (frexp (x, (&exponent))); + if (exponent <= 0) return (BIGNUM_ZERO ()); + if (exponent == 1) return (BIGNUM_ONE (x < 0)); + if (significand < 0) significand = (-significand); + { + bignum_length_type length = (BIGNUM_BITS_TO_DIGITS (exponent)); + bignum_type result = (bignum_allocate (length, (x < 0))); + bignum_digit_type * start = (BIGNUM_START_PTR (result)); + bignum_digit_type * scan = (start + length); + bignum_digit_type digit; + int odd_bits = (exponent % BIGNUM_DIGIT_LENGTH); + if (odd_bits > 0) + DTB_WRITE_DIGIT (1L << odd_bits); + while (start < scan) + { + if (significand == 0) + { + while (start < scan) + (*--scan) = 0; + break; + } + DTB_WRITE_DIGIT (BIGNUM_RADIX); + } + return (result); + } } -void primitive_bignum_shift(void) +#undef DTB_WRITE_DIGIT + +int +s48_bignum_fits_in_word_p(bignum_type bignum, long word_length, + int twos_complement_p) { - 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))); + unsigned int n_bits = (twos_complement_p ? (word_length - 1) : word_length); + BIGNUM_ASSERT (n_bits > 0); + { + bignum_length_type length = (BIGNUM_LENGTH (bignum)); + bignum_length_type max_digits = (BIGNUM_BITS_TO_DIGITS (n_bits)); + bignum_digit_type msd, max; + return + ((length < max_digits) || + ((length == max_digits) && + ((((msd = (BIGNUM_REF (bignum, (length - 1)))) < + (max = (1L << (n_bits - ((length - 1) * BIGNUM_DIGIT_LENGTH))))) || + (twos_complement_p && + (msd == max) && + (BIGNUM_NEGATIVE_P (bignum))))))); + } } -void primitive_bignum_less(void) +bignum_type +s48_bignum_length_in_bits(bignum_type bignum) { - GC_AND_POP_BIGNUMS(x,y); - box_boolean(s48_bignum_compare(x,y) == bignum_comparison_less); + if (BIGNUM_ZERO_P (bignum)) + return (BIGNUM_ZERO ()); + { + bignum_length_type index = ((BIGNUM_LENGTH (bignum)) - 1); + bignum_digit_type digit = (BIGNUM_REF (bignum, index)); + bignum_type result = (bignum_allocate (2, 0)); + (BIGNUM_REF (result, 0)) = index; + (BIGNUM_REF (result, 1)) = 0; + bignum_destructive_scale_up (result, BIGNUM_DIGIT_LENGTH); + while (digit > 0) + { + bignum_destructive_add (result, ((bignum_digit_type) 1)); + digit >>= 1; + } + return (bignum_trim (result)); + } } -void primitive_bignum_lesseq(void) +bignum_type +s48_bignum_length_upper_limit(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; - } + bignum_type result = (bignum_allocate (2, 0)); + (BIGNUM_REF (result, 0)) = 0; + (BIGNUM_REF (result, 1)) = BIGNUM_DIGIT_LENGTH; + return (result); } -void primitive_bignum_greater(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) { - GC_AND_POP_BIGNUMS(x,y); - box_boolean(s48_bignum_compare(x,y) == bignum_comparison_greater); + BIGNUM_ASSERT ((radix > 1) && (radix <= BIGNUM_RADIX_ROOT)); + if (n_digits == 0) + return (BIGNUM_ZERO ()); + if (n_digits == 1) + { + long digit = ((long) ((*producer) (context))); + return (s48_long_to_bignum (negative_p ? (- digit) : digit)); + } + { + bignum_length_type length; + { + unsigned int radix_copy = radix; + unsigned int log_radix = 0; + while (radix_copy > 0) + { + radix_copy >>= 1; + log_radix += 1; + } + /* This length will be at least as large as needed. */ + length = (BIGNUM_BITS_TO_DIGITS (n_digits * log_radix)); + } + { + bignum_type result = (bignum_allocate_zeroed (length, negative_p)); + while ((n_digits--) > 0) + { + bignum_destructive_scale_up (result, ((bignum_digit_type) radix)); + bignum_destructive_add + (result, ((bignum_digit_type) ((*producer) (context)))); + } + return (bignum_trim (result)); + } + } } -void primitive_bignum_greatereq(void) +long +s48_bignum_max_digit_stream_radix(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; - } + return (BIGNUM_RADIX_ROOT); } -void primitive_bignum_not(void) +/* Comparisons */ + +int +bignum_equal_p_unsigned(bignum_type x, bignum_type y) { - maybe_gc(0); - drepl(tag_bignum(s48_bignum_bitwise_not( - untag_bignum_fast(dpeek())))); + bignum_length_type length = (BIGNUM_LENGTH (x)); + if (length != (BIGNUM_LENGTH (y))) + return (0); + else + { + bignum_digit_type * scan_x = (BIGNUM_START_PTR (x)); + bignum_digit_type * scan_y = (BIGNUM_START_PTR (y)); + bignum_digit_type * end_x = (scan_x + length); + while (scan_x < end_x) + if ((*scan_x++) != (*scan_y++)) + return (0); + return (1); + } } -void box_signed_cell(F_FIXNUM integer) +enum bignum_comparison +bignum_compare_unsigned(bignum_type x, bignum_type y) { - dpush(tag_integer(integer)); + bignum_length_type x_length = (BIGNUM_LENGTH (x)); + bignum_length_type y_length = (BIGNUM_LENGTH (y)); + if (x_length < y_length) + return (bignum_comparison_less); + if (x_length > y_length) + return (bignum_comparison_greater); + { + bignum_digit_type * start_x = (BIGNUM_START_PTR (x)); + bignum_digit_type * scan_x = (start_x + x_length); + bignum_digit_type * scan_y = ((BIGNUM_START_PTR (y)) + y_length); + while (start_x < scan_x) + { + bignum_digit_type digit_x = (*--scan_x); + bignum_digit_type digit_y = (*--scan_y); + if (digit_x < digit_y) + return (bignum_comparison_less); + if (digit_x > digit_y) + return (bignum_comparison_greater); + } + } + return (bignum_comparison_equal); } -F_FIXNUM unbox_signed_cell(void) +/* Addition */ + +bignum_type +bignum_add_unsigned(bignum_type x, bignum_type y, int negative_p) { - return to_fixnum(dpop()); + if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x))) + { + bignum_type z = x; + x = y; + y = z; + } + { + bignum_length_type x_length = (BIGNUM_LENGTH (x)); + bignum_type r = (bignum_allocate ((x_length + 1), negative_p)); + bignum_digit_type sum; + bignum_digit_type carry = 0; + bignum_digit_type * scan_x = (BIGNUM_START_PTR (x)); + bignum_digit_type * scan_r = (BIGNUM_START_PTR (r)); + { + bignum_digit_type * scan_y = (BIGNUM_START_PTR (y)); + bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y))); + while (scan_y < end_y) + { + sum = ((*scan_x++) + (*scan_y++) + carry); + if (sum < BIGNUM_RADIX) + { + (*scan_r++) = sum; + carry = 0; + } + else + { + (*scan_r++) = (sum - BIGNUM_RADIX); + carry = 1; + } + } + } + { + bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length); + if (carry != 0) + while (scan_x < end_x) + { + sum = ((*scan_x++) + 1); + if (sum < BIGNUM_RADIX) + { + (*scan_r++) = sum; + carry = 0; + break; + } + else + (*scan_r++) = (sum - BIGNUM_RADIX); + } + while (scan_x < end_x) + (*scan_r++) = (*scan_x++); + } + if (carry != 0) + { + (*scan_r) = 1; + return (r); + } + return (bignum_shorten_length (r, x_length)); + } } -void box_unsigned_cell(CELL cell) +/* Subtraction */ + +bignum_type +bignum_subtract_unsigned(bignum_type x, bignum_type y) { - dpush(tag_cell(cell)); + int negative_p; + switch (bignum_compare_unsigned (x, y)) + { + case bignum_comparison_equal: + return (BIGNUM_ZERO ()); + case bignum_comparison_less: + { + bignum_type z = x; + x = y; + y = z; + } + negative_p = 1; + break; + case bignum_comparison_greater: + negative_p = 0; + break; + } + { + bignum_length_type x_length = (BIGNUM_LENGTH (x)); + bignum_type r = (bignum_allocate (x_length, negative_p)); + bignum_digit_type difference; + bignum_digit_type borrow = 0; + bignum_digit_type * scan_x = (BIGNUM_START_PTR (x)); + bignum_digit_type * scan_r = (BIGNUM_START_PTR (r)); + { + bignum_digit_type * scan_y = (BIGNUM_START_PTR (y)); + bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y))); + while (scan_y < end_y) + { + difference = (((*scan_x++) - (*scan_y++)) - borrow); + if (difference < 0) + { + (*scan_r++) = (difference + BIGNUM_RADIX); + borrow = 1; + } + else + { + (*scan_r++) = difference; + borrow = 0; + } + } + } + { + bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length); + if (borrow != 0) + while (scan_x < end_x) + { + difference = ((*scan_x++) - borrow); + if (difference < 0) + (*scan_r++) = (difference + BIGNUM_RADIX); + else + { + (*scan_r++) = difference; + borrow = 0; + break; + } + } + BIGNUM_ASSERT (borrow == 0); + while (scan_x < end_x) + (*scan_r++) = (*scan_x++); + } + return (bignum_trim (r)); + } } -F_FIXNUM unbox_unsigned_cell(void) +/* Multiplication + Maximum value for product_low or product_high: + ((R * R) + (R * (R - 2)) + (R - 1)) + Maximum value for carry: ((R * (R - 1)) + (R - 1)) + where R == BIGNUM_RADIX_ROOT */ + +bignum_type +bignum_multiply_unsigned(bignum_type x, bignum_type y, int negative_p) { - return to_cell(dpop()); + if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x))) + { + bignum_type z = x; + x = y; + y = z; + } + { + bignum_digit_type carry; + bignum_digit_type y_digit_low; + bignum_digit_type y_digit_high; + bignum_digit_type x_digit_low; + bignum_digit_type x_digit_high; + bignum_digit_type product_low; + bignum_digit_type * scan_r; + bignum_digit_type * scan_y; + bignum_length_type x_length = (BIGNUM_LENGTH (x)); + bignum_length_type y_length = (BIGNUM_LENGTH (y)); + bignum_type r = + (bignum_allocate_zeroed ((x_length + y_length), negative_p)); + bignum_digit_type * scan_x = (BIGNUM_START_PTR (x)); + bignum_digit_type * end_x = (scan_x + x_length); + bignum_digit_type * start_y = (BIGNUM_START_PTR (y)); + bignum_digit_type * end_y = (start_y + y_length); + bignum_digit_type * start_r = (BIGNUM_START_PTR (r)); +#define x_digit x_digit_high +#define y_digit y_digit_high +#define product_high carry + while (scan_x < end_x) + { + x_digit = (*scan_x++); + x_digit_low = (HD_LOW (x_digit)); + x_digit_high = (HD_HIGH (x_digit)); + carry = 0; + scan_y = start_y; + scan_r = (start_r++); + while (scan_y < end_y) + { + y_digit = (*scan_y++); + y_digit_low = (HD_LOW (y_digit)); + y_digit_high = (HD_HIGH (y_digit)); + product_low = + ((*scan_r) + + (x_digit_low * y_digit_low) + + (HD_LOW (carry))); + product_high = + ((x_digit_high * y_digit_low) + + (x_digit_low * y_digit_high) + + (HD_HIGH (product_low)) + + (HD_HIGH (carry))); + (*scan_r++) = + (HD_CONS ((HD_LOW (product_high)), (HD_LOW (product_low)))); + carry = + ((x_digit_high * y_digit_high) + + (HD_HIGH (product_high))); + } + (*scan_r) += carry; + } + return (bignum_trim (r)); +#undef x_digit +#undef y_digit +#undef product_high + } } -void box_signed_4(s32 n) +bignum_type +bignum_multiply_unsigned_small_factor(bignum_type x, bignum_digit_type y, + int negative_p) { - dpush(tag_bignum(s48_long_to_bignum(n))); + bignum_length_type length_x = (BIGNUM_LENGTH (x)); + bignum_type p = (bignum_allocate ((length_x + 1), negative_p)); + bignum_destructive_copy (x, p); + (BIGNUM_REF (p, length_x)) = 0; + bignum_destructive_scale_up (p, y); + return (bignum_trim (p)); } -s32 unbox_signed_4(void) +void +bignum_destructive_scale_up(bignum_type bignum, bignum_digit_type factor) { - return to_fixnum(dpop()); + bignum_digit_type carry = 0; + bignum_digit_type * scan = (BIGNUM_START_PTR (bignum)); + bignum_digit_type two_digits; + bignum_digit_type product_low; +#define product_high carry + bignum_digit_type * end = (scan + (BIGNUM_LENGTH (bignum))); + BIGNUM_ASSERT ((factor > 1) && (factor < BIGNUM_RADIX_ROOT)); + while (scan < end) + { + two_digits = (*scan); + product_low = ((factor * (HD_LOW (two_digits))) + (HD_LOW (carry))); + product_high = + ((factor * (HD_HIGH (two_digits))) + + (HD_HIGH (product_low)) + + (HD_HIGH (carry))); + (*scan++) = (HD_CONS ((HD_LOW (product_high)), (HD_LOW (product_low)))); + carry = (HD_HIGH (product_high)); + } + /* A carry here would be an overflow, i.e. it would not fit. + Hopefully the callers allocate enough space that this will + never happen. + */ + BIGNUM_ASSERT (carry == 0); + return; +#undef product_high } -void box_unsigned_4(u32 n) +void +bignum_destructive_add(bignum_type bignum, bignum_digit_type n) { - dpush(tag_bignum(s48_ulong_to_bignum(n))); + bignum_digit_type * scan = (BIGNUM_START_PTR (bignum)); + bignum_digit_type digit; + digit = ((*scan) + n); + if (digit < BIGNUM_RADIX) + { + (*scan) = digit; + return; + } + (*scan++) = (digit - BIGNUM_RADIX); + while (1) + { + digit = ((*scan) + 1); + if (digit < BIGNUM_RADIX) + { + (*scan) = digit; + return; + } + (*scan++) = (digit - BIGNUM_RADIX); + } } -u32 unbox_unsigned_4(void) +/* Division */ + +/* For help understanding this algorithm, see: + Knuth, Donald E., "The Art of Computer Programming", + volume 2, "Seminumerical Algorithms" + section 4.3.1, "Multiple-Precision Arithmetic". */ + +void +bignum_divide_unsigned_large_denominator(bignum_type numerator, + bignum_type denominator, + bignum_type * quotient, + bignum_type * remainder, + int q_negative_p, + int r_negative_p) { - return to_cell(dpop()); + bignum_length_type length_n = ((BIGNUM_LENGTH (numerator)) + 1); + bignum_length_type length_d = (BIGNUM_LENGTH (denominator)); + bignum_type q = + ((quotient != ((bignum_type *) 0)) + ? (bignum_allocate ((length_n - length_d), q_negative_p)) + : BIGNUM_OUT_OF_BAND); + bignum_type u = (bignum_allocate (length_n, r_negative_p)); + int shift = 0; + BIGNUM_ASSERT (length_d > 1); + { + bignum_digit_type v1 = (BIGNUM_REF ((denominator), (length_d - 1))); + while (v1 < (BIGNUM_RADIX / 2)) + { + v1 <<= 1; + shift += 1; + } + } + if (shift == 0) + { + bignum_destructive_copy (numerator, u); + (BIGNUM_REF (u, (length_n - 1))) = 0; + bignum_divide_unsigned_normalized (u, denominator, q); + } + else + { + bignum_type v = (bignum_allocate (length_d, 0)); + bignum_destructive_normalization (numerator, u, shift); + bignum_destructive_normalization (denominator, v, shift); + bignum_divide_unsigned_normalized (u, v, q); + BIGNUM_DEALLOCATE (v); + if (remainder != ((bignum_type *) 0)) + bignum_destructive_unnormalization (u, shift); + } + if (quotient != ((bignum_type *) 0)) + (*quotient) = (bignum_trim (q)); + if (remainder != ((bignum_type *) 0)) + (*remainder) = (bignum_trim (u)); + else + BIGNUM_DEALLOCATE (u); + return; } -void box_signed_8(s64 n) +void +bignum_divide_unsigned_normalized(bignum_type u, bignum_type v, bignum_type q) { - dpush(tag_bignum(s48_long_long_to_bignum(n))); + bignum_length_type u_length = (BIGNUM_LENGTH (u)); + bignum_length_type v_length = (BIGNUM_LENGTH (v)); + bignum_digit_type * u_start = (BIGNUM_START_PTR (u)); + bignum_digit_type * u_scan = (u_start + u_length); + bignum_digit_type * u_scan_limit = (u_start + v_length); + bignum_digit_type * u_scan_start = (u_scan - v_length); + bignum_digit_type * v_start = (BIGNUM_START_PTR (v)); + bignum_digit_type * v_end = (v_start + v_length); + bignum_digit_type * q_scan = NULL; + bignum_digit_type v1 = (v_end[-1]); + bignum_digit_type v2 = (v_end[-2]); + bignum_digit_type ph; /* high half of double-digit product */ + bignum_digit_type pl; /* low half of double-digit product */ + bignum_digit_type guess; + bignum_digit_type gh; /* high half-digit of guess */ + bignum_digit_type ch; /* high half of double-digit comparand */ + bignum_digit_type v2l = (HD_LOW (v2)); + bignum_digit_type v2h = (HD_HIGH (v2)); + bignum_digit_type cl; /* low half of double-digit comparand */ +#define gl ph /* low half-digit of guess */ +#define uj pl +#define qj ph + bignum_digit_type gm; /* memory loc for reference parameter */ + if (q != BIGNUM_OUT_OF_BAND) + q_scan = ((BIGNUM_START_PTR (q)) + (BIGNUM_LENGTH (q))); + while (u_scan_limit < u_scan) + { + uj = (*--u_scan); + if (uj != v1) + { + /* comparand = + (((((uj * BIGNUM_RADIX) + uj1) % v1) * BIGNUM_RADIX) + uj2); + guess = (((uj * BIGNUM_RADIX) + uj1) / v1); */ + cl = (u_scan[-2]); + ch = (bignum_digit_divide (uj, (u_scan[-1]), v1, (&gm))); + guess = gm; + } + else + { + cl = (u_scan[-2]); + ch = ((u_scan[-1]) + v1); + guess = (BIGNUM_RADIX - 1); + } + while (1) + { + /* product = (guess * v2); */ + gl = (HD_LOW (guess)); + gh = (HD_HIGH (guess)); + pl = (v2l * gl); + ph = ((v2l * gh) + (v2h * gl) + (HD_HIGH (pl))); + pl = (HD_CONS ((HD_LOW (ph)), (HD_LOW (pl)))); + ph = ((v2h * gh) + (HD_HIGH (ph))); + /* if (comparand >= product) */ + if ((ch > ph) || ((ch == ph) && (cl >= pl))) + break; + guess -= 1; + /* comparand += (v1 << BIGNUM_DIGIT_LENGTH) */ + ch += v1; + /* if (comparand >= (BIGNUM_RADIX * BIGNUM_RADIX)) */ + if (ch >= BIGNUM_RADIX) + break; + } + qj = (bignum_divide_subtract (v_start, v_end, guess, (--u_scan_start))); + if (q != BIGNUM_OUT_OF_BAND) + (*--q_scan) = qj; + } + return; +#undef gl +#undef uj +#undef qj } -s64 unbox_signed_8(void) +bignum_digit_type +bignum_divide_subtract(bignum_digit_type * v_start, + bignum_digit_type * v_end, + bignum_digit_type guess, + bignum_digit_type * u_start) { - return s48_bignum_to_long_long(to_bignum(dpop())); + bignum_digit_type * v_scan = v_start; + bignum_digit_type * u_scan = u_start; + bignum_digit_type carry = 0; + if (guess == 0) return (0); + { + bignum_digit_type gl = (HD_LOW (guess)); + bignum_digit_type gh = (HD_HIGH (guess)); + bignum_digit_type v; + bignum_digit_type pl; + bignum_digit_type vl; +#define vh v +#define ph carry +#define diff pl + while (v_scan < v_end) + { + v = (*v_scan++); + vl = (HD_LOW (v)); + vh = (HD_HIGH (v)); + pl = ((vl * gl) + (HD_LOW (carry))); + ph = ((vl * gh) + (vh * gl) + (HD_HIGH (pl)) + (HD_HIGH (carry))); + diff = ((*u_scan) - (HD_CONS ((HD_LOW (ph)), (HD_LOW (pl))))); + if (diff < 0) + { + (*u_scan++) = (diff + BIGNUM_RADIX); + carry = ((vh * gh) + (HD_HIGH (ph)) + 1); + } + else + { + (*u_scan++) = diff; + carry = ((vh * gh) + (HD_HIGH (ph))); + } + } + if (carry == 0) + return (guess); + diff = ((*u_scan) - carry); + if (diff < 0) + (*u_scan) = (diff + BIGNUM_RADIX); + else + { + (*u_scan) = diff; + return (guess); + } +#undef vh +#undef ph +#undef diff + } + /* Subtraction generated carry, implying guess is one too large. + Add v back in to bring it back down. */ + v_scan = v_start; + u_scan = u_start; + carry = 0; + while (v_scan < v_end) + { + bignum_digit_type sum = ((*v_scan++) + (*u_scan) + carry); + if (sum < BIGNUM_RADIX) + { + (*u_scan++) = sum; + carry = 0; + } + else + { + (*u_scan++) = (sum - BIGNUM_RADIX); + carry = 1; + } + } + if (carry == 1) + { + bignum_digit_type sum = ((*u_scan) + carry); + (*u_scan) = ((sum < BIGNUM_RADIX) ? sum : (sum - BIGNUM_RADIX)); + } + return (guess - 1); } -void box_unsigned_8(u64 n) +void +bignum_divide_unsigned_medium_denominator(bignum_type numerator, + bignum_digit_type denominator, + bignum_type * quotient, + bignum_type * remainder, + int q_negative_p, + int r_negative_p) { - dpush(tag_bignum(s48_ulong_long_to_bignum(n))); + bignum_length_type length_n = (BIGNUM_LENGTH (numerator)); + bignum_length_type length_q; + bignum_type q; + int shift = 0; + /* Because `bignum_digit_divide' requires a normalized denominator. */ + while (denominator < (BIGNUM_RADIX / 2)) + { + denominator <<= 1; + shift += 1; + } + if (shift == 0) + { + length_q = length_n; + q = (bignum_allocate (length_q, q_negative_p)); + bignum_destructive_copy (numerator, q); + } + else + { + length_q = (length_n + 1); + q = (bignum_allocate (length_q, q_negative_p)); + bignum_destructive_normalization (numerator, q, shift); + } + { + bignum_digit_type r = 0; + bignum_digit_type * start = (BIGNUM_START_PTR (q)); + bignum_digit_type * scan = (start + length_q); + bignum_digit_type qj; + if (quotient != ((bignum_type *) 0)) + { + while (start < scan) + { + r = (bignum_digit_divide (r, (*--scan), denominator, (&qj))); + (*scan) = qj; + } + (*quotient) = (bignum_trim (q)); + } + else + { + while (start < scan) + r = (bignum_digit_divide (r, (*--scan), denominator, (&qj))); + BIGNUM_DEALLOCATE (q); + } + if (remainder != ((bignum_type *) 0)) + { + if (shift != 0) + r >>= shift; + (*remainder) = (bignum_digit_to_bignum (r, r_negative_p)); + } + } + return; } -u64 unbox_unsigned_8(void) +void +bignum_destructive_normalization(bignum_type source, bignum_type target, + int shift_left) { - return s48_bignum_to_ulong_long(to_bignum(dpop())); + bignum_digit_type digit; + bignum_digit_type * scan_source = (BIGNUM_START_PTR (source)); + bignum_digit_type carry = 0; + bignum_digit_type * scan_target = (BIGNUM_START_PTR (target)); + bignum_digit_type * end_source = (scan_source + (BIGNUM_LENGTH (source))); + bignum_digit_type * end_target = (scan_target + (BIGNUM_LENGTH (target))); + int shift_right = (BIGNUM_DIGIT_LENGTH - shift_left); + bignum_digit_type mask = ((1L << shift_right) - 1); + while (scan_source < end_source) + { + digit = (*scan_source++); + (*scan_target++) = (((digit & mask) << shift_left) | carry); + carry = (digit >> shift_right); + } + if (scan_target < end_target) + (*scan_target) = carry; + else + BIGNUM_ASSERT (carry == 0); + return; } + +void +bignum_destructive_unnormalization(bignum_type bignum, int shift_right) +{ + bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); + bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); + bignum_digit_type digit; + bignum_digit_type carry = 0; + int shift_left = (BIGNUM_DIGIT_LENGTH - shift_right); + bignum_digit_type mask = ((1L << shift_right) - 1); + while (start < scan) + { + digit = (*--scan); + (*scan) = ((digit >> shift_right) | carry); + carry = ((digit & mask) << shift_left); + } + BIGNUM_ASSERT (carry == 0); + return; +} + +/* This is a reduced version of the division algorithm, applied to the + case of dividing two bignum digits by one bignum digit. It is + assumed that the numerator, denominator are normalized. */ + +#define BDD_STEP(qn, j) \ +{ \ + uj = (u[j]); \ + if (uj != v1) \ + { \ + uj_uj1 = (HD_CONS (uj, (u[j + 1]))); \ + guess = (uj_uj1 / v1); \ + comparand = (HD_CONS ((uj_uj1 % v1), (u[j + 2]))); \ + } \ + else \ + { \ + guess = (BIGNUM_RADIX_ROOT - 1); \ + comparand = (HD_CONS (((u[j + 1]) + v1), (u[j + 2]))); \ + } \ + while ((guess * v2) > comparand) \ + { \ + guess -= 1; \ + comparand += (v1 << BIGNUM_HALF_DIGIT_LENGTH); \ + if (comparand >= BIGNUM_RADIX) \ + break; \ + } \ + qn = (bignum_digit_divide_subtract (v1, v2, guess, (&u[j]))); \ +} + +bignum_digit_type +bignum_digit_divide(bignum_digit_type uh, bignum_digit_type ul, + bignum_digit_type v, + bignum_digit_type * q) /* return value */ +{ + bignum_digit_type guess; + bignum_digit_type comparand; + bignum_digit_type v1 = (HD_HIGH (v)); + bignum_digit_type v2 = (HD_LOW (v)); + bignum_digit_type uj; + bignum_digit_type uj_uj1; + bignum_digit_type q1; + bignum_digit_type q2; + bignum_digit_type u [4]; + if (uh == 0) + { + if (ul < v) + { + (*q) = 0; + return (ul); + } + else if (ul == v) + { + (*q) = 1; + return (0); + } + } + (u[0]) = (HD_HIGH (uh)); + (u[1]) = (HD_LOW (uh)); + (u[2]) = (HD_HIGH (ul)); + (u[3]) = (HD_LOW (ul)); + v1 = (HD_HIGH (v)); + v2 = (HD_LOW (v)); + BDD_STEP (q1, 0); + BDD_STEP (q2, 1); + (*q) = (HD_CONS (q1, q2)); + return (HD_CONS ((u[2]), (u[3]))); +} + +#undef BDD_STEP + +#define BDDS_MULSUB(vn, un, carry_in) \ +{ \ + product = ((vn * guess) + carry_in); \ + diff = (un - (HD_LOW (product))); \ + if (diff < 0) \ + { \ + un = (diff + BIGNUM_RADIX_ROOT); \ + carry = ((HD_HIGH (product)) + 1); \ + } \ + else \ + { \ + un = diff; \ + carry = (HD_HIGH (product)); \ + } \ +} + +#define BDDS_ADD(vn, un, carry_in) \ +{ \ + sum = (vn + un + carry_in); \ + if (sum < BIGNUM_RADIX_ROOT) \ + { \ + un = sum; \ + carry = 0; \ + } \ + else \ + { \ + un = (sum - BIGNUM_RADIX_ROOT); \ + carry = 1; \ + } \ +} + +bignum_digit_type +bignum_digit_divide_subtract(bignum_digit_type v1, bignum_digit_type v2, + bignum_digit_type guess, bignum_digit_type * u) +{ + { + bignum_digit_type product; + bignum_digit_type diff; + bignum_digit_type carry; + BDDS_MULSUB (v2, (u[2]), 0); + BDDS_MULSUB (v1, (u[1]), carry); + if (carry == 0) + return (guess); + diff = ((u[0]) - carry); + if (diff < 0) + (u[0]) = (diff + BIGNUM_RADIX); + else + { + (u[0]) = diff; + return (guess); + } + } + { + bignum_digit_type sum; + bignum_digit_type carry; + BDDS_ADD(v2, (u[2]), 0); + BDDS_ADD(v1, (u[1]), carry); + if (carry == 1) + (u[0]) += 1; + } + return (guess - 1); +} + +#undef BDDS_MULSUB +#undef BDDS_ADD + +void +bignum_divide_unsigned_small_denominator(bignum_type numerator, + bignum_digit_type denominator, + bignum_type * quotient, + bignum_type * remainder, + int q_negative_p, + int r_negative_p) +{ + bignum_type q = (bignum_new_sign (numerator, q_negative_p)); + bignum_digit_type r = (bignum_destructive_scale_down (q, denominator)); + (*quotient) = (bignum_trim (q)); + if (remainder != ((bignum_type *) 0)) + (*remainder) = (bignum_digit_to_bignum (r, r_negative_p)); + return; +} + +/* Given (denominator > 1), it is fairly easy to show that + (quotient_high < BIGNUM_RADIX_ROOT), after which it is easy to see + that all digits are < BIGNUM_RADIX. */ + +bignum_digit_type +bignum_destructive_scale_down(bignum_type bignum, bignum_digit_type denominator) +{ + bignum_digit_type numerator; + bignum_digit_type remainder = 0; + bignum_digit_type two_digits; +#define quotient_high remainder + bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); + bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); + BIGNUM_ASSERT ((denominator > 1) && (denominator < BIGNUM_RADIX_ROOT)); + while (start < scan) + { + two_digits = (*--scan); + numerator = (HD_CONS (remainder, (HD_HIGH (two_digits)))); + quotient_high = (numerator / denominator); + numerator = (HD_CONS ((numerator % denominator), (HD_LOW (two_digits)))); + (*scan) = (HD_CONS (quotient_high, (numerator / denominator))); + remainder = (numerator % denominator); + } + return (remainder); +#undef quotient_high +} + +bignum_type +bignum_remainder_unsigned_small_denominator( + bignum_type n, bignum_digit_type d, int negative_p) +{ + bignum_digit_type two_digits; + bignum_digit_type * start = (BIGNUM_START_PTR (n)); + bignum_digit_type * scan = (start + (BIGNUM_LENGTH (n))); + bignum_digit_type r = 0; + BIGNUM_ASSERT ((d > 1) && (d < BIGNUM_RADIX_ROOT)); + while (start < scan) + { + two_digits = (*--scan); + r = + ((HD_CONS (((HD_CONS (r, (HD_HIGH (two_digits)))) % d), + (HD_LOW (two_digits)))) + % d); + } + return (bignum_digit_to_bignum (r, negative_p)); +} + +bignum_type +bignum_digit_to_bignum(bignum_digit_type digit, int negative_p) +{ + if (digit == 0) + return (BIGNUM_ZERO ()); + else + { + bignum_type result = (bignum_allocate (1, negative_p)); + (BIGNUM_REF (result, 0)) = digit; + return (result); + } +} + +/* Allocation */ + +bignum_type +bignum_allocate(bignum_length_type length, int negative_p) +{ + BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX)); + { + bignum_type result = (BIGNUM_ALLOCATE (length)); + BIGNUM_SET_NEGATIVE_P (result, negative_p); + return (result); + } +} + +bignum_type +bignum_allocate_zeroed(bignum_length_type length, int negative_p) +{ + BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX)); + { + bignum_type result = (BIGNUM_ALLOCATE (length)); + bignum_digit_type * scan = (BIGNUM_START_PTR (result)); + bignum_digit_type * end = (scan + length); + BIGNUM_SET_NEGATIVE_P (result, negative_p); + while (scan < end) + (*scan++) = 0; + return (result); + } +} + +bignum_type +bignum_shorten_length(bignum_type bignum, bignum_length_type length) +{ + bignum_length_type current_length = (BIGNUM_LENGTH (bignum)); + BIGNUM_ASSERT ((length >= 0) || (length <= current_length)); + if (length < current_length) + { + BIGNUM_REDUCE_LENGTH (bignum, bignum, length); + BIGNUM_SET_NEGATIVE_P (bignum, (length != 0) && (BIGNUM_NEGATIVE_P (bignum))); + } + return (bignum); +} + +bignum_type +bignum_trim(bignum_type bignum) +{ + bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); + bignum_digit_type * end = (start + (BIGNUM_LENGTH (bignum))); + bignum_digit_type * scan = end; + while ((start <= scan) && ((*--scan) == 0)) + ; + scan += 1; + if (scan < end) + { + bignum_length_type length = (scan - start); + BIGNUM_REDUCE_LENGTH (bignum, bignum, length); + BIGNUM_SET_NEGATIVE_P (bignum, (length != 0) && (BIGNUM_NEGATIVE_P (bignum))); + } + return (bignum); +} + +/* Copying */ + +bignum_type +bignum_copy(bignum_type source) +{ + bignum_type target = + (bignum_allocate ((BIGNUM_LENGTH (source)), (BIGNUM_NEGATIVE_P (source)))); + bignum_destructive_copy (source, target); + return (target); +} + +bignum_type +bignum_new_sign(bignum_type bignum, int negative_p) +{ + bignum_type result = + (bignum_allocate ((BIGNUM_LENGTH (bignum)), negative_p)); + bignum_destructive_copy (bignum, result); + return (result); +} + +bignum_type +bignum_maybe_new_sign(bignum_type bignum, int negative_p) +{ +#ifndef BIGNUM_FORCE_NEW_RESULTS + if ((BIGNUM_NEGATIVE_P (bignum)) ? negative_p : (! negative_p)) + return (bignum); + else +#endif /* not BIGNUM_FORCE_NEW_RESULTS */ + { + bignum_type result = + (bignum_allocate ((BIGNUM_LENGTH (bignum)), negative_p)); + bignum_destructive_copy (bignum, result); + return (result); + } +} + +void +bignum_destructive_copy(bignum_type source, bignum_type target) +{ + bignum_digit_type * scan_source = (BIGNUM_START_PTR (source)); + bignum_digit_type * end_source = + (scan_source + (BIGNUM_LENGTH (source))); + bignum_digit_type * scan_target = (BIGNUM_START_PTR (target)); + while (scan_source < end_source) + (*scan_target++) = (*scan_source++); + return; +} + +/* Unused +void +bignum_destructive_zero(bignum_type bignum) +{ + bignum_digit_type * scan = (BIGNUM_START_PTR (bignum)); + bignum_digit_type * end = (scan + (BIGNUM_LENGTH (bignum))); + while (scan < end) + (*scan++) = 0; + return; +} +*/ + +/* + * Added bitwise operations (and oddp). + */ + +int +s48_bignum_oddp (bignum_type bignum) +{ + return (BIGNUM_LENGTH (bignum) > 0) && (BIGNUM_REF (bignum, 0) & 1); +} + +bignum_type +s48_bignum_bitwise_not(bignum_type x) +{ + return s48_bignum_subtract(BIGNUM_ONE(1), x); +} + +bignum_type +s48_bignum_arithmetic_shift(bignum_type arg1, long n) +{ + if (BIGNUM_NEGATIVE_P(arg1) && n < 0) + return + s48_bignum_bitwise_not(bignum_magnitude_ash(s48_bignum_bitwise_not(arg1), + n)); + else + return bignum_magnitude_ash(arg1, n); +} + +/* + * This uses a `long'-returning bignum_length_in_bits() which we don't have. +long +s48_bignum_integer_length(bignum_type arg1) +{ + return((BIGNUM_NEGATIVE_P (arg1)) + ? bignum_length_in_bits (s48_bignum_bitwise_not (arg1)) + : bignum_length_in_bits (arg1)); +} +*/ + +long +s48_bignum_bit_count(bignum_type arg1) +{ + return((BIGNUM_NEGATIVE_P (arg1)) + ? bignum_unsigned_logcount (s48_bignum_bitwise_not (arg1)) + : bignum_unsigned_logcount (arg1)); +} + +#define AND_OP 0 +#define IOR_OP 1 +#define XOR_OP 2 + +bignum_type +s48_bignum_bitwise_and(bignum_type arg1, bignum_type arg2) +{ + return( + (BIGNUM_NEGATIVE_P (arg1)) + ? (BIGNUM_NEGATIVE_P (arg2)) + ? bignum_negneg_bitwise_op(AND_OP, arg1, arg2) + : bignum_posneg_bitwise_op(AND_OP, arg2, arg1) + : (BIGNUM_NEGATIVE_P (arg2)) + ? bignum_posneg_bitwise_op(AND_OP, arg1, arg2) + : bignum_pospos_bitwise_op(AND_OP, arg1, arg2) + ); +} + +bignum_type +s48_bignum_bitwise_ior(bignum_type arg1, bignum_type arg2) +{ + return( + (BIGNUM_NEGATIVE_P (arg1)) + ? (BIGNUM_NEGATIVE_P (arg2)) + ? bignum_negneg_bitwise_op(IOR_OP, arg1, arg2) + : bignum_posneg_bitwise_op(IOR_OP, arg2, arg1) + : (BIGNUM_NEGATIVE_P (arg2)) + ? bignum_posneg_bitwise_op(IOR_OP, arg1, arg2) + : bignum_pospos_bitwise_op(IOR_OP, arg1, arg2) + ); +} + +bignum_type +s48_bignum_bitwise_xor(bignum_type arg1, bignum_type arg2) +{ + return( + (BIGNUM_NEGATIVE_P (arg1)) + ? (BIGNUM_NEGATIVE_P (arg2)) + ? bignum_negneg_bitwise_op(XOR_OP, arg1, arg2) + : bignum_posneg_bitwise_op(XOR_OP, arg2, arg1) + : (BIGNUM_NEGATIVE_P (arg2)) + ? bignum_posneg_bitwise_op(XOR_OP, arg1, arg2) + : bignum_pospos_bitwise_op(XOR_OP, arg1, arg2) + ); +} + +/* ash for the magnitude */ +/* assume arg1 is a big number, n is a long */ +bignum_type +bignum_magnitude_ash(bignum_type arg1, long n) +{ + bignum_type result = NULL; + bignum_digit_type *scan1; + bignum_digit_type *scanr; + bignum_digit_type *end; + + long digit_offset,bit_offset; + + if (BIGNUM_ZERO_P (arg1)) return (arg1); + + if (n > 0) { + digit_offset = n / BIGNUM_DIGIT_LENGTH; + bit_offset = n % BIGNUM_DIGIT_LENGTH; + + result = bignum_allocate_zeroed (BIGNUM_LENGTH (arg1) + digit_offset + 1, + BIGNUM_NEGATIVE_P(arg1)); + + scanr = BIGNUM_START_PTR (result) + digit_offset; + scan1 = BIGNUM_START_PTR (arg1); + end = scan1 + BIGNUM_LENGTH (arg1); + + while (scan1 < end) { + *scanr = *scanr | (*scan1 & BIGNUM_DIGIT_MASK) << bit_offset; + *scanr = *scanr & BIGNUM_DIGIT_MASK; + scanr++; + *scanr = *scan1++ >> (BIGNUM_DIGIT_LENGTH - bit_offset); + *scanr = *scanr & BIGNUM_DIGIT_MASK; + } + } + else if (n < 0 + && (-n >= (BIGNUM_LENGTH (arg1) * (bignum_length_type) BIGNUM_DIGIT_LENGTH))) + result = BIGNUM_ZERO (); + + else if (n < 0) { + digit_offset = -n / BIGNUM_DIGIT_LENGTH; + bit_offset = -n % BIGNUM_DIGIT_LENGTH; + + result = bignum_allocate_zeroed (BIGNUM_LENGTH (arg1) - digit_offset, + BIGNUM_NEGATIVE_P(arg1)); + + scanr = BIGNUM_START_PTR (result); + scan1 = BIGNUM_START_PTR (arg1) + digit_offset; + end = scanr + BIGNUM_LENGTH (result) - 1; + + while (scanr < end) { + *scanr = (*scan1++ & BIGNUM_DIGIT_MASK) >> bit_offset ; + *scanr = (*scanr | + *scan1 << (BIGNUM_DIGIT_LENGTH - bit_offset)) & BIGNUM_DIGIT_MASK; + scanr++; + } + *scanr = (*scan1++ & BIGNUM_DIGIT_MASK) >> bit_offset ; + } + else if (n == 0) result = arg1; + + return (bignum_trim (result)); +} + +bignum_type +bignum_pospos_bitwise_op(int op, bignum_type arg1, bignum_type arg2) +{ + bignum_type result; + bignum_length_type max_length; + + bignum_digit_type *scan1, *end1, digit1; + bignum_digit_type *scan2, *end2, digit2; + bignum_digit_type *scanr, *endr; + + max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2)) + ? BIGNUM_LENGTH(arg1) : BIGNUM_LENGTH(arg2); + + result = bignum_allocate(max_length, 0); + + scanr = BIGNUM_START_PTR(result); + scan1 = BIGNUM_START_PTR(arg1); + scan2 = BIGNUM_START_PTR(arg2); + endr = scanr + max_length; + end1 = scan1 + BIGNUM_LENGTH(arg1); + end2 = scan2 + BIGNUM_LENGTH(arg2); + + while (scanr < endr) { + digit1 = (scan1 < end1) ? *scan1++ : 0; + digit2 = (scan2 < end2) ? *scan2++ : 0; + /* + fprintf(stderr, "[pospos op = %d, i = %ld, d1 = %lx, d2 = %lx]\n", + op, endr - scanr, digit1, digit2); + */ + *scanr++ = (op == 0) ? digit1 & digit2 : + (op == 1) ? digit1 | digit2 : + digit1 ^ digit2; + } + return bignum_trim(result); +} + +bignum_type +bignum_posneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2) +{ + bignum_type result; + bignum_length_type max_length; + + bignum_digit_type *scan1, *end1, digit1; + bignum_digit_type *scan2, *end2, digit2, carry2; + bignum_digit_type *scanr, *endr; + + char neg_p = op == IOR_OP || op == XOR_OP; + + max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2) + 1) + ? BIGNUM_LENGTH(arg1) : BIGNUM_LENGTH(arg2) + 1; + + result = bignum_allocate(max_length, neg_p); + + scanr = BIGNUM_START_PTR(result); + scan1 = BIGNUM_START_PTR(arg1); + scan2 = BIGNUM_START_PTR(arg2); + endr = scanr + max_length; + end1 = scan1 + BIGNUM_LENGTH(arg1); + end2 = scan2 + BIGNUM_LENGTH(arg2); + + carry2 = 1; + + while (scanr < endr) { + digit1 = (scan1 < end1) ? *scan1++ : 0; + digit2 = (~((scan2 < end2) ? *scan2++ : 0) & BIGNUM_DIGIT_MASK) + + carry2; + + if (digit2 < BIGNUM_RADIX) + carry2 = 0; + else + { + digit2 = (digit2 - BIGNUM_RADIX); + carry2 = 1; + } + + *scanr++ = (op == AND_OP) ? digit1 & digit2 : + (op == IOR_OP) ? digit1 | digit2 : + digit1 ^ digit2; + } + + if (neg_p) + bignum_negate_magnitude(result); + + return bignum_trim(result); +} + +bignum_type +bignum_negneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2) +{ + bignum_type result; + bignum_length_type max_length; + + bignum_digit_type *scan1, *end1, digit1, carry1; + bignum_digit_type *scan2, *end2, digit2, carry2; + bignum_digit_type *scanr, *endr; + + char neg_p = op == AND_OP || op == IOR_OP; + + max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2)) + ? BIGNUM_LENGTH(arg1) + 1 : BIGNUM_LENGTH(arg2) + 1; + + result = bignum_allocate(max_length, neg_p); + + scanr = BIGNUM_START_PTR(result); + scan1 = BIGNUM_START_PTR(arg1); + scan2 = BIGNUM_START_PTR(arg2); + endr = scanr + max_length; + end1 = scan1 + BIGNUM_LENGTH(arg1); + end2 = scan2 + BIGNUM_LENGTH(arg2); + + carry1 = 1; + carry2 = 1; + + while (scanr < endr) { + digit1 = (~((scan1 < end1) ? *scan1++ : 0) & BIGNUM_DIGIT_MASK) + carry1; + digit2 = (~((scan2 < end2) ? *scan2++ : 0) & BIGNUM_DIGIT_MASK) + carry2; + + if (digit1 < BIGNUM_RADIX) + carry1 = 0; + else + { + digit1 = (digit1 - BIGNUM_RADIX); + carry1 = 1; + } + + if (digit2 < BIGNUM_RADIX) + carry2 = 0; + else + { + digit2 = (digit2 - BIGNUM_RADIX); + carry2 = 1; + } + + *scanr++ = (op == 0) ? digit1 & digit2 : + (op == 1) ? digit1 | digit2 : + digit1 ^ digit2; + } + + if (neg_p) + bignum_negate_magnitude(result); + + return bignum_trim(result); +} + +void +bignum_negate_magnitude(bignum_type arg) +{ + bignum_digit_type *scan; + bignum_digit_type *end; + bignum_digit_type digit; + bignum_digit_type carry; + + scan = BIGNUM_START_PTR(arg); + end = scan + BIGNUM_LENGTH(arg); + + carry = 1; + + while (scan < end) { + digit = (~*scan & BIGNUM_DIGIT_MASK) + carry; + + if (digit < BIGNUM_RADIX) + carry = 0; + else + { + digit = (digit - BIGNUM_RADIX); + carry = 1; + } + + *scan++ = digit; + } +} + +long +bignum_unsigned_logcount(bignum_type arg) +{ + + bignum_digit_type *scan; + bignum_digit_type *end; + bignum_digit_type digit; + + /* sufficient for any reasonable big number */ + long result; + int i; + + if (BIGNUM_ZERO_P (arg)) return (0L); + + scan = BIGNUM_START_PTR (arg); + end = scan + BIGNUM_LENGTH (arg); + result = 0L; + + while (scan < end) { + digit = *scan++ & BIGNUM_DIGIT_MASK; + for (i = 0; i++ < BIGNUM_DIGIT_LENGTH; digit = digit >> 1L) + result += digit & 1L; + } + + return (result); +} + +int +bignum_logbitp(int shift, bignum_type arg) +{ + return((BIGNUM_NEGATIVE_P (arg)) + ? !bignum_unsigned_logbitp (shift, s48_bignum_bitwise_not (arg)) + : bignum_unsigned_logbitp (shift,arg)); +} + +int +bignum_unsigned_logbitp(int shift, bignum_type bignum) +{ + bignum_length_type len = (BIGNUM_LENGTH (bignum)); + bignum_digit_type digit; + int index = shift / BIGNUM_DIGIT_LENGTH; + int p; + if (index >= len) + return 0; + digit = (BIGNUM_REF (bignum, index)); + p = shift % BIGNUM_DIGIT_LENGTH; + return digit & (1 << p); +} + diff --git a/vm/bignum.h b/vm/bignum.h index ac9df4cb5a..61abc0d9f7 100644 --- a/vm/bignum.h +++ b/vm/bignum.h @@ -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); diff --git a/vm/s48_bignumint.h b/vm/bignumint.h similarity index 100% rename from vm/s48_bignumint.h rename to vm/bignumint.h diff --git a/vm/boolean.c b/vm/boolean.c deleted file mode 100644 index 81f7c647b5..0000000000 --- a/vm/boolean.c +++ /dev/null @@ -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); -} diff --git a/vm/boolean.h b/vm/boolean.h deleted file mode 100644 index 2e21573738..0000000000 --- a/vm/boolean.h +++ /dev/null @@ -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); diff --git a/vm/cards.c b/vm/cards.c deleted file mode 100644 index 850e74c6a1..0000000000 --- a/vm/cards.c +++ /dev/null @@ -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); -} diff --git a/vm/cards.h b/vm/cards.h deleted file mode 100644 index a069cb24b4..0000000000 --- a/vm/cards.h +++ /dev/null @@ -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)<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); -} diff --git a/vm/compiler.h b/vm/compiler.h deleted file mode 100644 index ba6d882e23..0000000000 --- a/vm/compiler.h +++ /dev/null @@ -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); diff --git a/vm/complex.c b/vm/complex.c deleted file mode 100644 index 6f40e27710..0000000000 --- a/vm/complex.c +++ /dev/null @@ -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); -} diff --git a/vm/complex.h b/vm/complex.h deleted file mode 100644 index 8098eee02a..0000000000 --- a/vm/complex.h +++ /dev/null @@ -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); diff --git a/vm/cpu-amd64.h b/vm/cpu-amd64.h new file mode 100644 index 0000000000..77719262ad --- /dev/null +++ b/vm/cpu-amd64.h @@ -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) {} diff --git a/vm/cpu-ppc.h b/vm/cpu-ppc.h new file mode 100644 index 0000000000..0970fa76da --- /dev/null +++ b/vm/cpu-ppc.h @@ -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); diff --git a/vm/cpu-x86.h b/vm/cpu-x86.h new file mode 100644 index 0000000000..3115d3f211 --- /dev/null +++ b/vm/cpu-x86.h @@ -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) {} diff --git a/vm/debug.c b/vm/debug.c index d8cb229e0a..880cbbb8a9 100644 --- a/vm/debug.c +++ b/vm/debug.c @@ -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) diff --git a/vm/dll.c b/vm/dll.c deleted file mode 100644 index 80543ea247..0000000000 --- a/vm/dll.c +++ /dev/null @@ -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); -} diff --git a/vm/dll.h b/vm/dll.h deleted file mode 100644 index 9f532aa6f1..0000000000 --- a/vm/dll.h +++ /dev/null @@ -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); diff --git a/vm/error.c b/vm/error.c deleted file mode 100644 index 48e546bfe8..0000000000 --- a/vm/error.c +++ /dev/null @@ -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); -} diff --git a/vm/error.h b/vm/error.h deleted file mode 100644 index 1f12c67781..0000000000 --- a/vm/error.h +++ /dev/null @@ -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); diff --git a/vm/factor.c b/vm/factor.c index d584804370..60b464a3c9 100644 --- a/vm/factor.c +++ b/vm/factor.c @@ -38,22 +38,6 @@ INLINE bool factor_arg(const char* str, const char* arg, CELL* value) return false; } -void usage(void) -{ - printf("Usage: factor [ 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 .\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]; } diff --git a/vm/factor.h b/vm/factor.h index af7a9cb321..a3529299a2 100644 --- a/vm/factor.h +++ b/vm/factor.h @@ -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< #include #include @@ -72,62 +12,21 @@ CELL callframe_end; #include #include #include - #include -#ifdef WIN32 - #include - #include - - /* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */ - #define EPOCH_OFFSET 0x019db1ded53e8000LL -#else - #include - #include - #include - #include - #include - #include - #include -#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__ */ diff --git a/vm/file.h b/vm/file.h deleted file mode 100644 index 978c062746..0000000000 --- a/vm/file.h +++ /dev/null @@ -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); diff --git a/vm/fixnum.c b/vm/fixnum.c deleted file mode 100644 index 393e6b3e04..0000000000 --- a/vm/fixnum.c +++ /dev/null @@ -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) diff --git a/vm/fixnum.h b/vm/fixnum.h deleted file mode 100644 index 99b4e68676..0000000000 --- a/vm/fixnum.h +++ /dev/null @@ -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); diff --git a/vm/float.c b/vm/float.c deleted file mode 100644 index 1fa5e254c8..0000000000 --- a/vm/float.c +++ /dev/null @@ -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) diff --git a/vm/float.h b/vm/float.h deleted file mode 100644 index 2fa7a270cf..0000000000 --- a/vm/float.h +++ /dev/null @@ -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); diff --git a/vm/gc.c b/vm/gc.c deleted file mode 100644 index 4027a98427..0000000000 --- a/vm/gc.c +++ /dev/null @@ -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))); -} diff --git a/vm/gc.h b/vm/gc.h deleted file mode 100644 index 6fba4fad23..0000000000 --- a/vm/gc.h +++ /dev/null @@ -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); diff --git a/vm/hashtable.c b/vm/hashtable.c deleted file mode 100644 index 9f3cb8ba23..0000000000 --- a/vm/hashtable.c +++ /dev/null @@ -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); -} diff --git a/vm/hashtable.h b/vm/hashtable.h deleted file mode 100644 index 6d9b111efe..0000000000 --- a/vm/hashtable.h +++ /dev/null @@ -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); diff --git a/vm/image.c b/vm/image.c index 849aec67c3..e9d7ed0978 100644 --- a/vm/image.c +++ b/vm/image.c @@ -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); +} diff --git a/vm/image.h b/vm/image.h index c476605f7e..f8afb8ca2f 100644 --- a/vm/image.h +++ b/vm/image.h @@ -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))); +} diff --git a/vm/layouts.h b/vm/layouts.h new file mode 100644 index 0000000000..fb9f6fd07e --- /dev/null +++ b/vm/layouts.h @@ -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< #include #include @@ -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 diff --git a/vm/math.c b/vm/math.c new file mode 100644 index 0000000000..294e0807af --- /dev/null +++ b/vm/math.c @@ -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); +} diff --git a/vm/math.h b/vm/math.h new file mode 100644 index 0000000000..4d3c3b426b --- /dev/null +++ b/vm/math.h @@ -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); diff --git a/vm/memory.c b/vm/memory.c index 59044983e2..5e94db6caf 100644 --- a/vm/memory.c +++ b/vm/memory.c @@ -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))); +} diff --git a/vm/memory.h b/vm/memory.h index 517785b65c..75ffc9e2b6 100644 --- a/vm/memory.h +++ b/vm/memory.h @@ -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)<= 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); diff --git a/vm/misc.c b/vm/misc.c deleted file mode 100644 index 33b7ef3bd7..0000000000 --- a/vm/misc.c +++ /dev/null @@ -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 diff --git a/vm/misc.h b/vm/misc.h deleted file mode 100644 index f6ebfd330d..0000000000 --- a/vm/misc.h +++ /dev/null @@ -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 diff --git a/vm/os-freebsd.h b/vm/os-freebsd.h new file mode 100644 index 0000000000..a2dafd8f9e --- /dev/null +++ b/vm/os-freebsd.h @@ -0,0 +1 @@ +#define FACTOR_OS_STRING "freebsd" diff --git a/vm/unix/run.c b/vm/os-genunix.c similarity index 61% rename from vm/unix/run.c rename to vm/os-genunix.c index a128a6568a..ac0811c605 100644 --- a/vm/unix/run.c +++ b/vm/os-genunix.c @@ -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(); +} diff --git a/vm/os-genunix.h b/vm/os-genunix.h new file mode 100644 index 0000000000..b3c9f70bbb --- /dev/null +++ b/vm/os-genunix.h @@ -0,0 +1,3 @@ +void init_signals(void); +INLINE void early_init(void) {} +const char *default_image_path(void); diff --git a/vm/os-linux.h b/vm/os-linux.h new file mode 100644 index 0000000000..7335706c97 --- /dev/null +++ b/vm/os-linux.h @@ -0,0 +1 @@ +#define FACTOR_OS_STRING "linux" diff --git a/vm/os-macosx-ppc.h b/vm/os-macosx-ppc.h new file mode 100644 index 0000000000..932b2253e3 --- /dev/null +++ b/vm/os-macosx-ppc.h @@ -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 diff --git a/vm/os-macosx-x86.h b/vm/os-macosx-x86.h new file mode 100644 index 0000000000..a0cb850fd0 --- /dev/null +++ b/vm/os-macosx-x86.h @@ -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 diff --git a/vm/os-macosx.h b/vm/os-macosx.h new file mode 100644 index 0000000000..5d771d26df --- /dev/null +++ b/vm/os-macosx.h @@ -0,0 +1,4 @@ +#define FACTOR_OS_STRING "macosx" +void init_signals(void); +void early_init(void); +const char *default_image_path(void); diff --git a/vm/macosx/run.m b/vm/os-macosx.m similarity index 91% rename from vm/macosx/run.m rename to vm/os-macosx.m index ea07fb5461..fd0a892a60 100644 --- a/vm/macosx/run.m +++ b/vm/os-macosx.m @@ -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(); +} diff --git a/vm/os-solaris.h b/vm/os-solaris.h new file mode 100644 index 0000000000..da743aee1a --- /dev/null +++ b/vm/os-solaris.h @@ -0,0 +1 @@ +#define FACTOR_OS_STRING "solaris" diff --git a/vm/os-unix.c b/vm/os-unix.c new file mode 100644 index 0000000000..736db8b218 --- /dev/null +++ b/vm/os-unix.c @@ -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); +} diff --git a/vm/os-unix.h b/vm/os-unix.h new file mode 100644 index 0000000000..2d9453bd61 --- /dev/null +++ b/vm/os-unix.h @@ -0,0 +1,31 @@ +#include +#include +#include +#include +#include +#include +#include + +#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); diff --git a/vm/os-windows.c b/vm/os-windows.c new file mode 100644 index 0000000000..d994bbb855 --- /dev/null +++ b/vm/os-windows.c @@ -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"; +} diff --git a/vm/os-windows.h b/vm/os-windows.h new file mode 100644 index 0000000000..ecb202b13a --- /dev/null +++ b/vm/os-windows.h @@ -0,0 +1,35 @@ +#include +#include + +#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) {} diff --git a/vm/platform.h b/vm/platform.h index f53c797fc8..5d125c4535 100644 --- a/vm/platform.h +++ b/vm/platform.h @@ -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 diff --git a/vm/ratio.c b/vm/ratio.c deleted file mode 100644 index 53904468b7..0000000000 --- a/vm/ratio.c +++ /dev/null @@ -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); -} diff --git a/vm/ratio.h b/vm/ratio.h deleted file mode 100644 index 1c13240351..0000000000 --- a/vm/ratio.h +++ /dev/null @@ -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); diff --git a/vm/relocate.c b/vm/relocate.c deleted file mode 100644 index 8202d7216a..0000000000 --- a/vm/relocate.c +++ /dev/null @@ -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); -} diff --git a/vm/relocate.h b/vm/relocate.h deleted file mode 100644 index 12ba97660b..0000000000 --- a/vm/relocate.h +++ /dev/null @@ -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))); -} diff --git a/vm/run.c b/vm/run.c index 0ef2e2e021..6ff8cdb800 100644 --- a/vm/run.c +++ b/vm/run.c @@ -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); +} diff --git a/vm/run.h b/vm/run.h index 4572c82961..24f9147c92 100644 --- a/vm/run.h +++ b/vm/run.h @@ -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); diff --git a/vm/s48_bignum.c b/vm/s48_bignum.c deleted file mode 100644 index 5d6126fbab..0000000000 --- a/vm/s48_bignum.c +++ /dev/null @@ -1,1909 +0,0 @@ -/* :tabSize=2:indentSize=2:noTabs=true: - -$Id: s48_bignum.c,v 1.12 2005/12/21 02:36:52 spestov Exp $ - -Copyright (c) 1989-94 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. */ - -/* Changes for Scheme 48: - * - Converted to ANSI. - * - Added bitwise operations. - * - Added s48_ to the beginning of all externally visible names. - * - Cached the bignum representations of -1, 0, and 1. - */ - -/* Changes for Factor: - * - Add s48_ prefix to file names - * - Adapt s48_bignumint.h for Factor memory manager - * - Add more bignum <-> C type conversions - */ - -#include "factor.h" -#include -#include -#include /* abort */ -#include - -/* Exports */ - -int -s48_bignum_equal_p(bignum_type x, bignum_type y) -{ - return - ((BIGNUM_ZERO_P (x)) - ? (BIGNUM_ZERO_P (y)) - : ((! (BIGNUM_ZERO_P (y))) - && ((BIGNUM_NEGATIVE_P (x)) - ? (BIGNUM_NEGATIVE_P (y)) - : (! (BIGNUM_NEGATIVE_P (y)))) - && (bignum_equal_p_unsigned (x, y)))); -} - -enum bignum_comparison -s48_bignum_test(bignum_type bignum) -{ - return - ((BIGNUM_ZERO_P (bignum)) - ? bignum_comparison_equal - : (BIGNUM_NEGATIVE_P (bignum)) - ? bignum_comparison_less - : bignum_comparison_greater); -} - -enum bignum_comparison -s48_bignum_compare(bignum_type x, bignum_type y) -{ - return - ((BIGNUM_ZERO_P (x)) - ? ((BIGNUM_ZERO_P (y)) - ? bignum_comparison_equal - : (BIGNUM_NEGATIVE_P (y)) - ? bignum_comparison_greater - : bignum_comparison_less) - : (BIGNUM_ZERO_P (y)) - ? ((BIGNUM_NEGATIVE_P (x)) - ? bignum_comparison_less - : bignum_comparison_greater) - : (BIGNUM_NEGATIVE_P (x)) - ? ((BIGNUM_NEGATIVE_P (y)) - ? (bignum_compare_unsigned (y, x)) - : (bignum_comparison_less)) - : ((BIGNUM_NEGATIVE_P (y)) - ? (bignum_comparison_greater) - : (bignum_compare_unsigned (x, y)))); -} - -bignum_type -s48_bignum_add(bignum_type x, bignum_type y) -{ - return - ((BIGNUM_ZERO_P (x)) - ? (BIGNUM_MAYBE_COPY (y)) - : (BIGNUM_ZERO_P (y)) - ? (BIGNUM_MAYBE_COPY (x)) - : ((BIGNUM_NEGATIVE_P (x)) - ? ((BIGNUM_NEGATIVE_P (y)) - ? (bignum_add_unsigned (x, y, 1)) - : (bignum_subtract_unsigned (y, x))) - : ((BIGNUM_NEGATIVE_P (y)) - ? (bignum_subtract_unsigned (x, y)) - : (bignum_add_unsigned (x, y, 0))))); -} - -bignum_type -s48_bignum_subtract(bignum_type x, bignum_type y) -{ - return - ((BIGNUM_ZERO_P (x)) - ? ((BIGNUM_ZERO_P (y)) - ? (BIGNUM_MAYBE_COPY (y)) - : (bignum_new_sign (y, (! (BIGNUM_NEGATIVE_P (y)))))) - : ((BIGNUM_ZERO_P (y)) - ? (BIGNUM_MAYBE_COPY (x)) - : ((BIGNUM_NEGATIVE_P (x)) - ? ((BIGNUM_NEGATIVE_P (y)) - ? (bignum_subtract_unsigned (y, x)) - : (bignum_add_unsigned (x, y, 1))) - : ((BIGNUM_NEGATIVE_P (y)) - ? (bignum_add_unsigned (x, y, 0)) - : (bignum_subtract_unsigned (x, y)))))); -} - -bignum_type -s48_bignum_negate(bignum_type x) -{ - return - ((BIGNUM_ZERO_P (x)) - ? (BIGNUM_MAYBE_COPY (x)) - : (bignum_new_sign (x, (! (BIGNUM_NEGATIVE_P (x)))))); -} - -bignum_type -s48_bignum_multiply(bignum_type x, bignum_type y) -{ - bignum_length_type x_length = (BIGNUM_LENGTH (x)); - bignum_length_type y_length = (BIGNUM_LENGTH (y)); - int negative_p = - ((BIGNUM_NEGATIVE_P (x)) - ? (! (BIGNUM_NEGATIVE_P (y))) - : (BIGNUM_NEGATIVE_P (y))); - if (BIGNUM_ZERO_P (x)) - return (BIGNUM_MAYBE_COPY (x)); - if (BIGNUM_ZERO_P (y)) - return (BIGNUM_MAYBE_COPY (y)); - if (x_length == 1) - { - bignum_digit_type digit = (BIGNUM_REF (x, 0)); - if (digit == 1) - return (bignum_maybe_new_sign (y, negative_p)); - if (digit < BIGNUM_RADIX_ROOT) - return (bignum_multiply_unsigned_small_factor (y, digit, negative_p)); - } - if (y_length == 1) - { - bignum_digit_type digit = (BIGNUM_REF (y, 0)); - if (digit == 1) - return (bignum_maybe_new_sign (x, negative_p)); - if (digit < BIGNUM_RADIX_ROOT) - return (bignum_multiply_unsigned_small_factor (x, digit, negative_p)); - } - return (bignum_multiply_unsigned (x, y, negative_p)); -} - -void -s48_bignum_divide(bignum_type numerator, bignum_type denominator, - bignum_type * quotient, bignum_type * remainder) -{ - if (BIGNUM_ZERO_P (denominator)) - { - raise(SIGFPE); - return; - } - if (BIGNUM_ZERO_P (numerator)) - { - (*quotient) = (BIGNUM_MAYBE_COPY (numerator)); - (*remainder) = (BIGNUM_MAYBE_COPY (numerator)); - } - else - { - int r_negative_p = (BIGNUM_NEGATIVE_P (numerator)); - int q_negative_p = - ((BIGNUM_NEGATIVE_P (denominator)) ? (! r_negative_p) : r_negative_p); - switch (bignum_compare_unsigned (numerator, denominator)) - { - case bignum_comparison_equal: - { - (*quotient) = (BIGNUM_ONE (q_negative_p)); - (*remainder) = (BIGNUM_ZERO ()); - break; - } - case bignum_comparison_less: - { - (*quotient) = (BIGNUM_ZERO ()); - (*remainder) = (BIGNUM_MAYBE_COPY (numerator)); - break; - } - case bignum_comparison_greater: - { - if ((BIGNUM_LENGTH (denominator)) == 1) - { - bignum_digit_type digit = (BIGNUM_REF (denominator, 0)); - if (digit == 1) - { - (*quotient) = - (bignum_maybe_new_sign (numerator, q_negative_p)); - (*remainder) = (BIGNUM_ZERO ()); - break; - } - else if (digit < BIGNUM_RADIX_ROOT) - { - bignum_divide_unsigned_small_denominator - (numerator, digit, - quotient, remainder, - q_negative_p, r_negative_p); - break; - } - else - { - bignum_divide_unsigned_medium_denominator - (numerator, digit, - quotient, remainder, - q_negative_p, r_negative_p); - break; - } - } - bignum_divide_unsigned_large_denominator - (numerator, denominator, - quotient, remainder, - q_negative_p, r_negative_p); - break; - } - } - } -} - -bignum_type -s48_bignum_quotient(bignum_type numerator, bignum_type denominator) -{ - if (BIGNUM_ZERO_P (denominator)) - { - raise(SIGFPE); - return (BIGNUM_OUT_OF_BAND); - } - if (BIGNUM_ZERO_P (numerator)) - return (BIGNUM_MAYBE_COPY (numerator)); - { - int q_negative_p = - ((BIGNUM_NEGATIVE_P (denominator)) - ? (! (BIGNUM_NEGATIVE_P (numerator))) - : (BIGNUM_NEGATIVE_P (numerator))); - switch (bignum_compare_unsigned (numerator, denominator)) - { - case bignum_comparison_equal: - return (BIGNUM_ONE (q_negative_p)); - case bignum_comparison_less: - return (BIGNUM_ZERO ()); - case bignum_comparison_greater: - default: /* to appease gcc -Wall */ - { - bignum_type quotient; - if ((BIGNUM_LENGTH (denominator)) == 1) - { - bignum_digit_type digit = (BIGNUM_REF (denominator, 0)); - if (digit == 1) - return (bignum_maybe_new_sign (numerator, q_negative_p)); - if (digit < BIGNUM_RADIX_ROOT) - bignum_divide_unsigned_small_denominator - (numerator, digit, - ("ient), ((bignum_type *) 0), - q_negative_p, 0); - else - bignum_divide_unsigned_medium_denominator - (numerator, digit, - ("ient), ((bignum_type *) 0), - q_negative_p, 0); - } - else - bignum_divide_unsigned_large_denominator - (numerator, denominator, - ("ient), ((bignum_type *) 0), - q_negative_p, 0); - return (quotient); - } - } - } -} - -bignum_type -s48_bignum_remainder(bignum_type numerator, bignum_type denominator) -{ - if (BIGNUM_ZERO_P (denominator)) - { - raise(SIGFPE); - return (BIGNUM_OUT_OF_BAND); - } - if (BIGNUM_ZERO_P (numerator)) - return (BIGNUM_MAYBE_COPY (numerator)); - switch (bignum_compare_unsigned (numerator, denominator)) - { - case bignum_comparison_equal: - return (BIGNUM_ZERO ()); - case bignum_comparison_less: - return (BIGNUM_MAYBE_COPY (numerator)); - case bignum_comparison_greater: - default: /* to appease gcc -Wall */ - { - bignum_type remainder; - if ((BIGNUM_LENGTH (denominator)) == 1) - { - bignum_digit_type digit = (BIGNUM_REF (denominator, 0)); - if (digit == 1) - return (BIGNUM_ZERO ()); - if (digit < BIGNUM_RADIX_ROOT) - return - (bignum_remainder_unsigned_small_denominator - (numerator, digit, (BIGNUM_NEGATIVE_P (numerator)))); - bignum_divide_unsigned_medium_denominator - (numerator, digit, - ((bignum_type *) 0), (&remainder), - 0, (BIGNUM_NEGATIVE_P (numerator))); - } - else - bignum_divide_unsigned_large_denominator - (numerator, denominator, - ((bignum_type *) 0), (&remainder), - 0, (BIGNUM_NEGATIVE_P (numerator))); - return (remainder); - } - } -} - -#define FOO_TO_BIGNUM(name,type,utype) \ - bignum_type s48_##name##_to_bignum(type n) \ - { \ - int negative_p; \ - bignum_digit_type result_digits [BIGNUM_DIGITS_FOR(type)]; \ - bignum_digit_type * end_digits = result_digits; \ - /* Special cases win when these small constants are cached. */ \ - if (n == 0) return (BIGNUM_ZERO ()); \ - if (n == 1) return (BIGNUM_ONE (0)); \ - if (n == -1) return (BIGNUM_ONE (1)); \ - { \ - utype accumulator = ((negative_p = (n < 0)) ? (-n) : n); \ - do \ - { \ - (*end_digits++) = (accumulator & BIGNUM_DIGIT_MASK); \ - accumulator >>= BIGNUM_DIGIT_LENGTH; \ - } \ - while (accumulator != 0); \ - } \ - { \ - bignum_type result = \ - (bignum_allocate ((end_digits - result_digits), negative_p)); \ - bignum_digit_type * scan_digits = result_digits; \ - bignum_digit_type * scan_result = (BIGNUM_START_PTR (result)); \ - while (scan_digits < end_digits) \ - (*scan_result++) = (*scan_digits++); \ - return (result); \ - } \ - } - -FOO_TO_BIGNUM(cell,CELL,CELL) -FOO_TO_BIGNUM(fixnum,F_FIXNUM,CELL) -FOO_TO_BIGNUM(long,long,unsigned long) -FOO_TO_BIGNUM(ulong,unsigned long,unsigned long) -FOO_TO_BIGNUM(long_long,s64,u64) -FOO_TO_BIGNUM(ulong_long,u64,u64) - -/* this is inefficient; its only used for fixnum multiplication overflow so -it probaly does not matter */ -bignum_type s48_fixnum_pair_to_bignum(CELL x, F_FIXNUM y) -{ - return s48_bignum_add( - s48_bignum_arithmetic_shift( - s48_fixnum_to_bignum(y), - sizeof(unsigned long) * 8), - s48_cell_to_bignum(x)); -} - -#define BIGNUM_TO_FOO(name,type,utype) \ - type s48_bignum_to_##name(bignum_type bignum) \ - { \ - if (BIGNUM_ZERO_P (bignum)) \ - return (0); \ - { \ - utype accumulator = 0; \ - bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); \ - bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); \ - while (start < scan) \ - accumulator = ((accumulator << BIGNUM_DIGIT_LENGTH) + (*--scan)); \ - return ((BIGNUM_NEGATIVE_P (bignum)) ? (-((type)accumulator)) : accumulator); \ - } \ - } - -BIGNUM_TO_FOO(cell,CELL,CELL); -BIGNUM_TO_FOO(fixnum,F_FIXNUM,CELL); -BIGNUM_TO_FOO(long,long,unsigned long) -BIGNUM_TO_FOO(ulong,unsigned long,unsigned long) -BIGNUM_TO_FOO(long_long,s64,u64) -BIGNUM_TO_FOO(ulong_long,u64,u64) - -double -s48_bignum_to_double(bignum_type bignum) -{ - if (BIGNUM_ZERO_P (bignum)) - return (0); - { - double accumulator = 0; - bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); - bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); - while (start < scan) - accumulator = ((accumulator * BIGNUM_RADIX) + (*--scan)); - return ((BIGNUM_NEGATIVE_P (bignum)) ? (-accumulator) : accumulator); - } -} - -#define DTB_WRITE_DIGIT(factor) \ -{ \ - significand *= (factor); \ - digit = ((bignum_digit_type) significand); \ - (*--scan) = digit; \ - significand -= ((double) digit); \ -} - -bignum_type -s48_double_to_bignum(double x) -{ - int exponent; - double significand = (frexp (x, (&exponent))); - if (exponent <= 0) return (BIGNUM_ZERO ()); - if (exponent == 1) return (BIGNUM_ONE (x < 0)); - if (significand < 0) significand = (-significand); - { - bignum_length_type length = (BIGNUM_BITS_TO_DIGITS (exponent)); - bignum_type result = (bignum_allocate (length, (x < 0))); - bignum_digit_type * start = (BIGNUM_START_PTR (result)); - bignum_digit_type * scan = (start + length); - bignum_digit_type digit; - int odd_bits = (exponent % BIGNUM_DIGIT_LENGTH); - if (odd_bits > 0) - DTB_WRITE_DIGIT (1L << odd_bits); - while (start < scan) - { - if (significand == 0) - { - while (start < scan) - (*--scan) = 0; - break; - } - DTB_WRITE_DIGIT (BIGNUM_RADIX); - } - return (result); - } -} - -#undef DTB_WRITE_DIGIT - -int -s48_bignum_fits_in_word_p(bignum_type bignum, long word_length, - int twos_complement_p) -{ - unsigned int n_bits = (twos_complement_p ? (word_length - 1) : word_length); - BIGNUM_ASSERT (n_bits > 0); - { - bignum_length_type length = (BIGNUM_LENGTH (bignum)); - bignum_length_type max_digits = (BIGNUM_BITS_TO_DIGITS (n_bits)); - bignum_digit_type msd, max; - return - ((length < max_digits) || - ((length == max_digits) && - ((((msd = (BIGNUM_REF (bignum, (length - 1)))) < - (max = (1L << (n_bits - ((length - 1) * BIGNUM_DIGIT_LENGTH))))) || - (twos_complement_p && - (msd == max) && - (BIGNUM_NEGATIVE_P (bignum))))))); - } -} - -bignum_type -s48_bignum_length_in_bits(bignum_type bignum) -{ - if (BIGNUM_ZERO_P (bignum)) - return (BIGNUM_ZERO ()); - { - bignum_length_type index = ((BIGNUM_LENGTH (bignum)) - 1); - bignum_digit_type digit = (BIGNUM_REF (bignum, index)); - bignum_type result = (bignum_allocate (2, 0)); - (BIGNUM_REF (result, 0)) = index; - (BIGNUM_REF (result, 1)) = 0; - bignum_destructive_scale_up (result, BIGNUM_DIGIT_LENGTH); - while (digit > 0) - { - bignum_destructive_add (result, ((bignum_digit_type) 1)); - digit >>= 1; - } - return (bignum_trim (result)); - } -} - -bignum_type -s48_bignum_length_upper_limit(void) -{ - bignum_type result = (bignum_allocate (2, 0)); - (BIGNUM_REF (result, 0)) = 0; - (BIGNUM_REF (result, 1)) = BIGNUM_DIGIT_LENGTH; - return (result); -} - -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) -{ - BIGNUM_ASSERT ((radix > 1) && (radix <= BIGNUM_RADIX_ROOT)); - if (n_digits == 0) - return (BIGNUM_ZERO ()); - if (n_digits == 1) - { - long digit = ((long) ((*producer) (context))); - return (s48_long_to_bignum (negative_p ? (- digit) : digit)); - } - { - bignum_length_type length; - { - unsigned int radix_copy = radix; - unsigned int log_radix = 0; - while (radix_copy > 0) - { - radix_copy >>= 1; - log_radix += 1; - } - /* This length will be at least as large as needed. */ - length = (BIGNUM_BITS_TO_DIGITS (n_digits * log_radix)); - } - { - bignum_type result = (bignum_allocate_zeroed (length, negative_p)); - while ((n_digits--) > 0) - { - bignum_destructive_scale_up (result, ((bignum_digit_type) radix)); - bignum_destructive_add - (result, ((bignum_digit_type) ((*producer) (context)))); - } - return (bignum_trim (result)); - } - } -} - -long -s48_bignum_max_digit_stream_radix(void) -{ - return (BIGNUM_RADIX_ROOT); -} - -/* Comparisons */ - -int -bignum_equal_p_unsigned(bignum_type x, bignum_type y) -{ - bignum_length_type length = (BIGNUM_LENGTH (x)); - if (length != (BIGNUM_LENGTH (y))) - return (0); - else - { - bignum_digit_type * scan_x = (BIGNUM_START_PTR (x)); - bignum_digit_type * scan_y = (BIGNUM_START_PTR (y)); - bignum_digit_type * end_x = (scan_x + length); - while (scan_x < end_x) - if ((*scan_x++) != (*scan_y++)) - return (0); - return (1); - } -} - -enum bignum_comparison -bignum_compare_unsigned(bignum_type x, bignum_type y) -{ - bignum_length_type x_length = (BIGNUM_LENGTH (x)); - bignum_length_type y_length = (BIGNUM_LENGTH (y)); - if (x_length < y_length) - return (bignum_comparison_less); - if (x_length > y_length) - return (bignum_comparison_greater); - { - bignum_digit_type * start_x = (BIGNUM_START_PTR (x)); - bignum_digit_type * scan_x = (start_x + x_length); - bignum_digit_type * scan_y = ((BIGNUM_START_PTR (y)) + y_length); - while (start_x < scan_x) - { - bignum_digit_type digit_x = (*--scan_x); - bignum_digit_type digit_y = (*--scan_y); - if (digit_x < digit_y) - return (bignum_comparison_less); - if (digit_x > digit_y) - return (bignum_comparison_greater); - } - } - return (bignum_comparison_equal); -} - -/* Addition */ - -bignum_type -bignum_add_unsigned(bignum_type x, bignum_type y, int negative_p) -{ - if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x))) - { - bignum_type z = x; - x = y; - y = z; - } - { - bignum_length_type x_length = (BIGNUM_LENGTH (x)); - bignum_type r = (bignum_allocate ((x_length + 1), negative_p)); - bignum_digit_type sum; - bignum_digit_type carry = 0; - bignum_digit_type * scan_x = (BIGNUM_START_PTR (x)); - bignum_digit_type * scan_r = (BIGNUM_START_PTR (r)); - { - bignum_digit_type * scan_y = (BIGNUM_START_PTR (y)); - bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y))); - while (scan_y < end_y) - { - sum = ((*scan_x++) + (*scan_y++) + carry); - if (sum < BIGNUM_RADIX) - { - (*scan_r++) = sum; - carry = 0; - } - else - { - (*scan_r++) = (sum - BIGNUM_RADIX); - carry = 1; - } - } - } - { - bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length); - if (carry != 0) - while (scan_x < end_x) - { - sum = ((*scan_x++) + 1); - if (sum < BIGNUM_RADIX) - { - (*scan_r++) = sum; - carry = 0; - break; - } - else - (*scan_r++) = (sum - BIGNUM_RADIX); - } - while (scan_x < end_x) - (*scan_r++) = (*scan_x++); - } - if (carry != 0) - { - (*scan_r) = 1; - return (r); - } - return (bignum_shorten_length (r, x_length)); - } -} - -/* Subtraction */ - -bignum_type -bignum_subtract_unsigned(bignum_type x, bignum_type y) -{ - int negative_p; - switch (bignum_compare_unsigned (x, y)) - { - case bignum_comparison_equal: - return (BIGNUM_ZERO ()); - case bignum_comparison_less: - { - bignum_type z = x; - x = y; - y = z; - } - negative_p = 1; - break; - case bignum_comparison_greater: - negative_p = 0; - break; - } - { - bignum_length_type x_length = (BIGNUM_LENGTH (x)); - bignum_type r = (bignum_allocate (x_length, negative_p)); - bignum_digit_type difference; - bignum_digit_type borrow = 0; - bignum_digit_type * scan_x = (BIGNUM_START_PTR (x)); - bignum_digit_type * scan_r = (BIGNUM_START_PTR (r)); - { - bignum_digit_type * scan_y = (BIGNUM_START_PTR (y)); - bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y))); - while (scan_y < end_y) - { - difference = (((*scan_x++) - (*scan_y++)) - borrow); - if (difference < 0) - { - (*scan_r++) = (difference + BIGNUM_RADIX); - borrow = 1; - } - else - { - (*scan_r++) = difference; - borrow = 0; - } - } - } - { - bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length); - if (borrow != 0) - while (scan_x < end_x) - { - difference = ((*scan_x++) - borrow); - if (difference < 0) - (*scan_r++) = (difference + BIGNUM_RADIX); - else - { - (*scan_r++) = difference; - borrow = 0; - break; - } - } - BIGNUM_ASSERT (borrow == 0); - while (scan_x < end_x) - (*scan_r++) = (*scan_x++); - } - return (bignum_trim (r)); - } -} - -/* Multiplication - Maximum value for product_low or product_high: - ((R * R) + (R * (R - 2)) + (R - 1)) - Maximum value for carry: ((R * (R - 1)) + (R - 1)) - where R == BIGNUM_RADIX_ROOT */ - -bignum_type -bignum_multiply_unsigned(bignum_type x, bignum_type y, int negative_p) -{ - if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x))) - { - bignum_type z = x; - x = y; - y = z; - } - { - bignum_digit_type carry; - bignum_digit_type y_digit_low; - bignum_digit_type y_digit_high; - bignum_digit_type x_digit_low; - bignum_digit_type x_digit_high; - bignum_digit_type product_low; - bignum_digit_type * scan_r; - bignum_digit_type * scan_y; - bignum_length_type x_length = (BIGNUM_LENGTH (x)); - bignum_length_type y_length = (BIGNUM_LENGTH (y)); - bignum_type r = - (bignum_allocate_zeroed ((x_length + y_length), negative_p)); - bignum_digit_type * scan_x = (BIGNUM_START_PTR (x)); - bignum_digit_type * end_x = (scan_x + x_length); - bignum_digit_type * start_y = (BIGNUM_START_PTR (y)); - bignum_digit_type * end_y = (start_y + y_length); - bignum_digit_type * start_r = (BIGNUM_START_PTR (r)); -#define x_digit x_digit_high -#define y_digit y_digit_high -#define product_high carry - while (scan_x < end_x) - { - x_digit = (*scan_x++); - x_digit_low = (HD_LOW (x_digit)); - x_digit_high = (HD_HIGH (x_digit)); - carry = 0; - scan_y = start_y; - scan_r = (start_r++); - while (scan_y < end_y) - { - y_digit = (*scan_y++); - y_digit_low = (HD_LOW (y_digit)); - y_digit_high = (HD_HIGH (y_digit)); - product_low = - ((*scan_r) + - (x_digit_low * y_digit_low) + - (HD_LOW (carry))); - product_high = - ((x_digit_high * y_digit_low) + - (x_digit_low * y_digit_high) + - (HD_HIGH (product_low)) + - (HD_HIGH (carry))); - (*scan_r++) = - (HD_CONS ((HD_LOW (product_high)), (HD_LOW (product_low)))); - carry = - ((x_digit_high * y_digit_high) + - (HD_HIGH (product_high))); - } - (*scan_r) += carry; - } - return (bignum_trim (r)); -#undef x_digit -#undef y_digit -#undef product_high - } -} - -bignum_type -bignum_multiply_unsigned_small_factor(bignum_type x, bignum_digit_type y, - int negative_p) -{ - bignum_length_type length_x = (BIGNUM_LENGTH (x)); - bignum_type p = (bignum_allocate ((length_x + 1), negative_p)); - bignum_destructive_copy (x, p); - (BIGNUM_REF (p, length_x)) = 0; - bignum_destructive_scale_up (p, y); - return (bignum_trim (p)); -} - -void -bignum_destructive_scale_up(bignum_type bignum, bignum_digit_type factor) -{ - bignum_digit_type carry = 0; - bignum_digit_type * scan = (BIGNUM_START_PTR (bignum)); - bignum_digit_type two_digits; - bignum_digit_type product_low; -#define product_high carry - bignum_digit_type * end = (scan + (BIGNUM_LENGTH (bignum))); - BIGNUM_ASSERT ((factor > 1) && (factor < BIGNUM_RADIX_ROOT)); - while (scan < end) - { - two_digits = (*scan); - product_low = ((factor * (HD_LOW (two_digits))) + (HD_LOW (carry))); - product_high = - ((factor * (HD_HIGH (two_digits))) + - (HD_HIGH (product_low)) + - (HD_HIGH (carry))); - (*scan++) = (HD_CONS ((HD_LOW (product_high)), (HD_LOW (product_low)))); - carry = (HD_HIGH (product_high)); - } - /* A carry here would be an overflow, i.e. it would not fit. - Hopefully the callers allocate enough space that this will - never happen. - */ - BIGNUM_ASSERT (carry == 0); - return; -#undef product_high -} - -void -bignum_destructive_add(bignum_type bignum, bignum_digit_type n) -{ - bignum_digit_type * scan = (BIGNUM_START_PTR (bignum)); - bignum_digit_type digit; - digit = ((*scan) + n); - if (digit < BIGNUM_RADIX) - { - (*scan) = digit; - return; - } - (*scan++) = (digit - BIGNUM_RADIX); - while (1) - { - digit = ((*scan) + 1); - if (digit < BIGNUM_RADIX) - { - (*scan) = digit; - return; - } - (*scan++) = (digit - BIGNUM_RADIX); - } -} - -/* Division */ - -/* For help understanding this algorithm, see: - Knuth, Donald E., "The Art of Computer Programming", - volume 2, "Seminumerical Algorithms" - section 4.3.1, "Multiple-Precision Arithmetic". */ - -void -bignum_divide_unsigned_large_denominator(bignum_type numerator, - bignum_type denominator, - bignum_type * quotient, - bignum_type * remainder, - int q_negative_p, - int r_negative_p) -{ - bignum_length_type length_n = ((BIGNUM_LENGTH (numerator)) + 1); - bignum_length_type length_d = (BIGNUM_LENGTH (denominator)); - bignum_type q = - ((quotient != ((bignum_type *) 0)) - ? (bignum_allocate ((length_n - length_d), q_negative_p)) - : BIGNUM_OUT_OF_BAND); - bignum_type u = (bignum_allocate (length_n, r_negative_p)); - int shift = 0; - BIGNUM_ASSERT (length_d > 1); - { - bignum_digit_type v1 = (BIGNUM_REF ((denominator), (length_d - 1))); - while (v1 < (BIGNUM_RADIX / 2)) - { - v1 <<= 1; - shift += 1; - } - } - if (shift == 0) - { - bignum_destructive_copy (numerator, u); - (BIGNUM_REF (u, (length_n - 1))) = 0; - bignum_divide_unsigned_normalized (u, denominator, q); - } - else - { - bignum_type v = (bignum_allocate (length_d, 0)); - bignum_destructive_normalization (numerator, u, shift); - bignum_destructive_normalization (denominator, v, shift); - bignum_divide_unsigned_normalized (u, v, q); - BIGNUM_DEALLOCATE (v); - if (remainder != ((bignum_type *) 0)) - bignum_destructive_unnormalization (u, shift); - } - if (quotient != ((bignum_type *) 0)) - (*quotient) = (bignum_trim (q)); - if (remainder != ((bignum_type *) 0)) - (*remainder) = (bignum_trim (u)); - else - BIGNUM_DEALLOCATE (u); - return; -} - -void -bignum_divide_unsigned_normalized(bignum_type u, bignum_type v, bignum_type q) -{ - bignum_length_type u_length = (BIGNUM_LENGTH (u)); - bignum_length_type v_length = (BIGNUM_LENGTH (v)); - bignum_digit_type * u_start = (BIGNUM_START_PTR (u)); - bignum_digit_type * u_scan = (u_start + u_length); - bignum_digit_type * u_scan_limit = (u_start + v_length); - bignum_digit_type * u_scan_start = (u_scan - v_length); - bignum_digit_type * v_start = (BIGNUM_START_PTR (v)); - bignum_digit_type * v_end = (v_start + v_length); - bignum_digit_type * q_scan = NULL; - bignum_digit_type v1 = (v_end[-1]); - bignum_digit_type v2 = (v_end[-2]); - bignum_digit_type ph; /* high half of double-digit product */ - bignum_digit_type pl; /* low half of double-digit product */ - bignum_digit_type guess; - bignum_digit_type gh; /* high half-digit of guess */ - bignum_digit_type ch; /* high half of double-digit comparand */ - bignum_digit_type v2l = (HD_LOW (v2)); - bignum_digit_type v2h = (HD_HIGH (v2)); - bignum_digit_type cl; /* low half of double-digit comparand */ -#define gl ph /* low half-digit of guess */ -#define uj pl -#define qj ph - bignum_digit_type gm; /* memory loc for reference parameter */ - if (q != BIGNUM_OUT_OF_BAND) - q_scan = ((BIGNUM_START_PTR (q)) + (BIGNUM_LENGTH (q))); - while (u_scan_limit < u_scan) - { - uj = (*--u_scan); - if (uj != v1) - { - /* comparand = - (((((uj * BIGNUM_RADIX) + uj1) % v1) * BIGNUM_RADIX) + uj2); - guess = (((uj * BIGNUM_RADIX) + uj1) / v1); */ - cl = (u_scan[-2]); - ch = (bignum_digit_divide (uj, (u_scan[-1]), v1, (&gm))); - guess = gm; - } - else - { - cl = (u_scan[-2]); - ch = ((u_scan[-1]) + v1); - guess = (BIGNUM_RADIX - 1); - } - while (1) - { - /* product = (guess * v2); */ - gl = (HD_LOW (guess)); - gh = (HD_HIGH (guess)); - pl = (v2l * gl); - ph = ((v2l * gh) + (v2h * gl) + (HD_HIGH (pl))); - pl = (HD_CONS ((HD_LOW (ph)), (HD_LOW (pl)))); - ph = ((v2h * gh) + (HD_HIGH (ph))); - /* if (comparand >= product) */ - if ((ch > ph) || ((ch == ph) && (cl >= pl))) - break; - guess -= 1; - /* comparand += (v1 << BIGNUM_DIGIT_LENGTH) */ - ch += v1; - /* if (comparand >= (BIGNUM_RADIX * BIGNUM_RADIX)) */ - if (ch >= BIGNUM_RADIX) - break; - } - qj = (bignum_divide_subtract (v_start, v_end, guess, (--u_scan_start))); - if (q != BIGNUM_OUT_OF_BAND) - (*--q_scan) = qj; - } - return; -#undef gl -#undef uj -#undef qj -} - -bignum_digit_type -bignum_divide_subtract(bignum_digit_type * v_start, - bignum_digit_type * v_end, - bignum_digit_type guess, - bignum_digit_type * u_start) -{ - bignum_digit_type * v_scan = v_start; - bignum_digit_type * u_scan = u_start; - bignum_digit_type carry = 0; - if (guess == 0) return (0); - { - bignum_digit_type gl = (HD_LOW (guess)); - bignum_digit_type gh = (HD_HIGH (guess)); - bignum_digit_type v; - bignum_digit_type pl; - bignum_digit_type vl; -#define vh v -#define ph carry -#define diff pl - while (v_scan < v_end) - { - v = (*v_scan++); - vl = (HD_LOW (v)); - vh = (HD_HIGH (v)); - pl = ((vl * gl) + (HD_LOW (carry))); - ph = ((vl * gh) + (vh * gl) + (HD_HIGH (pl)) + (HD_HIGH (carry))); - diff = ((*u_scan) - (HD_CONS ((HD_LOW (ph)), (HD_LOW (pl))))); - if (diff < 0) - { - (*u_scan++) = (diff + BIGNUM_RADIX); - carry = ((vh * gh) + (HD_HIGH (ph)) + 1); - } - else - { - (*u_scan++) = diff; - carry = ((vh * gh) + (HD_HIGH (ph))); - } - } - if (carry == 0) - return (guess); - diff = ((*u_scan) - carry); - if (diff < 0) - (*u_scan) = (diff + BIGNUM_RADIX); - else - { - (*u_scan) = diff; - return (guess); - } -#undef vh -#undef ph -#undef diff - } - /* Subtraction generated carry, implying guess is one too large. - Add v back in to bring it back down. */ - v_scan = v_start; - u_scan = u_start; - carry = 0; - while (v_scan < v_end) - { - bignum_digit_type sum = ((*v_scan++) + (*u_scan) + carry); - if (sum < BIGNUM_RADIX) - { - (*u_scan++) = sum; - carry = 0; - } - else - { - (*u_scan++) = (sum - BIGNUM_RADIX); - carry = 1; - } - } - if (carry == 1) - { - bignum_digit_type sum = ((*u_scan) + carry); - (*u_scan) = ((sum < BIGNUM_RADIX) ? sum : (sum - BIGNUM_RADIX)); - } - return (guess - 1); -} - -void -bignum_divide_unsigned_medium_denominator(bignum_type numerator, - bignum_digit_type denominator, - bignum_type * quotient, - bignum_type * remainder, - int q_negative_p, - int r_negative_p) -{ - bignum_length_type length_n = (BIGNUM_LENGTH (numerator)); - bignum_length_type length_q; - bignum_type q; - int shift = 0; - /* Because `bignum_digit_divide' requires a normalized denominator. */ - while (denominator < (BIGNUM_RADIX / 2)) - { - denominator <<= 1; - shift += 1; - } - if (shift == 0) - { - length_q = length_n; - q = (bignum_allocate (length_q, q_negative_p)); - bignum_destructive_copy (numerator, q); - } - else - { - length_q = (length_n + 1); - q = (bignum_allocate (length_q, q_negative_p)); - bignum_destructive_normalization (numerator, q, shift); - } - { - bignum_digit_type r = 0; - bignum_digit_type * start = (BIGNUM_START_PTR (q)); - bignum_digit_type * scan = (start + length_q); - bignum_digit_type qj; - if (quotient != ((bignum_type *) 0)) - { - while (start < scan) - { - r = (bignum_digit_divide (r, (*--scan), denominator, (&qj))); - (*scan) = qj; - } - (*quotient) = (bignum_trim (q)); - } - else - { - while (start < scan) - r = (bignum_digit_divide (r, (*--scan), denominator, (&qj))); - BIGNUM_DEALLOCATE (q); - } - if (remainder != ((bignum_type *) 0)) - { - if (shift != 0) - r >>= shift; - (*remainder) = (bignum_digit_to_bignum (r, r_negative_p)); - } - } - return; -} - -void -bignum_destructive_normalization(bignum_type source, bignum_type target, - int shift_left) -{ - bignum_digit_type digit; - bignum_digit_type * scan_source = (BIGNUM_START_PTR (source)); - bignum_digit_type carry = 0; - bignum_digit_type * scan_target = (BIGNUM_START_PTR (target)); - bignum_digit_type * end_source = (scan_source + (BIGNUM_LENGTH (source))); - bignum_digit_type * end_target = (scan_target + (BIGNUM_LENGTH (target))); - int shift_right = (BIGNUM_DIGIT_LENGTH - shift_left); - bignum_digit_type mask = ((1L << shift_right) - 1); - while (scan_source < end_source) - { - digit = (*scan_source++); - (*scan_target++) = (((digit & mask) << shift_left) | carry); - carry = (digit >> shift_right); - } - if (scan_target < end_target) - (*scan_target) = carry; - else - BIGNUM_ASSERT (carry == 0); - return; -} - -void -bignum_destructive_unnormalization(bignum_type bignum, int shift_right) -{ - bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); - bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); - bignum_digit_type digit; - bignum_digit_type carry = 0; - int shift_left = (BIGNUM_DIGIT_LENGTH - shift_right); - bignum_digit_type mask = ((1L << shift_right) - 1); - while (start < scan) - { - digit = (*--scan); - (*scan) = ((digit >> shift_right) | carry); - carry = ((digit & mask) << shift_left); - } - BIGNUM_ASSERT (carry == 0); - return; -} - -/* This is a reduced version of the division algorithm, applied to the - case of dividing two bignum digits by one bignum digit. It is - assumed that the numerator, denominator are normalized. */ - -#define BDD_STEP(qn, j) \ -{ \ - uj = (u[j]); \ - if (uj != v1) \ - { \ - uj_uj1 = (HD_CONS (uj, (u[j + 1]))); \ - guess = (uj_uj1 / v1); \ - comparand = (HD_CONS ((uj_uj1 % v1), (u[j + 2]))); \ - } \ - else \ - { \ - guess = (BIGNUM_RADIX_ROOT - 1); \ - comparand = (HD_CONS (((u[j + 1]) + v1), (u[j + 2]))); \ - } \ - while ((guess * v2) > comparand) \ - { \ - guess -= 1; \ - comparand += (v1 << BIGNUM_HALF_DIGIT_LENGTH); \ - if (comparand >= BIGNUM_RADIX) \ - break; \ - } \ - qn = (bignum_digit_divide_subtract (v1, v2, guess, (&u[j]))); \ -} - -bignum_digit_type -bignum_digit_divide(bignum_digit_type uh, bignum_digit_type ul, - bignum_digit_type v, - bignum_digit_type * q) /* return value */ -{ - bignum_digit_type guess; - bignum_digit_type comparand; - bignum_digit_type v1 = (HD_HIGH (v)); - bignum_digit_type v2 = (HD_LOW (v)); - bignum_digit_type uj; - bignum_digit_type uj_uj1; - bignum_digit_type q1; - bignum_digit_type q2; - bignum_digit_type u [4]; - if (uh == 0) - { - if (ul < v) - { - (*q) = 0; - return (ul); - } - else if (ul == v) - { - (*q) = 1; - return (0); - } - } - (u[0]) = (HD_HIGH (uh)); - (u[1]) = (HD_LOW (uh)); - (u[2]) = (HD_HIGH (ul)); - (u[3]) = (HD_LOW (ul)); - v1 = (HD_HIGH (v)); - v2 = (HD_LOW (v)); - BDD_STEP (q1, 0); - BDD_STEP (q2, 1); - (*q) = (HD_CONS (q1, q2)); - return (HD_CONS ((u[2]), (u[3]))); -} - -#undef BDD_STEP - -#define BDDS_MULSUB(vn, un, carry_in) \ -{ \ - product = ((vn * guess) + carry_in); \ - diff = (un - (HD_LOW (product))); \ - if (diff < 0) \ - { \ - un = (diff + BIGNUM_RADIX_ROOT); \ - carry = ((HD_HIGH (product)) + 1); \ - } \ - else \ - { \ - un = diff; \ - carry = (HD_HIGH (product)); \ - } \ -} - -#define BDDS_ADD(vn, un, carry_in) \ -{ \ - sum = (vn + un + carry_in); \ - if (sum < BIGNUM_RADIX_ROOT) \ - { \ - un = sum; \ - carry = 0; \ - } \ - else \ - { \ - un = (sum - BIGNUM_RADIX_ROOT); \ - carry = 1; \ - } \ -} - -bignum_digit_type -bignum_digit_divide_subtract(bignum_digit_type v1, bignum_digit_type v2, - bignum_digit_type guess, bignum_digit_type * u) -{ - { - bignum_digit_type product; - bignum_digit_type diff; - bignum_digit_type carry; - BDDS_MULSUB (v2, (u[2]), 0); - BDDS_MULSUB (v1, (u[1]), carry); - if (carry == 0) - return (guess); - diff = ((u[0]) - carry); - if (diff < 0) - (u[0]) = (diff + BIGNUM_RADIX); - else - { - (u[0]) = diff; - return (guess); - } - } - { - bignum_digit_type sum; - bignum_digit_type carry; - BDDS_ADD(v2, (u[2]), 0); - BDDS_ADD(v1, (u[1]), carry); - if (carry == 1) - (u[0]) += 1; - } - return (guess - 1); -} - -#undef BDDS_MULSUB -#undef BDDS_ADD - -void -bignum_divide_unsigned_small_denominator(bignum_type numerator, - bignum_digit_type denominator, - bignum_type * quotient, - bignum_type * remainder, - int q_negative_p, - int r_negative_p) -{ - bignum_type q = (bignum_new_sign (numerator, q_negative_p)); - bignum_digit_type r = (bignum_destructive_scale_down (q, denominator)); - (*quotient) = (bignum_trim (q)); - if (remainder != ((bignum_type *) 0)) - (*remainder) = (bignum_digit_to_bignum (r, r_negative_p)); - return; -} - -/* Given (denominator > 1), it is fairly easy to show that - (quotient_high < BIGNUM_RADIX_ROOT), after which it is easy to see - that all digits are < BIGNUM_RADIX. */ - -bignum_digit_type -bignum_destructive_scale_down(bignum_type bignum, bignum_digit_type denominator) -{ - bignum_digit_type numerator; - bignum_digit_type remainder = 0; - bignum_digit_type two_digits; -#define quotient_high remainder - bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); - bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); - BIGNUM_ASSERT ((denominator > 1) && (denominator < BIGNUM_RADIX_ROOT)); - while (start < scan) - { - two_digits = (*--scan); - numerator = (HD_CONS (remainder, (HD_HIGH (two_digits)))); - quotient_high = (numerator / denominator); - numerator = (HD_CONS ((numerator % denominator), (HD_LOW (two_digits)))); - (*scan) = (HD_CONS (quotient_high, (numerator / denominator))); - remainder = (numerator % denominator); - } - return (remainder); -#undef quotient_high -} - -bignum_type -bignum_remainder_unsigned_small_denominator( - bignum_type n, bignum_digit_type d, int negative_p) -{ - bignum_digit_type two_digits; - bignum_digit_type * start = (BIGNUM_START_PTR (n)); - bignum_digit_type * scan = (start + (BIGNUM_LENGTH (n))); - bignum_digit_type r = 0; - BIGNUM_ASSERT ((d > 1) && (d < BIGNUM_RADIX_ROOT)); - while (start < scan) - { - two_digits = (*--scan); - r = - ((HD_CONS (((HD_CONS (r, (HD_HIGH (two_digits)))) % d), - (HD_LOW (two_digits)))) - % d); - } - return (bignum_digit_to_bignum (r, negative_p)); -} - -bignum_type -bignum_digit_to_bignum(bignum_digit_type digit, int negative_p) -{ - if (digit == 0) - return (BIGNUM_ZERO ()); - else - { - bignum_type result = (bignum_allocate (1, negative_p)); - (BIGNUM_REF (result, 0)) = digit; - return (result); - } -} - -/* Allocation */ - -bignum_type -bignum_allocate(bignum_length_type length, int negative_p) -{ - BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX)); - { - bignum_type result = (BIGNUM_ALLOCATE (length)); - BIGNUM_SET_NEGATIVE_P (result, negative_p); - return (result); - } -} - -bignum_type -bignum_allocate_zeroed(bignum_length_type length, int negative_p) -{ - BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX)); - { - bignum_type result = (BIGNUM_ALLOCATE (length)); - bignum_digit_type * scan = (BIGNUM_START_PTR (result)); - bignum_digit_type * end = (scan + length); - BIGNUM_SET_NEGATIVE_P (result, negative_p); - while (scan < end) - (*scan++) = 0; - return (result); - } -} - -bignum_type -bignum_shorten_length(bignum_type bignum, bignum_length_type length) -{ - bignum_length_type current_length = (BIGNUM_LENGTH (bignum)); - BIGNUM_ASSERT ((length >= 0) || (length <= current_length)); - if (length < current_length) - { - BIGNUM_REDUCE_LENGTH (bignum, bignum, length); - BIGNUM_SET_NEGATIVE_P (bignum, (length != 0) && (BIGNUM_NEGATIVE_P (bignum))); - } - return (bignum); -} - -bignum_type -bignum_trim(bignum_type bignum) -{ - bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); - bignum_digit_type * end = (start + (BIGNUM_LENGTH (bignum))); - bignum_digit_type * scan = end; - while ((start <= scan) && ((*--scan) == 0)) - ; - scan += 1; - if (scan < end) - { - bignum_length_type length = (scan - start); - BIGNUM_REDUCE_LENGTH (bignum, bignum, length); - BIGNUM_SET_NEGATIVE_P (bignum, (length != 0) && (BIGNUM_NEGATIVE_P (bignum))); - } - return (bignum); -} - -/* Copying */ - -bignum_type -bignum_copy(bignum_type source) -{ - bignum_type target = - (bignum_allocate ((BIGNUM_LENGTH (source)), (BIGNUM_NEGATIVE_P (source)))); - bignum_destructive_copy (source, target); - return (target); -} - -bignum_type -bignum_new_sign(bignum_type bignum, int negative_p) -{ - bignum_type result = - (bignum_allocate ((BIGNUM_LENGTH (bignum)), negative_p)); - bignum_destructive_copy (bignum, result); - return (result); -} - -bignum_type -bignum_maybe_new_sign(bignum_type bignum, int negative_p) -{ -#ifndef BIGNUM_FORCE_NEW_RESULTS - if ((BIGNUM_NEGATIVE_P (bignum)) ? negative_p : (! negative_p)) - return (bignum); - else -#endif /* not BIGNUM_FORCE_NEW_RESULTS */ - { - bignum_type result = - (bignum_allocate ((BIGNUM_LENGTH (bignum)), negative_p)); - bignum_destructive_copy (bignum, result); - return (result); - } -} - -void -bignum_destructive_copy(bignum_type source, bignum_type target) -{ - bignum_digit_type * scan_source = (BIGNUM_START_PTR (source)); - bignum_digit_type * end_source = - (scan_source + (BIGNUM_LENGTH (source))); - bignum_digit_type * scan_target = (BIGNUM_START_PTR (target)); - while (scan_source < end_source) - (*scan_target++) = (*scan_source++); - return; -} - -/* Unused -void -bignum_destructive_zero(bignum_type bignum) -{ - bignum_digit_type * scan = (BIGNUM_START_PTR (bignum)); - bignum_digit_type * end = (scan + (BIGNUM_LENGTH (bignum))); - while (scan < end) - (*scan++) = 0; - return; -} -*/ - -/* - * Added bitwise operations (and oddp). - */ - -int -s48_bignum_oddp (bignum_type bignum) -{ - return (BIGNUM_LENGTH (bignum) > 0) && (BIGNUM_REF (bignum, 0) & 1); -} - -bignum_type -s48_bignum_bitwise_not(bignum_type x) -{ - return s48_bignum_subtract(BIGNUM_ONE(1), x); -} - -bignum_type -s48_bignum_arithmetic_shift(bignum_type arg1, long n) -{ - if (BIGNUM_NEGATIVE_P(arg1) && n < 0) - return - s48_bignum_bitwise_not(bignum_magnitude_ash(s48_bignum_bitwise_not(arg1), - n)); - else - return bignum_magnitude_ash(arg1, n); -} - -/* - * This uses a `long'-returning bignum_length_in_bits() which we don't have. -long -s48_bignum_integer_length(bignum_type arg1) -{ - return((BIGNUM_NEGATIVE_P (arg1)) - ? bignum_length_in_bits (s48_bignum_bitwise_not (arg1)) - : bignum_length_in_bits (arg1)); -} -*/ - -long -s48_bignum_bit_count(bignum_type arg1) -{ - return((BIGNUM_NEGATIVE_P (arg1)) - ? bignum_unsigned_logcount (s48_bignum_bitwise_not (arg1)) - : bignum_unsigned_logcount (arg1)); -} - -#define AND_OP 0 -#define IOR_OP 1 -#define XOR_OP 2 - -bignum_type -s48_bignum_bitwise_and(bignum_type arg1, bignum_type arg2) -{ - return( - (BIGNUM_NEGATIVE_P (arg1)) - ? (BIGNUM_NEGATIVE_P (arg2)) - ? bignum_negneg_bitwise_op(AND_OP, arg1, arg2) - : bignum_posneg_bitwise_op(AND_OP, arg2, arg1) - : (BIGNUM_NEGATIVE_P (arg2)) - ? bignum_posneg_bitwise_op(AND_OP, arg1, arg2) - : bignum_pospos_bitwise_op(AND_OP, arg1, arg2) - ); -} - -bignum_type -s48_bignum_bitwise_ior(bignum_type arg1, bignum_type arg2) -{ - return( - (BIGNUM_NEGATIVE_P (arg1)) - ? (BIGNUM_NEGATIVE_P (arg2)) - ? bignum_negneg_bitwise_op(IOR_OP, arg1, arg2) - : bignum_posneg_bitwise_op(IOR_OP, arg2, arg1) - : (BIGNUM_NEGATIVE_P (arg2)) - ? bignum_posneg_bitwise_op(IOR_OP, arg1, arg2) - : bignum_pospos_bitwise_op(IOR_OP, arg1, arg2) - ); -} - -bignum_type -s48_bignum_bitwise_xor(bignum_type arg1, bignum_type arg2) -{ - return( - (BIGNUM_NEGATIVE_P (arg1)) - ? (BIGNUM_NEGATIVE_P (arg2)) - ? bignum_negneg_bitwise_op(XOR_OP, arg1, arg2) - : bignum_posneg_bitwise_op(XOR_OP, arg2, arg1) - : (BIGNUM_NEGATIVE_P (arg2)) - ? bignum_posneg_bitwise_op(XOR_OP, arg1, arg2) - : bignum_pospos_bitwise_op(XOR_OP, arg1, arg2) - ); -} - -/* ash for the magnitude */ -/* assume arg1 is a big number, n is a long */ -bignum_type -bignum_magnitude_ash(bignum_type arg1, long n) -{ - bignum_type result = NULL; - bignum_digit_type *scan1; - bignum_digit_type *scanr; - bignum_digit_type *end; - - long digit_offset,bit_offset; - - if (BIGNUM_ZERO_P (arg1)) return (arg1); - - if (n > 0) { - digit_offset = n / BIGNUM_DIGIT_LENGTH; - bit_offset = n % BIGNUM_DIGIT_LENGTH; - - result = bignum_allocate_zeroed (BIGNUM_LENGTH (arg1) + digit_offset + 1, - BIGNUM_NEGATIVE_P(arg1)); - - scanr = BIGNUM_START_PTR (result) + digit_offset; - scan1 = BIGNUM_START_PTR (arg1); - end = scan1 + BIGNUM_LENGTH (arg1); - - while (scan1 < end) { - *scanr = *scanr | (*scan1 & BIGNUM_DIGIT_MASK) << bit_offset; - *scanr = *scanr & BIGNUM_DIGIT_MASK; - scanr++; - *scanr = *scan1++ >> (BIGNUM_DIGIT_LENGTH - bit_offset); - *scanr = *scanr & BIGNUM_DIGIT_MASK; - } - } - else if (n < 0 - && (-n >= (BIGNUM_LENGTH (arg1) * (bignum_length_type) BIGNUM_DIGIT_LENGTH))) - result = BIGNUM_ZERO (); - - else if (n < 0) { - digit_offset = -n / BIGNUM_DIGIT_LENGTH; - bit_offset = -n % BIGNUM_DIGIT_LENGTH; - - result = bignum_allocate_zeroed (BIGNUM_LENGTH (arg1) - digit_offset, - BIGNUM_NEGATIVE_P(arg1)); - - scanr = BIGNUM_START_PTR (result); - scan1 = BIGNUM_START_PTR (arg1) + digit_offset; - end = scanr + BIGNUM_LENGTH (result) - 1; - - while (scanr < end) { - *scanr = (*scan1++ & BIGNUM_DIGIT_MASK) >> bit_offset ; - *scanr = (*scanr | - *scan1 << (BIGNUM_DIGIT_LENGTH - bit_offset)) & BIGNUM_DIGIT_MASK; - scanr++; - } - *scanr = (*scan1++ & BIGNUM_DIGIT_MASK) >> bit_offset ; - } - else if (n == 0) result = arg1; - - return (bignum_trim (result)); -} - -bignum_type -bignum_pospos_bitwise_op(int op, bignum_type arg1, bignum_type arg2) -{ - bignum_type result; - bignum_length_type max_length; - - bignum_digit_type *scan1, *end1, digit1; - bignum_digit_type *scan2, *end2, digit2; - bignum_digit_type *scanr, *endr; - - max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2)) - ? BIGNUM_LENGTH(arg1) : BIGNUM_LENGTH(arg2); - - result = bignum_allocate(max_length, 0); - - scanr = BIGNUM_START_PTR(result); - scan1 = BIGNUM_START_PTR(arg1); - scan2 = BIGNUM_START_PTR(arg2); - endr = scanr + max_length; - end1 = scan1 + BIGNUM_LENGTH(arg1); - end2 = scan2 + BIGNUM_LENGTH(arg2); - - while (scanr < endr) { - digit1 = (scan1 < end1) ? *scan1++ : 0; - digit2 = (scan2 < end2) ? *scan2++ : 0; - /* - fprintf(stderr, "[pospos op = %d, i = %ld, d1 = %lx, d2 = %lx]\n", - op, endr - scanr, digit1, digit2); - */ - *scanr++ = (op == 0) ? digit1 & digit2 : - (op == 1) ? digit1 | digit2 : - digit1 ^ digit2; - } - return bignum_trim(result); -} - -bignum_type -bignum_posneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2) -{ - bignum_type result; - bignum_length_type max_length; - - bignum_digit_type *scan1, *end1, digit1; - bignum_digit_type *scan2, *end2, digit2, carry2; - bignum_digit_type *scanr, *endr; - - char neg_p = op == IOR_OP || op == XOR_OP; - - max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2) + 1) - ? BIGNUM_LENGTH(arg1) : BIGNUM_LENGTH(arg2) + 1; - - result = bignum_allocate(max_length, neg_p); - - scanr = BIGNUM_START_PTR(result); - scan1 = BIGNUM_START_PTR(arg1); - scan2 = BIGNUM_START_PTR(arg2); - endr = scanr + max_length; - end1 = scan1 + BIGNUM_LENGTH(arg1); - end2 = scan2 + BIGNUM_LENGTH(arg2); - - carry2 = 1; - - while (scanr < endr) { - digit1 = (scan1 < end1) ? *scan1++ : 0; - digit2 = (~((scan2 < end2) ? *scan2++ : 0) & BIGNUM_DIGIT_MASK) - + carry2; - - if (digit2 < BIGNUM_RADIX) - carry2 = 0; - else - { - digit2 = (digit2 - BIGNUM_RADIX); - carry2 = 1; - } - - *scanr++ = (op == AND_OP) ? digit1 & digit2 : - (op == IOR_OP) ? digit1 | digit2 : - digit1 ^ digit2; - } - - if (neg_p) - bignum_negate_magnitude(result); - - return bignum_trim(result); -} - -bignum_type -bignum_negneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2) -{ - bignum_type result; - bignum_length_type max_length; - - bignum_digit_type *scan1, *end1, digit1, carry1; - bignum_digit_type *scan2, *end2, digit2, carry2; - bignum_digit_type *scanr, *endr; - - char neg_p = op == AND_OP || op == IOR_OP; - - max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2)) - ? BIGNUM_LENGTH(arg1) + 1 : BIGNUM_LENGTH(arg2) + 1; - - result = bignum_allocate(max_length, neg_p); - - scanr = BIGNUM_START_PTR(result); - scan1 = BIGNUM_START_PTR(arg1); - scan2 = BIGNUM_START_PTR(arg2); - endr = scanr + max_length; - end1 = scan1 + BIGNUM_LENGTH(arg1); - end2 = scan2 + BIGNUM_LENGTH(arg2); - - carry1 = 1; - carry2 = 1; - - while (scanr < endr) { - digit1 = (~((scan1 < end1) ? *scan1++ : 0) & BIGNUM_DIGIT_MASK) + carry1; - digit2 = (~((scan2 < end2) ? *scan2++ : 0) & BIGNUM_DIGIT_MASK) + carry2; - - if (digit1 < BIGNUM_RADIX) - carry1 = 0; - else - { - digit1 = (digit1 - BIGNUM_RADIX); - carry1 = 1; - } - - if (digit2 < BIGNUM_RADIX) - carry2 = 0; - else - { - digit2 = (digit2 - BIGNUM_RADIX); - carry2 = 1; - } - - *scanr++ = (op == 0) ? digit1 & digit2 : - (op == 1) ? digit1 | digit2 : - digit1 ^ digit2; - } - - if (neg_p) - bignum_negate_magnitude(result); - - return bignum_trim(result); -} - -void -bignum_negate_magnitude(bignum_type arg) -{ - bignum_digit_type *scan; - bignum_digit_type *end; - bignum_digit_type digit; - bignum_digit_type carry; - - scan = BIGNUM_START_PTR(arg); - end = scan + BIGNUM_LENGTH(arg); - - carry = 1; - - while (scan < end) { - digit = (~*scan & BIGNUM_DIGIT_MASK) + carry; - - if (digit < BIGNUM_RADIX) - carry = 0; - else - { - digit = (digit - BIGNUM_RADIX); - carry = 1; - } - - *scan++ = digit; - } -} - -long -bignum_unsigned_logcount(bignum_type arg) -{ - - bignum_digit_type *scan; - bignum_digit_type *end; - bignum_digit_type digit; - - /* sufficient for any reasonable big number */ - long result; - int i; - - if (BIGNUM_ZERO_P (arg)) return (0L); - - scan = BIGNUM_START_PTR (arg); - end = scan + BIGNUM_LENGTH (arg); - result = 0L; - - while (scan < end) { - digit = *scan++ & BIGNUM_DIGIT_MASK; - for (i = 0; i++ < BIGNUM_DIGIT_LENGTH; digit = digit >> 1L) - result += digit & 1L; - } - - return (result); -} - -int -bignum_logbitp(int shift, bignum_type arg) -{ - return((BIGNUM_NEGATIVE_P (arg)) - ? !bignum_unsigned_logbitp (shift, s48_bignum_bitwise_not (arg)) - : bignum_unsigned_logbitp (shift,arg)); -} - -int -bignum_unsigned_logbitp(int shift, bignum_type bignum) -{ - bignum_length_type len = (BIGNUM_LENGTH (bignum)); - bignum_digit_type digit; - int index = shift / BIGNUM_DIGIT_LENGTH; - int p; - if (index >= len) - return 0; - digit = (BIGNUM_REF (bignum, index)); - p = shift % BIGNUM_DIGIT_LENGTH; - return digit & (1 << p); -} - diff --git a/vm/s48_bignum.h b/vm/s48_bignum.h deleted file mode 100644 index 61abc0d9f7..0000000000 --- a/vm/s48_bignum.h +++ /dev/null @@ -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); diff --git a/vm/sbuf.c b/vm/sbuf.c deleted file mode 100644 index 9ddf15aa9e..0000000000 --- a/vm/sbuf.c +++ /dev/null @@ -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); -} diff --git a/vm/sbuf.h b/vm/sbuf.h deleted file mode 100644 index b89d59d49a..0000000000 --- a/vm/sbuf.h +++ /dev/null @@ -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); diff --git a/vm/signal.h b/vm/signal.h deleted file mode 100644 index f5ee86572d..0000000000 --- a/vm/signal.h +++ /dev/null @@ -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); diff --git a/vm/stack.h b/vm/stack.h index 330afd6db8..a003c44a5c 100644 --- a/vm/stack.h +++ b/vm/stack.h @@ -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; diff --git a/vm/string.c b/vm/string.c deleted file mode 100644 index a42ac97b09..0000000000 --- a/vm/string.c +++ /dev/null @@ -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); -} diff --git a/vm/string.h b/vm/string.h deleted file mode 100644 index f2a47bb7e1..0000000000 --- a/vm/string.h +++ /dev/null @@ -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); diff --git a/vm/types.c b/vm/types.c new file mode 100644 index 0000000000..b991a6081d --- /dev/null +++ b/vm/types.c @@ -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)); +} + +/* ( 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); +} diff --git a/vm/types.h b/vm/types.h new file mode 100644 index 0000000000..88daa12cf1 --- /dev/null +++ b/vm/types.h @@ -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); diff --git a/vm/unix/ffi.c b/vm/unix/ffi.c deleted file mode 100644 index 139f9182b9..0000000000 --- a/vm/unix/ffi.c +++ /dev/null @@ -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; -} diff --git a/vm/unix/file.c b/vm/unix/file.c deleted file mode 100644 index f50b97c40a..0000000000 --- a/vm/unix/file.c +++ /dev/null @@ -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()); -} - diff --git a/vm/unix/icache.S b/vm/unix/icache.S deleted file mode 100644 index f4fc8fb4a5..0000000000 --- a/vm/unix/icache.S +++ /dev/null @@ -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 diff --git a/vm/unix/memory.c b/vm/unix/memory.c deleted file mode 100644 index 096ee423b1..0000000000 --- a/vm/unix/memory.c +++ /dev/null @@ -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); -} diff --git a/vm/unix/signal.c b/vm/unix/signal.c deleted file mode 100644 index 5ebcb9e47e..0000000000 --- a/vm/unix/signal.c +++ /dev/null @@ -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 -} diff --git a/vm/vector.c b/vm/vector.c deleted file mode 100644 index 927a491171..0000000000 --- a/vm/vector.c +++ /dev/null @@ -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); -} diff --git a/vm/vector.h b/vm/vector.h deleted file mode 100644 index b46a77dba2..0000000000 --- a/vm/vector.h +++ /dev/null @@ -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); diff --git a/vm/windows/ffi.c b/vm/windows/ffi.c deleted file mode 100644 index f94630c2c5..0000000000 --- a/vm/windows/ffi.c +++ /dev/null @@ -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; -} diff --git a/vm/windows/file.c b/vm/windows/file.c deleted file mode 100644 index 2217c3af99..0000000000 --- a/vm/windows/file.c +++ /dev/null @@ -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()); -} \ No newline at end of file diff --git a/vm/windows/memory.c b/vm/windows/memory.c deleted file mode 100644 index 8c99e8fc94..0000000000 --- a/vm/windows/memory.c +++ /dev/null @@ -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); -} - diff --git a/vm/windows/misc.c b/vm/windows/misc.c deleted file mode 100644 index 66fa60aa46..0000000000 --- a/vm/windows/misc.c +++ /dev/null @@ -1,3 +0,0 @@ -#include "../factor.h" - -void init_signals() { } diff --git a/vm/windows/run.c b/vm/windows/run.c deleted file mode 100644 index 001797f90c..0000000000 --- a/vm/windows/run.c +++ /dev/null @@ -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"; -} diff --git a/vm/word.c b/vm/word.c deleted file mode 100644 index 14ab6e4592..0000000000 --- a/vm/word.c +++ /dev/null @@ -1,68 +0,0 @@ -#include "factor.h" - -/* 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)); -} - -/* ( 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); -} diff --git a/vm/word.h b/vm/word.h deleted file mode 100644 index c27639355a..0000000000 --- a/vm/word.h +++ /dev/null @@ -1,43 +0,0 @@ -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 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); diff --git a/vm/wrapper.c b/vm/wrapper.c deleted file mode 100644 index cd63308f5d..0000000000 --- a/vm/wrapper.c +++ /dev/null @@ -1,22 +0,0 @@ -#include "factor.h" - -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); -} diff --git a/vm/wrapper.h b/vm/wrapper.h deleted file mode 100644 index 93767aff90..0000000000 --- a/vm/wrapper.h +++ /dev/null @@ -1,18 +0,0 @@ -typedef struct { - CELL header; - CELL object; -} F_WRAPPER; - -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);