From c3a88ce57bdab0f12b39369fc7be6ad4baef47d7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 2 May 2009 04:04:19 -0500 Subject: [PATCH 01/44] Porting VM to C++ --- Makefile | 126 +-- vmpp/Config.arm | 1 + vmpp/Config.freebsd | 4 + vmpp/Config.freebsd.x86.32 | 2 + vmpp/Config.freebsd.x86.64 | 3 + vmpp/Config.linux | 4 + vmpp/Config.linux.arm | 3 + vmpp/Config.linux.ppc | 3 + vmpp/Config.linux.x86.32 | 2 + vmpp/Config.linux.x86.64 | 3 + vmpp/Config.macosx | 23 + vmpp/Config.macosx.ppc | 3 + vmpp/Config.macosx.x86.32 | 2 + vmpp/Config.macosx.x86.64 | 3 + vmpp/Config.netbsd | 5 + vmpp/Config.netbsd.x86.32 | 2 + vmpp/Config.netbsd.x86.64 | 2 + vmpp/Config.openbsd | 5 + vmpp/Config.openbsd.x86.32 | 2 + vmpp/Config.openbsd.x86.64 | 2 + vmpp/Config.ppc | 1 + vmpp/Config.solaris | 6 + vmpp/Config.solaris.x86.32 | 2 + vmpp/Config.solaris.x86.64 | 2 + vmpp/Config.unix | 27 + vmpp/Config.windows | 10 + vmpp/Config.windows.ce | 5 + vmpp/Config.windows.ce.arm | 4 + vmpp/Config.windows.nt | 10 + vmpp/Config.windows.nt.x86.32 | 4 + vmpp/Config.windows.nt.x86.64 | 6 + vmpp/Config.x86.32 | 5 + vmpp/Config.x86.64 | 2 + vmpp/alien.cpp | 234 ++++ vmpp/alien.hpp | 50 + vmpp/arrays.cpp | 159 +++ vmpp/arrays.hpp | 64 ++ vmpp/asm.h | 16 + vmpp/bignum.cpp | 1881 +++++++++++++++++++++++++++++++++ vmpp/bignum.hpp | 127 +++ vmpp/bignumint.hpp | 100 ++ vmpp/booleans.cpp | 13 + vmpp/booleans.hpp | 7 + vmpp/byte_arrays.cpp | 84 ++ vmpp/byte_arrays.hpp | 40 + vmpp/callstack.cpp | 230 ++++ vmpp/callstack.hpp | 28 + vmpp/code_block.cpp | 504 +++++++++ vmpp/code_block.hpp | 92 ++ vmpp/code_gc.cpp | 336 ++++++ vmpp/code_gc.hpp | 45 + vmpp/code_heap.cpp | 228 ++++ vmpp/code_heap.hpp | 27 + vmpp/cpu-arm.S | 127 +++ vmpp/cpu-arm.hpp | 13 + vmpp/cpu-ppc.S | 236 +++++ vmpp/cpu-ppc.hpp | 12 + vmpp/cpu-x86.32.S | 76 ++ vmpp/cpu-x86.32.hpp | 6 + vmpp/cpu-x86.64.S | 83 ++ vmpp/cpu-x86.64.hpp | 6 + vmpp/cpu-x86.S | 74 ++ vmpp/cpu-x86.hpp | 45 + vmpp/data_gc.cpp | 672 ++++++++++++ vmpp/data_gc.h | 159 +++ vmpp/data_gc.hpp | 122 +++ vmpp/data_heap.cpp | 385 +++++++ vmpp/data_heap.hpp | 134 +++ vmpp/debug.cpp | 502 +++++++++ vmpp/debug.hpp | 7 + vmpp/dispatch.cpp | 205 ++++ vmpp/dispatch.hpp | 13 + vmpp/errors.cpp | 157 +++ vmpp/errors.hpp | 62 ++ vmpp/factor.cpp | 215 ++++ vmpp/factor.hpp | 11 + vmpp/factor.rs | 2 + vmpp/ffi_test.c | 321 ++++++ vmpp/ffi_test.h | 98 ++ vmpp/float_bits.hpp | 40 + vmpp/image.cpp | 339 ++++++ vmpp/image.hpp | 45 + vmpp/inline_cache.cpp | 257 +++++ vmpp/inline_cache.hpp | 8 + vmpp/io.cpp | 226 ++++ vmpp/io.hpp | 18 + vmpp/jit.cpp | 123 +++ vmpp/jit.hpp | 92 ++ vmpp/layouts.hpp | 263 +++++ vmpp/local_roots.cpp | 7 + vmpp/local_roots.hpp | 66 ++ vmpp/mach_signal.cpp | 202 ++++ vmpp/mach_signal.hpp | 75 ++ vmpp/main-unix.cpp | 7 + vmpp/main-windows-ce.cpp | 134 +++ vmpp/main-windows-nt.cpp | 27 + vmpp/master.hpp | 60 ++ vmpp/math.cpp | 519 +++++++++ vmpp/math.hpp | 149 +++ vmpp/os-freebsd-x86.32.hpp | 9 + vmpp/os-freebsd-x86.64.hpp | 9 + vmpp/os-freebsd.cpp | 34 + vmpp/os-freebsd.hpp | 9 + vmpp/os-genunix.cpp | 35 + vmpp/os-genunix.hpp | 8 + vmpp/os-linux-arm.cpp | 26 + vmpp/os-linux-arm.hpp | 14 + vmpp/os-linux-ppc.hpp | 12 + vmpp/os-linux-x86.32.hpp | 10 + vmpp/os-linux-x86.64.hpp | 10 + vmpp/os-linux.cpp | 58 + vmpp/os-linux.hpp | 5 + vmpp/os-macosx-ppc.hpp | 39 + vmpp/os-macosx-x86.32.hpp | 37 + vmpp/os-macosx-x86.64.hpp | 37 + vmpp/os-macosx.hpp | 17 + vmpp/os-macosx.mm | 82 ++ vmpp/os-netbsd-x86.32.hpp | 3 + vmpp/os-netbsd-x86.64.hpp | 4 + vmpp/os-netbsd.cpp | 11 + vmpp/os-netbsd.hpp | 5 + vmpp/os-openbsd-x86.32.hpp | 10 + vmpp/os-openbsd-x86.64.hpp | 10 + vmpp/os-openbsd.cpp | 6 + vmpp/os-solaris-x86.32.hpp | 10 + vmpp/os-solaris-x86.64.hpp | 10 + vmpp/os-solaris.cpp | 6 + vmpp/os-unix.cpp | 315 ++++++ vmpp/os-unix.hpp | 59 ++ vmpp/os-windows-ce.cpp | 40 + vmpp/os-windows-ce.hpp | 27 + vmpp/os-windows-nt.32.hpp | 2 + vmpp/os-windows-nt.64.hpp | 2 + vmpp/os-windows-nt.cpp | 51 + vmpp/os-windows-nt.hpp | 21 + vmpp/os-windows.cpp | 147 +++ vmpp/os-windows.hpp | 59 ++ vmpp/platform.hpp | 122 +++ vmpp/primitives.cpp | 154 +++ vmpp/primitives.hpp | 3 + vmpp/profiler.cpp | 58 + vmpp/profiler.hpp | 4 + vmpp/quotations.cpp | 374 +++++++ vmpp/quotations.hpp | 16 + vmpp/run.cpp | 254 +++++ vmpp/run.hpp | 273 +++++ vmpp/strings.cpp | 294 ++++++ vmpp/strings.hpp | 46 + vmpp/tuples.cpp | 35 + vmpp/tuples.hpp | 32 + vmpp/utilities.cpp | 55 + vmpp/utilities.hpp | 10 + vmpp/words.cpp | 82 ++ vmpp/words.hpp | 18 + vmpp/write_barrier.cpp | 5 + vmpp/write_barrier.hpp | 66 ++ 156 files changed, 14040 insertions(+), 59 deletions(-) create mode 100644 vmpp/Config.arm create mode 100644 vmpp/Config.freebsd create mode 100644 vmpp/Config.freebsd.x86.32 create mode 100644 vmpp/Config.freebsd.x86.64 create mode 100644 vmpp/Config.linux create mode 100644 vmpp/Config.linux.arm create mode 100644 vmpp/Config.linux.ppc create mode 100644 vmpp/Config.linux.x86.32 create mode 100644 vmpp/Config.linux.x86.64 create mode 100644 vmpp/Config.macosx create mode 100644 vmpp/Config.macosx.ppc create mode 100644 vmpp/Config.macosx.x86.32 create mode 100644 vmpp/Config.macosx.x86.64 create mode 100644 vmpp/Config.netbsd create mode 100644 vmpp/Config.netbsd.x86.32 create mode 100644 vmpp/Config.netbsd.x86.64 create mode 100644 vmpp/Config.openbsd create mode 100644 vmpp/Config.openbsd.x86.32 create mode 100644 vmpp/Config.openbsd.x86.64 create mode 100644 vmpp/Config.ppc create mode 100644 vmpp/Config.solaris create mode 100644 vmpp/Config.solaris.x86.32 create mode 100644 vmpp/Config.solaris.x86.64 create mode 100755 vmpp/Config.unix create mode 100644 vmpp/Config.windows create mode 100644 vmpp/Config.windows.ce create mode 100755 vmpp/Config.windows.ce.arm create mode 100644 vmpp/Config.windows.nt create mode 100644 vmpp/Config.windows.nt.x86.32 create mode 100644 vmpp/Config.windows.nt.x86.64 create mode 100644 vmpp/Config.x86.32 create mode 100644 vmpp/Config.x86.64 create mode 100755 vmpp/alien.cpp create mode 100755 vmpp/alien.hpp create mode 100644 vmpp/arrays.cpp create mode 100644 vmpp/arrays.hpp create mode 100644 vmpp/asm.h create mode 100755 vmpp/bignum.cpp create mode 100644 vmpp/bignum.hpp create mode 100644 vmpp/bignumint.hpp create mode 100644 vmpp/booleans.cpp create mode 100644 vmpp/booleans.hpp create mode 100644 vmpp/byte_arrays.cpp create mode 100644 vmpp/byte_arrays.hpp create mode 100755 vmpp/callstack.cpp create mode 100755 vmpp/callstack.hpp create mode 100644 vmpp/code_block.cpp create mode 100644 vmpp/code_block.hpp create mode 100755 vmpp/code_gc.cpp create mode 100755 vmpp/code_gc.hpp create mode 100755 vmpp/code_heap.cpp create mode 100755 vmpp/code_heap.hpp create mode 100755 vmpp/cpu-arm.S create mode 100755 vmpp/cpu-arm.hpp create mode 100755 vmpp/cpu-ppc.S create mode 100755 vmpp/cpu-ppc.hpp create mode 100755 vmpp/cpu-x86.32.S create mode 100755 vmpp/cpu-x86.32.hpp create mode 100644 vmpp/cpu-x86.64.S create mode 100644 vmpp/cpu-x86.64.hpp create mode 100755 vmpp/cpu-x86.S create mode 100755 vmpp/cpu-x86.hpp create mode 100755 vmpp/data_gc.cpp create mode 100644 vmpp/data_gc.h create mode 100755 vmpp/data_gc.hpp create mode 100644 vmpp/data_heap.cpp create mode 100644 vmpp/data_heap.hpp create mode 100755 vmpp/debug.cpp create mode 100755 vmpp/debug.hpp create mode 100644 vmpp/dispatch.cpp create mode 100644 vmpp/dispatch.hpp create mode 100755 vmpp/errors.cpp create mode 100755 vmpp/errors.hpp create mode 100755 vmpp/factor.cpp create mode 100644 vmpp/factor.hpp create mode 100644 vmpp/factor.rs create mode 100755 vmpp/ffi_test.c create mode 100755 vmpp/ffi_test.h create mode 100644 vmpp/float_bits.hpp create mode 100755 vmpp/image.cpp create mode 100755 vmpp/image.hpp create mode 100644 vmpp/inline_cache.cpp create mode 100644 vmpp/inline_cache.hpp create mode 100755 vmpp/io.cpp create mode 100755 vmpp/io.hpp create mode 100644 vmpp/jit.cpp create mode 100644 vmpp/jit.hpp create mode 100755 vmpp/layouts.hpp create mode 100644 vmpp/local_roots.cpp create mode 100644 vmpp/local_roots.hpp create mode 100644 vmpp/mach_signal.cpp create mode 100644 vmpp/mach_signal.hpp create mode 100644 vmpp/main-unix.cpp create mode 100644 vmpp/main-windows-ce.cpp create mode 100755 vmpp/main-windows-nt.cpp create mode 100644 vmpp/master.hpp create mode 100644 vmpp/math.cpp create mode 100644 vmpp/math.hpp create mode 100644 vmpp/os-freebsd-x86.32.hpp create mode 100644 vmpp/os-freebsd-x86.64.hpp create mode 100644 vmpp/os-freebsd.cpp create mode 100644 vmpp/os-freebsd.hpp create mode 100755 vmpp/os-genunix.cpp create mode 100644 vmpp/os-genunix.hpp create mode 100644 vmpp/os-linux-arm.cpp create mode 100644 vmpp/os-linux-arm.hpp create mode 100644 vmpp/os-linux-ppc.hpp create mode 100644 vmpp/os-linux-x86.32.hpp create mode 100644 vmpp/os-linux-x86.64.hpp create mode 100644 vmpp/os-linux.cpp create mode 100644 vmpp/os-linux.hpp create mode 100644 vmpp/os-macosx-ppc.hpp create mode 100644 vmpp/os-macosx-x86.32.hpp create mode 100644 vmpp/os-macosx-x86.64.hpp create mode 100644 vmpp/os-macosx.hpp create mode 100644 vmpp/os-macosx.mm create mode 100644 vmpp/os-netbsd-x86.32.hpp create mode 100644 vmpp/os-netbsd-x86.64.hpp create mode 100755 vmpp/os-netbsd.cpp create mode 100644 vmpp/os-netbsd.hpp create mode 100644 vmpp/os-openbsd-x86.32.hpp create mode 100644 vmpp/os-openbsd-x86.64.hpp create mode 100644 vmpp/os-openbsd.cpp create mode 100644 vmpp/os-solaris-x86.32.hpp create mode 100644 vmpp/os-solaris-x86.64.hpp create mode 100644 vmpp/os-solaris.cpp create mode 100755 vmpp/os-unix.cpp create mode 100755 vmpp/os-unix.hpp create mode 100755 vmpp/os-windows-ce.cpp create mode 100755 vmpp/os-windows-ce.hpp create mode 100644 vmpp/os-windows-nt.32.hpp create mode 100644 vmpp/os-windows-nt.64.hpp create mode 100755 vmpp/os-windows-nt.cpp create mode 100755 vmpp/os-windows-nt.hpp create mode 100755 vmpp/os-windows.cpp create mode 100755 vmpp/os-windows.hpp create mode 100644 vmpp/platform.hpp create mode 100755 vmpp/primitives.cpp create mode 100644 vmpp/primitives.hpp create mode 100755 vmpp/profiler.cpp create mode 100755 vmpp/profiler.hpp create mode 100755 vmpp/quotations.cpp create mode 100755 vmpp/quotations.hpp create mode 100755 vmpp/run.cpp create mode 100755 vmpp/run.hpp create mode 100644 vmpp/strings.cpp create mode 100644 vmpp/strings.hpp create mode 100644 vmpp/tuples.cpp create mode 100644 vmpp/tuples.hpp create mode 100755 vmpp/utilities.cpp create mode 100755 vmpp/utilities.hpp create mode 100644 vmpp/words.cpp create mode 100644 vmpp/words.hpp create mode 100644 vmpp/write_barrier.cpp create mode 100644 vmpp/write_barrier.hpp diff --git a/Makefile b/Makefile index 33d42217a2..8549325056 100755 --- a/Makefile +++ b/Makefile @@ -1,4 +1,5 @@ CC = gcc +CPP = g++ AR = ar LD = ld @@ -9,7 +10,7 @@ VERSION = 0.92 BUNDLE = Factor.app LIBPATH = -L/usr/X11R6/lib -CFLAGS = -Wall -Werror +CFLAGS = -Wall ifdef DEBUG CFLAGS += -g -DFACTOR_DEBUG @@ -26,38 +27,40 @@ ifdef CONFIG endif DLL_OBJS = $(PLAF_DLL_OBJS) \ - vm/alien.o \ - vm/arrays.o \ - vm/bignum.o \ - vm/booleans.o \ - vm/byte_arrays.o \ - vm/callstack.o \ - vm/code_block.o \ - vm/code_gc.o \ - vm/code_heap.o \ - vm/data_gc.o \ - vm/data_heap.o \ - vm/debug.o \ - vm/dispatch.o \ - vm/errors.o \ - vm/factor.o \ - vm/image.o \ - vm/inline_cache.o \ - vm/io.o \ - vm/jit.o \ - vm/math.o \ - vm/primitives.o \ - vm/profiler.o \ - vm/quotations.o \ - vm/run.o \ - vm/strings.o \ - vm/tuples.o \ - vm/utilities.o \ - vm/words.o + vmpp/alien.o \ + vmpp/arrays.o \ + vmpp/bignum.o \ + vmpp/booleans.o \ + vmpp/byte_arrays.o \ + vmpp/callstack.o \ + vmpp/code_block.o \ + vmpp/code_gc.o \ + vmpp/code_heap.o \ + vmpp/data_gc.o \ + vmpp/data_heap.o \ + vmpp/debug.o \ + vmpp/dispatch.o \ + vmpp/errors.o \ + vmpp/factor.o \ + vmpp/image.o \ + vmpp/inline_cache.o \ + vmpp/io.o \ + vmpp/jit.o \ + vmpp/local_roots.o \ + vmpp/math.o \ + vmpp/primitives.o \ + vmpp/profiler.o \ + vmpp/quotations.o \ + vmpp/run.o \ + vmpp/strings.o \ + vmpp/tuples.o \ + vmpp/utilities.o \ + vmpp/words.o \ + vmpp/write_barrier.o EXE_OBJS = $(PLAF_EXE_OBJS) -TEST_OBJS = vm/ffi_test.o +TEST_OBJS = vmpp/ffi_test.o default: $(MAKE) `./build-support/factor.sh make-target` @@ -92,60 +95,60 @@ help: @echo "X11=1 force link with X11 libraries instead of Cocoa (only on Mac OS X)" openbsd-x86-32: - $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.openbsd.x86.32 + $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.openbsd.x86.32 openbsd-x86-64: - $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.openbsd.x86.64 + $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.openbsd.x86.64 freebsd-x86-32: - $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.freebsd.x86.32 + $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.freebsd.x86.32 freebsd-x86-64: - $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.freebsd.x86.64 + $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.freebsd.x86.64 netbsd-x86-32: - $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.netbsd.x86.32 + $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.netbsd.x86.32 netbsd-x86-64: - $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.netbsd.x86.64 + $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.netbsd.x86.64 macosx-ppc: - $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) macosx.app CONFIG=vm/Config.macosx.ppc + $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) macosx.app CONFIG=vmpp/Config.macosx.ppc macosx-x86-32: - $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) macosx.app CONFIG=vm/Config.macosx.x86.32 + $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) macosx.app CONFIG=vmpp/Config.macosx.x86.32 macosx-x86-64: - $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) macosx.app CONFIG=vm/Config.macosx.x86.64 + $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) macosx.app CONFIG=vmpp/Config.macosx.x86.64 linux-x86-32: - $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.linux.x86.32 + $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.linux.x86.32 linux-x86-64: - $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.linux.x86.64 + $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.linux.x86.64 linux-ppc: - $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.linux.ppc + $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.linux.ppc linux-arm: - $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.linux.arm + $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.linux.arm solaris-x86-32: - $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.solaris.x86.32 + $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.solaris.x86.32 solaris-x86-64: - $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.solaris.x86.64 + $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.solaris.x86.64 winnt-x86-32: - $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.windows.nt.x86.32 - $(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32 + $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.windows.nt.x86.32 + $(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vmpp/Config.windows.nt.x86.32 winnt-x86-64: - $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.windows.nt.x86.64 - $(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64 + $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.windows.nt.x86.64 + $(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vmpp/Config.windows.nt.x86.64 wince-arm: - $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.windows.ce.arm + $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.windows.ce.arm macosx.app: factor mkdir -p $(BUNDLE)/Contents/MacOS @@ -161,34 +164,39 @@ macosx.app: factor $(EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS) $(LINKER) $(ENGINE) $(DLL_OBJS) - $(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \ + $(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \ $(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS) $(CONSOLE_EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS) $(LINKER) $(ENGINE) $(DLL_OBJS) - $(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \ + $(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \ $(CFLAGS) $(CFLAGS_CONSOLE) -o factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION) $(EXE_OBJS) -$(TEST_LIBRARY): vm/ffi_test.o +$(TEST_LIBRARY): vmpp/ffi_test.o $(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o libfactor-ffi-test$(SHARED_DLL_EXTENSION) $(TEST_OBJS) clean: - rm -f vm/*.o + rm -f vmpp/*.o rm -f factor*.dll libfactor.{a,so,dylib} libfactor-ffi-test.{a,so,dylib} Factor.app/Contents/Frameworks/libfactor.dylib -vm/resources.o: - $(WINDRES) vm/factor.rs vm/resources.o +vmpp/resources.o: + $(WINDRES) vmpp/factor.rs vmpp/resources.o -vm/ffi_test.o: vm/ffi_test.c +vmpp/ffi_test.o: vmpp/ffi_test.c $(CC) -c $(CFLAGS) $(FFI_TEST_CFLAGS) -o $@ $< .c.o: $(CC) -c $(CFLAGS) -o $@ $< +.cpp.o: + $(CPP) -c $(CFLAGS) -o $@ $< + .S.o: $(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $< -.m.o: - $(CC) -c $(CFLAGS) -o $@ $< +.mm.o: + $(CPP) -c $(CFLAGS) -o $@ $< .PHONY: factor + +.SUFFIXES: .mm diff --git a/vmpp/Config.arm b/vmpp/Config.arm new file mode 100644 index 0000000000..003383aeb9 --- /dev/null +++ b/vmpp/Config.arm @@ -0,0 +1 @@ +PLAF_DLL_OBJS += vmpppp/cpu-arm.o diff --git a/vmpp/Config.freebsd b/vmpp/Config.freebsd new file mode 100644 index 0000000000..91f6adf340 --- /dev/null +++ b/vmpp/Config.freebsd @@ -0,0 +1,4 @@ +include vmpppp/Config.unix +PLAF_DLL_OBJS += vmpppp/os-genunix.o vmpp/os-freebsd.o +CFLAGS += -export-dynamic +LIBS = -L/usr/local/lib/ -lm $(X11_UI_LIBS) diff --git a/vmpp/Config.freebsd.x86.32 b/vmpp/Config.freebsd.x86.32 new file mode 100644 index 0000000000..e5acaccc00 --- /dev/null +++ b/vmpp/Config.freebsd.x86.32 @@ -0,0 +1,2 @@ +include vmpp/Config.freebsd +include vmpp/Config.x86.32 diff --git a/vmpp/Config.freebsd.x86.64 b/vmpp/Config.freebsd.x86.64 new file mode 100644 index 0000000000..24d2b894bc --- /dev/null +++ b/vmpp/Config.freebsd.x86.64 @@ -0,0 +1,3 @@ +include vmpp/Config.freebsd +include vmpp/Config.x86.64 +LIBS += -lpthread diff --git a/vmpp/Config.linux b/vmpp/Config.linux new file mode 100644 index 0000000000..57622af687 --- /dev/null +++ b/vmpp/Config.linux @@ -0,0 +1,4 @@ +include vmpp/Config.unix +PLAF_DLL_OBJS += vmpp/os-genunix.o vm/os-linux.o +CFLAGS += -export-dynamic +LIBS = -ldl -lm -lpthread $(X11_UI_LIBS) diff --git a/vmpp/Config.linux.arm b/vmpp/Config.linux.arm new file mode 100644 index 0000000000..926638d51b --- /dev/null +++ b/vmpp/Config.linux.arm @@ -0,0 +1,3 @@ +include vmpp/Config.linux +include vmpp/Config.arm +PLAF_DLL_OBJS += vmpp/os-linux-arm.o diff --git a/vmpp/Config.linux.ppc b/vmpp/Config.linux.ppc new file mode 100644 index 0000000000..439b2284f9 --- /dev/null +++ b/vmpp/Config.linux.ppc @@ -0,0 +1,3 @@ +include vmpp/Config.linux +include vmpp/Config.ppc +CFLAGS += -mregnames diff --git a/vmpp/Config.linux.x86.32 b/vmpp/Config.linux.x86.32 new file mode 100644 index 0000000000..95b5baf2f8 --- /dev/null +++ b/vmpp/Config.linux.x86.32 @@ -0,0 +1,2 @@ +include vmpp/Config.linux +include vmpp/Config.x86.32 diff --git a/vmpp/Config.linux.x86.64 b/vmpp/Config.linux.x86.64 new file mode 100644 index 0000000000..fb20de21f2 --- /dev/null +++ b/vmpp/Config.linux.x86.64 @@ -0,0 +1,3 @@ +include vmpp/Config.linux +include vmpp/Config.x86.64 +LIBPATH = -L/usr/X11R6/lib64 -L/usr/X11R6/lib diff --git a/vmpp/Config.macosx b/vmpp/Config.macosx new file mode 100644 index 0000000000..221020fb9a --- /dev/null +++ b/vmpp/Config.macosx @@ -0,0 +1,23 @@ +include vmpp/Config.unix +CFLAGS += -fPIC + +PLAF_DLL_OBJS += vmpp/os-macosx.o vmpp/mach_signal.o + +DLL_EXTENSION = .dylib +SHARED_DLL_EXTENSION = .dylib + +SHARED_FLAG = -dynamiclib + +ifdef X11 + LIBS = -lm -framework Cocoa -L/opt/local/lib $(X11_UI_LIBS) -Wl,-dylib_file,/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib:/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib +else + LIBS = -lm -framework Cocoa -framework AppKit +endif + +LINKER = $(CPP) $(CFLAGS) -dynamiclib -single_module -std=gnu99 \ + -current_version $(VERSION) \ + -compatibility_version $(VERSION) \ + -fvisibility=hidden \ + $(LIBS) $(LIBPATH) -o + +LINK_WITH_ENGINE = -lfactor diff --git a/vmpp/Config.macosx.ppc b/vmpp/Config.macosx.ppc new file mode 100644 index 0000000000..8152f0dc97 --- /dev/null +++ b/vmpp/Config.macosx.ppc @@ -0,0 +1,3 @@ +include vmpp/Config.macosx +include vmpp/Config.ppc +CFLAGS += -arch ppc diff --git a/vmpp/Config.macosx.x86.32 b/vmpp/Config.macosx.x86.32 new file mode 100644 index 0000000000..3780d0f66d --- /dev/null +++ b/vmpp/Config.macosx.x86.32 @@ -0,0 +1,2 @@ +include vmpp/Config.macosx +include vmpp/Config.x86.32 diff --git a/vmpp/Config.macosx.x86.64 b/vmpp/Config.macosx.x86.64 new file mode 100644 index 0000000000..9528d84889 --- /dev/null +++ b/vmpp/Config.macosx.x86.64 @@ -0,0 +1,3 @@ +include vmpp/Config.macosx +include vmpp/Config.x86.64 +CFLAGS += -m64 diff --git a/vmpp/Config.netbsd b/vmpp/Config.netbsd new file mode 100644 index 0000000000..051168affb --- /dev/null +++ b/vmpp/Config.netbsd @@ -0,0 +1,5 @@ +include vmpp/Config.unix +PLAF_DLL_OBJS += vmpp/os-genunix.o vm/os-netbsd.o +CFLAGS += -export-dynamic +LIBPATH = -L/usr/X11R6/lib -Wl,-rpath,/usr/X11R6/lib -L/usr/pkg/lib -Wl,-rpath,/usr/pkg/lib +LIBS = -lm -lopenal -lalut $(X11_UI_LIBS) diff --git a/vmpp/Config.netbsd.x86.32 b/vmpp/Config.netbsd.x86.32 new file mode 100644 index 0000000000..24223f2002 --- /dev/null +++ b/vmpp/Config.netbsd.x86.32 @@ -0,0 +1,2 @@ +include vmpp/Config.netbsd +include vmpp/Config.x86.32 diff --git a/vmpp/Config.netbsd.x86.64 b/vmpp/Config.netbsd.x86.64 new file mode 100644 index 0000000000..a3399f498d --- /dev/null +++ b/vmpp/Config.netbsd.x86.64 @@ -0,0 +1,2 @@ +include vmpp/Config.netbsd +include vmpp/Config.x86.64 diff --git a/vmpp/Config.openbsd b/vmpp/Config.openbsd new file mode 100644 index 0000000000..36240d93ee --- /dev/null +++ b/vmpp/Config.openbsd @@ -0,0 +1,5 @@ +include vmpp/Config.unix +PLAF_DLL_OBJS += vmpp/os-genunix.o vm/os-openbsd.o +CC = egcc +CFLAGS += -export-dynamic +LIBS = -L/usr/local/lib/ -lm $(X11_UI_LIBS) -lz -lssl -lcrypto -lpthread diff --git a/vmpp/Config.openbsd.x86.32 b/vmpp/Config.openbsd.x86.32 new file mode 100644 index 0000000000..9c15945057 --- /dev/null +++ b/vmpp/Config.openbsd.x86.32 @@ -0,0 +1,2 @@ +include vmpp/Config.openbsd +include vmpp/Config.x86.32 diff --git a/vmpp/Config.openbsd.x86.64 b/vmpp/Config.openbsd.x86.64 new file mode 100644 index 0000000000..081c9f39dd --- /dev/null +++ b/vmpp/Config.openbsd.x86.64 @@ -0,0 +1,2 @@ +include vmpp/Config.openbsd +include vmpp/Config.x86.64 diff --git a/vmpp/Config.ppc b/vmpp/Config.ppc new file mode 100644 index 0000000000..1a460e3779 --- /dev/null +++ b/vmpp/Config.ppc @@ -0,0 +1 @@ +PLAF_DLL_OBJS += vmpp/cpu-ppc.o diff --git a/vmpp/Config.solaris b/vmpp/Config.solaris new file mode 100644 index 0000000000..732814c65c --- /dev/null +++ b/vmpp/Config.solaris @@ -0,0 +1,6 @@ +include vmpp/Config.unix +PLAF_DLL_OBJS += vmpp/os-genunix.o vm/os-solaris.o +CFLAGS += -D_STDC_C99 -Drestrict="" -export-dynamic +LIBS += -ldl -lsocket -lnsl -lm -R/opt/PM/lib -R/opt/csw/lib \ + -R/usr/local/lib -R/usr/sfw/lib -R/usr/X11R6/lib \ + -R/opt/sfw/lib $(X11_UI_LIBS) diff --git a/vmpp/Config.solaris.x86.32 b/vmpp/Config.solaris.x86.32 new file mode 100644 index 0000000000..e7371d0963 --- /dev/null +++ b/vmpp/Config.solaris.x86.32 @@ -0,0 +1,2 @@ +include vmpp/Config.solaris +include vmpp/Config.x86.32 diff --git a/vmpp/Config.solaris.x86.64 b/vmpp/Config.solaris.x86.64 new file mode 100644 index 0000000000..8eae9fee26 --- /dev/null +++ b/vmpp/Config.solaris.x86.64 @@ -0,0 +1,2 @@ +include vmpp/Config.solaris +include vmpp/Config.x86.64 diff --git a/vmpp/Config.unix b/vmpp/Config.unix new file mode 100755 index 0000000000..705cfaa03c --- /dev/null +++ b/vmpp/Config.unix @@ -0,0 +1,27 @@ +ifndef DEBUG + CFLAGS += -fomit-frame-pointer +endif + +EXE_SUFFIX = +DLL_PREFIX = lib +DLL_EXTENSION = .a +SHARED_DLL_EXTENSION = .so +SHARED_FLAG = -shared + +PLAF_DLL_OBJS = vmpp/os-unix.o +PLAF_EXE_OBJS += vmpp/main-unix.o + +ifdef NO_UI + X11_UI_LIBS = +else + X11_UI_LIBS = -lpango-1.0 -lpangocairo-1.0 -lcairo -lglib-2.0 -lgobject-2.0 -lGL -lX11 +endif + +# CFLAGS += -fPIC +FFI_TEST_CFLAGS = -fPIC + +# LINKER = gcc -shared -o +# LINK_WITH_ENGINE = '-Wl,-rpath,$$ORIGIN' -lfactor + +LINKER = $(AR) rcs +LINK_WITH_ENGINE = -Wl,--whole-archive -lfactor -Wl,-no-whole-archive diff --git a/vmpp/Config.windows b/vmpp/Config.windows new file mode 100644 index 0000000000..2ba6e7d479 --- /dev/null +++ b/vmpp/Config.windows @@ -0,0 +1,10 @@ +CFLAGS += -DWINDOWS -mno-cygwin +LIBS = -lm +PLAF_DLL_OBJS += vmpp/os-windows.o +SHARED_FLAG = -shared +EXE_EXTENSION=.exe +CONSOLE_EXTENSION=.com +DLL_EXTENSION=.dll +SHARED_DLL_EXTENSION=.dll +LINKER = $(CC) -shared -mno-cygwin -o +LINK_WITH_ENGINE = -l$(DLL_PREFIX)factor$(DLL_SUFFIX) diff --git a/vmpp/Config.windows.ce b/vmpp/Config.windows.ce new file mode 100644 index 0000000000..36f6918fb7 --- /dev/null +++ b/vmpp/Config.windows.ce @@ -0,0 +1,5 @@ +CFLAGS += -DWINCE +LIBS = -lm +PLAF_DLL_OBJS += vmpp/os-windows-ce.o +PLAF_EXE_OBJS += vmpp/main-windows-ce.o +include vmpp/Config.windows diff --git a/vmpp/Config.windows.ce.arm b/vmpp/Config.windows.ce.arm new file mode 100755 index 0000000000..d757e316bc --- /dev/null +++ b/vmpp/Config.windows.ce.arm @@ -0,0 +1,4 @@ +CC = arm-wince-mingw32ce-gcc +DLL_SUFFIX=-ce +EXE_SUFFIX=-ce +include vmpp/Config.windows.ce vm/Config.arm diff --git a/vmpp/Config.windows.nt b/vmpp/Config.windows.nt new file mode 100644 index 0000000000..88fd89c630 --- /dev/null +++ b/vmpp/Config.windows.nt @@ -0,0 +1,10 @@ +LIBS = -lm +EXE_SUFFIX= +DLL_SUFFIX= +PLAF_DLL_OBJS += vmpp/os-windows-nt.o +PLAF_EXE_OBJS += vmpp/resources.o +PLAF_EXE_OBJS += vmpp/main-windows-nt.o +CFLAGS += -mwindows +CFLAGS_CONSOLE += -mconsole +CONSOLE_EXTENSION = .com +include vmpp/Config.windows diff --git a/vmpp/Config.windows.nt.x86.32 b/vmpp/Config.windows.nt.x86.32 new file mode 100644 index 0000000000..9640d5103c --- /dev/null +++ b/vmpp/Config.windows.nt.x86.32 @@ -0,0 +1,4 @@ +DLL_PATH=http://factorcode.org/dlls +WINDRES=windres +include vmpp/Config.windows.nt +include vmpp/Config.x86.32 diff --git a/vmpp/Config.windows.nt.x86.64 b/vmpp/Config.windows.nt.x86.64 new file mode 100644 index 0000000000..6c34a3cf49 --- /dev/null +++ b/vmpp/Config.windows.nt.x86.64 @@ -0,0 +1,6 @@ +#error "lol" +DLL_PATH=http://factorcode.org/dlls/64 +CC=$(WIN64_PATH)-gcc.exe +WINDRES=$(WIN64_PATH)-windres.exe +include vmpp/Config.windows.nt +include vmpp/Config.x86.64 diff --git a/vmpp/Config.x86.32 b/vmpp/Config.x86.32 new file mode 100644 index 0000000000..ae2326372d --- /dev/null +++ b/vmpp/Config.x86.32 @@ -0,0 +1,5 @@ +BOOT_ARCH = x86 +PLAF_DLL_OBJS += vmpp/cpu-x86.32.o + +# gcc bug workaround +CFLAGS += -fno-builtin-strlen -fno-builtin-strcat diff --git a/vmpp/Config.x86.64 b/vmpp/Config.x86.64 new file mode 100644 index 0000000000..34e3751969 --- /dev/null +++ b/vmpp/Config.x86.64 @@ -0,0 +1,2 @@ +PLAF_DLL_OBJS += vmpp/cpu-x86.64.o +CFLAGS += -DFACTOR_64 diff --git a/vmpp/alien.cpp b/vmpp/alien.cpp new file mode 100755 index 0000000000..d55ea75b0d --- /dev/null +++ b/vmpp/alien.cpp @@ -0,0 +1,234 @@ +#include "master.hpp" + +/* gets the address of an object representing a C pointer */ +char *alien_offset(CELL object) +{ + F_ALIEN *alien; + F_BYTE_ARRAY *byte_array; + + switch(type_of(object)) + { + case BYTE_ARRAY_TYPE: + byte_array = untag_byte_array_fast(object); + return (char *)(byte_array + 1); + case ALIEN_TYPE: + alien = untag_alien_fast(object); + if(alien->expired != F) + general_error(ERROR_EXPIRED,object,F,NULL); + return alien_offset(alien->alien) + alien->displacement; + case F_TYPE: + return NULL; + default: + type_error(ALIEN_TYPE,object); + return NULL; /* can't happen */ + } +} + +/* gets the address of an object representing a C pointer, with the +intention of storing the pointer across code which may potentially GC. */ +char *pinned_alien_offset(CELL object) +{ + F_ALIEN *alien; + + switch(type_of(object)) + { + case ALIEN_TYPE: + alien = untag_alien_fast(object); + if(alien->expired != F) + general_error(ERROR_EXPIRED,object,F,NULL); + return pinned_alien_offset(alien->alien) + alien->displacement; + case F_TYPE: + return NULL; + default: + type_error(ALIEN_TYPE,object); + return NULL; /* can't happen */ + } +} + +/* pop an object representing a C pointer */ +char *unbox_alien(void) +{ + return alien_offset(dpop()); +} + +/* make an alien */ +CELL allot_alien(CELL delegate, CELL displacement) +{ + REGISTER_ROOT(delegate); + F_ALIEN *alien = (F_ALIEN *)allot_object(ALIEN_TYPE,sizeof(F_ALIEN)); + UNREGISTER_ROOT(delegate); + + if(type_of(delegate) == ALIEN_TYPE) + { + F_ALIEN *delegate_alien = untag_alien_fast(delegate); + displacement += delegate_alien->displacement; + alien->alien = delegate_alien->alien; + } + else + alien->alien = delegate; + + alien->displacement = displacement; + alien->expired = F; + return tag_object(alien); +} + +/* make an alien and push */ +void box_alien(void *ptr) +{ + if(ptr == NULL) + dpush(F); + else + dpush(allot_alien(F,(CELL)ptr)); +} + +/* make an alien pointing at an offset of another alien */ +void primitive_displaced_alien(void) +{ + CELL alien = dpop(); + CELL displacement = to_cell(dpop()); + + if(alien == F && displacement == 0) + dpush(F); + else + { + switch(type_of(alien)) + { + case BYTE_ARRAY_TYPE: + case ALIEN_TYPE: + case F_TYPE: + dpush(allot_alien(alien,displacement)); + break; + default: + type_error(ALIEN_TYPE,alien); + break; + } + } +} + +/* address of an object representing a C pointer. Explicitly throw an error +if the object is a byte array, as a sanity check. */ +void primitive_alien_address(void) +{ + box_unsigned_cell((CELL)pinned_alien_offset(dpop())); +} + +/* pop ( alien n ) from datastack, return alien's address plus n */ +INLINE void *alien_pointer(void) +{ + F_FIXNUM offset = to_fixnum(dpop()); + return unbox_alien() + offset; +} + +/* define words to read/write values at an alien address */ +#define DEFINE_ALIEN_ACCESSOR(name,type,boxer,to) \ + void primitive_alien_##name(void) \ + { \ + boxer(*(type*)alien_pointer()); \ + } \ + void primitive_set_alien_##name(void) \ + { \ + type *ptr = (type *)alien_pointer(); \ + type value = to(dpop()); \ + *ptr = value; \ + } + +DEFINE_ALIEN_ACCESSOR(signed_cell,F_FIXNUM,box_signed_cell,to_fixnum) +DEFINE_ALIEN_ACCESSOR(unsigned_cell,CELL,box_unsigned_cell,to_cell) +DEFINE_ALIEN_ACCESSOR(signed_8,s64,box_signed_8,to_signed_8) +DEFINE_ALIEN_ACCESSOR(unsigned_8,u64,box_unsigned_8,to_unsigned_8) +DEFINE_ALIEN_ACCESSOR(signed_4,s32,box_signed_4,to_fixnum) +DEFINE_ALIEN_ACCESSOR(unsigned_4,u32,box_unsigned_4,to_cell) +DEFINE_ALIEN_ACCESSOR(signed_2,s16,box_signed_2,to_fixnum) +DEFINE_ALIEN_ACCESSOR(unsigned_2,u16,box_unsigned_2,to_cell) +DEFINE_ALIEN_ACCESSOR(signed_1,s8,box_signed_1,to_fixnum) +DEFINE_ALIEN_ACCESSOR(unsigned_1,u8,box_unsigned_1,to_cell) +DEFINE_ALIEN_ACCESSOR(float,float,box_float,to_float) +DEFINE_ALIEN_ACCESSOR(double,double,box_double,to_double) +DEFINE_ALIEN_ACCESSOR(cell,void *,box_alien,pinned_alien_offset) + +/* for FFI calls passing structs by value */ +void to_value_struct(CELL src, void *dest, CELL size) +{ + memcpy(dest,alien_offset(src),size); +} + +/* for FFI callbacks receiving structs by value */ +void box_value_struct(void *src, CELL size) +{ + F_BYTE_ARRAY *array = allot_byte_array(size); + memcpy(array + 1,src,size); + dpush(tag_object(array)); +} + +/* On some x86 OSes, structs <= 8 bytes are returned in registers. */ +void box_small_struct(CELL x, CELL y, CELL size) +{ + CELL data[2]; + data[0] = x; + data[1] = y; + box_value_struct(data,size); +} + +/* On OS X/PPC, complex numbers are returned in registers. */ +void box_medium_struct(CELL x1, CELL x2, CELL x3, CELL x4, CELL size) +{ + CELL data[4]; + data[0] = x1; + data[1] = x2; + data[2] = x3; + data[3] = x4; + box_value_struct(data,size); +} + +/* open a native library and push a handle */ +void primitive_dlopen(void) +{ + CELL path = tag_object(string_to_native_alien( + untag_string(dpop()))); + REGISTER_ROOT(path); + F_DLL *dll = (F_DLL *)allot_object(DLL_TYPE,sizeof(F_DLL)); + UNREGISTER_ROOT(path); + dll->path = path; + ffi_dlopen(dll); + dpush(tag_object(dll)); +} + +/* look up a symbol in a native library */ +void primitive_dlsym(void) +{ + CELL dll = dpop(); + REGISTER_ROOT(dll); + F_SYMBOL *sym = unbox_symbol_string(); + UNREGISTER_ROOT(dll); + + F_DLL *d; + + if(dll == F) + box_alien(ffi_dlsym(NULL,sym)); + else + { + d = untag_dll(dll); + if(d->dll == NULL) + dpush(F); + else + box_alien(ffi_dlsym(d,sym)); + } +} + +/* close a native library handle */ +void primitive_dlclose(void) +{ + ffi_dlclose(untag_dll(dpop())); +} + +void primitive_dll_validp(void) +{ + CELL dll = dpop(); + if(dll == F) + dpush(T); + else + { + F_DLL *d = untag_dll(dll); + dpush(d->dll == NULL ? F : T); + } +} diff --git a/vmpp/alien.hpp b/vmpp/alien.hpp new file mode 100755 index 0000000000..6f822aea83 --- /dev/null +++ b/vmpp/alien.hpp @@ -0,0 +1,50 @@ +DEFINE_UNTAG(F_ALIEN,ALIEN_TYPE,alien) + +CELL allot_alien(CELL delegate, CELL displacement); + +void primitive_displaced_alien(void); +void primitive_alien_address(void); + +DLLEXPORT char *alien_offset(CELL object); + +DLLEXPORT char *unbox_alien(void); +DLLEXPORT void box_alien(void *ptr); + +void primitive_alien_signed_cell(void); +void primitive_set_alien_signed_cell(void); +void primitive_alien_unsigned_cell(void); +void primitive_set_alien_unsigned_cell(void); +void primitive_alien_signed_8(void); +void primitive_set_alien_signed_8(void); +void primitive_alien_unsigned_8(void); +void primitive_set_alien_unsigned_8(void); +void primitive_alien_signed_4(void); +void primitive_set_alien_signed_4(void); +void primitive_alien_unsigned_4(void); +void primitive_set_alien_unsigned_4(void); +void primitive_alien_signed_2(void); +void primitive_set_alien_signed_2(void); +void primitive_alien_unsigned_2(void); +void primitive_set_alien_unsigned_2(void); +void primitive_alien_signed_1(void); +void primitive_set_alien_signed_1(void); +void primitive_alien_unsigned_1(void); +void primitive_set_alien_unsigned_1(void); +void primitive_alien_float(void); +void primitive_set_alien_float(void); +void primitive_alien_double(void); +void primitive_set_alien_double(void); +void primitive_alien_cell(void); +void primitive_set_alien_cell(void); + +DLLEXPORT void to_value_struct(CELL src, void *dest, CELL size); +DLLEXPORT void box_value_struct(void *src, CELL size); +DLLEXPORT void box_small_struct(CELL x, CELL y, CELL size); +void box_medium_struct(CELL x1, CELL x2, CELL x3, CELL x4, CELL size); + +DEFINE_UNTAG(F_DLL,DLL_TYPE,dll) + +void primitive_dlopen(void); +void primitive_dlsym(void); +void primitive_dlclose(void); +void primitive_dll_validp(void); diff --git a/vmpp/arrays.cpp b/vmpp/arrays.cpp new file mode 100644 index 0000000000..0bddf04f97 --- /dev/null +++ b/vmpp/arrays.cpp @@ -0,0 +1,159 @@ +#include "master.hpp" + +/* the array is full of undefined data, and must be correctly filled before the +next GC. size is in cells */ +F_ARRAY *allot_array_internal(CELL type, CELL capacity) +{ + F_ARRAY *array = (F_ARRAY *)allot_object(type,array_size(capacity)); + array->capacity = tag_fixnum(capacity); + return array; +} + +/* make a new array with an initial element */ +F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill) +{ + REGISTER_ROOT(fill); + F_ARRAY* array = allot_array_internal(type, capacity); + UNREGISTER_ROOT(fill); + if(fill == 0) + memset((void*)AREF(array,0),'\0',capacity * CELLS); + else + { + /* No need for write barrier here. Either the object is in + the nursery, or it was allocated directly in tenured space + and the write barrier is already hit for us in that case. */ + CELL i; + for(i = 0; i < capacity; i++) + put(AREF(array,i),fill); + } + return array; +} + +/* push a new array on the stack */ +void primitive_array(void) +{ + CELL initial = dpop(); + CELL size = unbox_array_size(); + dpush(tag_array(allot_array(ARRAY_TYPE,size,initial))); +} + +CELL allot_array_1(CELL obj) +{ + REGISTER_ROOT(obj); + F_ARRAY *a = allot_array_internal(ARRAY_TYPE,1); + UNREGISTER_ROOT(obj); + set_array_nth(a,0,obj); + return tag_array(a); +} + +CELL allot_array_2(CELL v1, CELL v2) +{ + REGISTER_ROOT(v1); + REGISTER_ROOT(v2); + F_ARRAY *a = allot_array_internal(ARRAY_TYPE,2); + UNREGISTER_ROOT(v2); + UNREGISTER_ROOT(v1); + set_array_nth(a,0,v1); + set_array_nth(a,1,v2); + return tag_array(a); +} + +CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4) +{ + REGISTER_ROOT(v1); + REGISTER_ROOT(v2); + REGISTER_ROOT(v3); + REGISTER_ROOT(v4); + F_ARRAY *a = allot_array_internal(ARRAY_TYPE,4); + UNREGISTER_ROOT(v4); + UNREGISTER_ROOT(v3); + UNREGISTER_ROOT(v2); + UNREGISTER_ROOT(v1); + set_array_nth(a,0,v1); + set_array_nth(a,1,v2); + set_array_nth(a,2,v3); + set_array_nth(a,3,v4); + return tag_array(a); +} + +static bool reallot_array_in_place_p(F_ARRAY *array, CELL capacity) +{ + return in_zone(&nursery,(CELL)array) && capacity <= array_capacity(array); +} + +F_ARRAY *reallot_array(F_ARRAY *array, CELL capacity) +{ +#ifdef FACTOR_DEBUG + CELL header = untag_header(array->header); + assert(header == ARRAY_TYPE || header == BIGNUM_TYPE); +#endif + + if(reallot_array_in_place_p(array,capacity)) + { + array->capacity = tag_fixnum(capacity); + return array; + } + else + { + CELL to_copy = array_capacity(array); + if(capacity < to_copy) + to_copy = capacity; + + REGISTER_UNTAGGED(array); + F_ARRAY* new_array = allot_array_internal(untag_header(array->header),capacity); + UNREGISTER_UNTAGGED(F_ARRAY,array); + + memcpy(new_array + 1,array + 1,to_copy * CELLS); + memset((char *)AREF(new_array,to_copy),'\0',(capacity - to_copy) * CELLS); + + return new_array; + } +} + +void primitive_resize_array(void) +{ + F_ARRAY* array = untag_array(dpop()); + CELL capacity = unbox_array_size(); + dpush(tag_array(reallot_array(array,capacity))); +} + +void growable_array_add(F_GROWABLE_ARRAY *array, CELL elt) +{ + F_ARRAY *underlying = untag_array_fast(array->array); + REGISTER_ROOT(elt); + + if(array->count == array_capacity(underlying)) + { + underlying = reallot_array(underlying,array->count * 2); + array->array = tag_array(underlying); + } + + UNREGISTER_ROOT(elt); + set_array_nth(underlying,array->count++,elt); +} + +void growable_array_append(F_GROWABLE_ARRAY *array, F_ARRAY *elts) +{ + REGISTER_UNTAGGED(elts); + + F_ARRAY *underlying = untag_array_fast(array->array); + + CELL elts_size = array_capacity(elts); + CELL new_size = array->count + elts_size; + + if(new_size >= array_capacity(underlying)) + { + underlying = reallot_array(underlying,new_size * 2); + array->array = tag_array(underlying); + } + + UNREGISTER_UNTAGGED(F_ARRAY,elts); + + write_barrier(array->array); + + memcpy((void *)AREF(underlying,array->count), + (void *)AREF(elts,0), + elts_size * CELLS); + + array->count += elts_size; +} diff --git a/vmpp/arrays.hpp b/vmpp/arrays.hpp new file mode 100644 index 0000000000..6fe8a5464c --- /dev/null +++ b/vmpp/arrays.hpp @@ -0,0 +1,64 @@ +DEFINE_UNTAG(F_ARRAY,ARRAY_TYPE,array) + +INLINE CELL tag_array(F_ARRAY *array) +{ + return RETAG(array,ARRAY_TYPE); +} + +/* Inline functions */ +INLINE CELL array_size(CELL size) +{ + return sizeof(F_ARRAY) + size * CELLS; +} + +F_ARRAY *allot_array_internal(CELL type, CELL capacity); +F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill); +F_BYTE_ARRAY *allot_byte_array(CELL size); + +CELL allot_array_1(CELL obj); +CELL allot_array_2(CELL v1, CELL v2); +CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4); + +void primitive_array(void); + +F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity); +void primitive_resize_array(void); + +/* Macros to simulate a vector in C */ +typedef struct { + CELL count; + CELL array; +} F_GROWABLE_ARRAY; + +/* Allocates memory */ +INLINE F_GROWABLE_ARRAY make_growable_array(void) +{ + F_GROWABLE_ARRAY result; + result.count = 0; + result.array = tag_array(allot_array(ARRAY_TYPE,2,F)); + return result; +} + +#define GROWABLE_ARRAY(result) F_GROWABLE_ARRAY result##_g = make_growable_array(); \ + REGISTER_ROOT(result##_g.array) + +void growable_array_add(F_GROWABLE_ARRAY *result, CELL elt); + +#define GROWABLE_ARRAY_ADD(result,elt) \ + growable_array_add(&result##_g,elt) + +void growable_array_append(F_GROWABLE_ARRAY *result, F_ARRAY *elts); + +#define GROWABLE_ARRAY_APPEND(result,elts) \ + growable_array_append(&result##_g,elts) + +INLINE void growable_array_trim(F_GROWABLE_ARRAY *array) +{ + array->array = tag_array(reallot_array(untag_array_fast(array->array),array->count)); +} + +#define GROWABLE_ARRAY_TRIM(result) growable_array_trim(&result##_g) + +#define GROWABLE_ARRAY_DONE(result) \ + UNREGISTER_ROOT(result##_g.array); \ + CELL result = result##_g.array; diff --git a/vmpp/asm.h b/vmpp/asm.h new file mode 100644 index 0000000000..9719ae8af0 --- /dev/null +++ b/vmpp/asm.h @@ -0,0 +1,16 @@ +#if defined(__APPLE__) || (defined(WINDOWS) && !defined(__arm__)) + #define MANGLE(sym) _##sym +#else + #define MANGLE(sym) sym +#endif + +/* Apple's PPC assembler is out of date? */ +#if defined(__APPLE__) && defined(__ppc__) + #define XX @ +#else + #define XX ; +#endif + +/* The returns and args are just for documentation */ +#define DEF(returns,symbol,args) .globl MANGLE(symbol) XX \ +MANGLE(symbol) diff --git a/vmpp/bignum.cpp b/vmpp/bignum.cpp new file mode 100755 index 0000000000..b431b6be88 --- /dev/null +++ b/vmpp/bignum.cpp @@ -0,0 +1,1881 @@ +/* :tabSize=2:indentSize=2:noTabs=true: + +Copyright (C) 1989-94 Massachusetts Institute of Technology +Portions copyright (C) 2004-2008 Slava Pestov + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy and modify this software, to +redistribute either the original software or a modified version, and +to use this software for any purpose is granted, subject to the +following restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. */ + +/* Changes for Scheme 48: + * - Converted to ANSI. + * - Added bitwise operations. + * - Added s48 to the beginning of all externally visible names. + * - Cached the bignum representations of -1, 0, and 1. + */ + +/* Changes for Factor: + * - Adapt bignumint.h for Factor memory manager + * - Add more bignum <-> C type conversions + * - Remove unused functions + * - Add local variable GC root recording + * - Remove s48 prefix from function names + * - Various fixes for Win64 + */ + +#include "master.hpp" + +#include + +#include +#include + +/* Exports */ + +int +bignum_equal_p(bignum_type x, bignum_type y) +{ + return + ((BIGNUM_ZERO_P (x)) + ? (BIGNUM_ZERO_P (y)) + : ((! (BIGNUM_ZERO_P (y))) + && ((BIGNUM_NEGATIVE_P (x)) + ? (BIGNUM_NEGATIVE_P (y)) + : (! (BIGNUM_NEGATIVE_P (y)))) + && (bignum_equal_p_unsigned (x, y)))); +} + +enum bignum_comparison +bignum_compare(bignum_type x, bignum_type y) +{ + return + ((BIGNUM_ZERO_P (x)) + ? ((BIGNUM_ZERO_P (y)) + ? bignum_comparison_equal + : (BIGNUM_NEGATIVE_P (y)) + ? bignum_comparison_greater + : bignum_comparison_less) + : (BIGNUM_ZERO_P (y)) + ? ((BIGNUM_NEGATIVE_P (x)) + ? bignum_comparison_less + : bignum_comparison_greater) + : (BIGNUM_NEGATIVE_P (x)) + ? ((BIGNUM_NEGATIVE_P (y)) + ? (bignum_compare_unsigned (y, x)) + : (bignum_comparison_less)) + : ((BIGNUM_NEGATIVE_P (y)) + ? (bignum_comparison_greater) + : (bignum_compare_unsigned (x, y)))); +} + +/* allocates memory */ +bignum_type +bignum_add(bignum_type x, bignum_type y) +{ + return + ((BIGNUM_ZERO_P (x)) + ? (y) + : (BIGNUM_ZERO_P (y)) + ? (x) + : ((BIGNUM_NEGATIVE_P (x)) + ? ((BIGNUM_NEGATIVE_P (y)) + ? (bignum_add_unsigned (x, y, 1)) + : (bignum_subtract_unsigned (y, x))) + : ((BIGNUM_NEGATIVE_P (y)) + ? (bignum_subtract_unsigned (x, y)) + : (bignum_add_unsigned (x, y, 0))))); +} + +/* allocates memory */ +bignum_type +bignum_subtract(bignum_type x, bignum_type y) +{ + return + ((BIGNUM_ZERO_P (x)) + ? ((BIGNUM_ZERO_P (y)) + ? (y) + : (bignum_new_sign (y, (! (BIGNUM_NEGATIVE_P (y)))))) + : ((BIGNUM_ZERO_P (y)) + ? (x) + : ((BIGNUM_NEGATIVE_P (x)) + ? ((BIGNUM_NEGATIVE_P (y)) + ? (bignum_subtract_unsigned (y, x)) + : (bignum_add_unsigned (x, y, 1))) + : ((BIGNUM_NEGATIVE_P (y)) + ? (bignum_add_unsigned (x, y, 0)) + : (bignum_subtract_unsigned (x, y)))))); +} + +/* allocates memory */ +bignum_type +bignum_multiply(bignum_type x, bignum_type y) +{ + bignum_length_type x_length = (BIGNUM_LENGTH (x)); + bignum_length_type y_length = (BIGNUM_LENGTH (y)); + int negative_p = + ((BIGNUM_NEGATIVE_P (x)) + ? (! (BIGNUM_NEGATIVE_P (y))) + : (BIGNUM_NEGATIVE_P (y))); + if (BIGNUM_ZERO_P (x)) + return (x); + if (BIGNUM_ZERO_P (y)) + return (y); + if (x_length == 1) + { + bignum_digit_type digit = (BIGNUM_REF (x, 0)); + if (digit == 1) + return (bignum_maybe_new_sign (y, negative_p)); + if (digit < BIGNUM_RADIX_ROOT) + return (bignum_multiply_unsigned_small_factor (y, digit, negative_p)); + } + if (y_length == 1) + { + bignum_digit_type digit = (BIGNUM_REF (y, 0)); + if (digit == 1) + return (bignum_maybe_new_sign (x, negative_p)); + if (digit < BIGNUM_RADIX_ROOT) + return (bignum_multiply_unsigned_small_factor (x, digit, negative_p)); + } + return (bignum_multiply_unsigned (x, y, negative_p)); +} + +/* allocates memory */ +void +bignum_divide(bignum_type numerator, bignum_type denominator, + bignum_type * quotient, bignum_type * remainder) +{ + if (BIGNUM_ZERO_P (denominator)) + { + divide_by_zero_error(); + return; + } + if (BIGNUM_ZERO_P (numerator)) + { + (*quotient) = numerator; + (*remainder) = numerator; + } + else + { + int r_negative_p = (BIGNUM_NEGATIVE_P (numerator)); + int q_negative_p = + ((BIGNUM_NEGATIVE_P (denominator)) ? (! r_negative_p) : r_negative_p); + switch (bignum_compare_unsigned (numerator, denominator)) + { + case bignum_comparison_equal: + { + (*quotient) = (BIGNUM_ONE (q_negative_p)); + (*remainder) = (BIGNUM_ZERO ()); + break; + } + case bignum_comparison_less: + { + (*quotient) = (BIGNUM_ZERO ()); + (*remainder) = numerator; + break; + } + case bignum_comparison_greater: + { + if ((BIGNUM_LENGTH (denominator)) == 1) + { + bignum_digit_type digit = (BIGNUM_REF (denominator, 0)); + if (digit == 1) + { + (*quotient) = + (bignum_maybe_new_sign (numerator, q_negative_p)); + (*remainder) = (BIGNUM_ZERO ()); + break; + } + else if (digit < BIGNUM_RADIX_ROOT) + { + bignum_divide_unsigned_small_denominator + (numerator, digit, + quotient, remainder, + q_negative_p, r_negative_p); + break; + } + else + { + bignum_divide_unsigned_medium_denominator + (numerator, digit, + quotient, remainder, + q_negative_p, r_negative_p); + break; + } + } + bignum_divide_unsigned_large_denominator + (numerator, denominator, + quotient, remainder, + q_negative_p, r_negative_p); + break; + } + } + } +} + +/* allocates memory */ +bignum_type +bignum_quotient(bignum_type numerator, bignum_type denominator) +{ + if (BIGNUM_ZERO_P (denominator)) + { + divide_by_zero_error(); + return (BIGNUM_OUT_OF_BAND); + } + if (BIGNUM_ZERO_P (numerator)) + return numerator; + { + int q_negative_p = + ((BIGNUM_NEGATIVE_P (denominator)) + ? (! (BIGNUM_NEGATIVE_P (numerator))) + : (BIGNUM_NEGATIVE_P (numerator))); + switch (bignum_compare_unsigned (numerator, denominator)) + { + case bignum_comparison_equal: + return (BIGNUM_ONE (q_negative_p)); + case bignum_comparison_less: + return (BIGNUM_ZERO ()); + case bignum_comparison_greater: + default: /* to appease gcc -Wall */ + { + bignum_type quotient; + if ((BIGNUM_LENGTH (denominator)) == 1) + { + bignum_digit_type digit = (BIGNUM_REF (denominator, 0)); + if (digit == 1) + return (bignum_maybe_new_sign (numerator, q_negative_p)); + if (digit < BIGNUM_RADIX_ROOT) + bignum_divide_unsigned_small_denominator + (numerator, digit, + ("ient), ((bignum_type *) 0), + q_negative_p, 0); + else + bignum_divide_unsigned_medium_denominator + (numerator, digit, + ("ient), ((bignum_type *) 0), + q_negative_p, 0); + } + else + bignum_divide_unsigned_large_denominator + (numerator, denominator, + ("ient), ((bignum_type *) 0), + q_negative_p, 0); + return (quotient); + } + } + } +} + +/* allocates memory */ +bignum_type +bignum_remainder(bignum_type numerator, bignum_type denominator) +{ + if (BIGNUM_ZERO_P (denominator)) + { + divide_by_zero_error(); + return (BIGNUM_OUT_OF_BAND); + } + if (BIGNUM_ZERO_P (numerator)) + return numerator; + switch (bignum_compare_unsigned (numerator, denominator)) + { + case bignum_comparison_equal: + return (BIGNUM_ZERO ()); + case bignum_comparison_less: + return numerator; + case bignum_comparison_greater: + default: /* to appease gcc -Wall */ + { + bignum_type remainder; + if ((BIGNUM_LENGTH (denominator)) == 1) + { + bignum_digit_type digit = (BIGNUM_REF (denominator, 0)); + if (digit == 1) + return (BIGNUM_ZERO ()); + if (digit < BIGNUM_RADIX_ROOT) + return + (bignum_remainder_unsigned_small_denominator + (numerator, digit, (BIGNUM_NEGATIVE_P (numerator)))); + bignum_divide_unsigned_medium_denominator + (numerator, digit, + ((bignum_type *) 0), (&remainder), + 0, (BIGNUM_NEGATIVE_P (numerator))); + } + else + bignum_divide_unsigned_large_denominator + (numerator, denominator, + ((bignum_type *) 0), (&remainder), + 0, (BIGNUM_NEGATIVE_P (numerator))); + return (remainder); + } + } +} + +#define FOO_TO_BIGNUM(name,type,utype) \ + bignum_type name##_to_bignum(type n) \ + { \ + int negative_p; \ + bignum_digit_type result_digits [BIGNUM_DIGITS_FOR(type)]; \ + bignum_digit_type * end_digits = result_digits; \ + /* Special cases win when these small constants are cached. */ \ + if (n == 0) return (BIGNUM_ZERO ()); \ + if (n == 1) return (BIGNUM_ONE (0)); \ + if (n < (type)0 && n == (type)-1) return (BIGNUM_ONE (1)); \ + { \ + utype accumulator = ((negative_p = (n < (utype)0)) ? (-n) : n); \ + do \ + { \ + (*end_digits++) = (accumulator & BIGNUM_DIGIT_MASK); \ + accumulator >>= BIGNUM_DIGIT_LENGTH; \ + } \ + while (accumulator != 0); \ + } \ + { \ + bignum_type result = \ + (allot_bignum ((end_digits - result_digits), negative_p)); \ + bignum_digit_type * scan_digits = result_digits; \ + bignum_digit_type * scan_result = (BIGNUM_START_PTR (result)); \ + while (scan_digits < end_digits) \ + (*scan_result++) = (*scan_digits++); \ + return (result); \ + } \ + } + +/* all below allocate memory */ +FOO_TO_BIGNUM(cell,CELL,CELL) +FOO_TO_BIGNUM(fixnum,F_FIXNUM,CELL) +FOO_TO_BIGNUM(long_long,s64,u64) +FOO_TO_BIGNUM(ulong_long,u64,u64) + +#define BIGNUM_TO_FOO(name,type,utype) \ + type bignum_to_##name(bignum_type bignum) \ + { \ + if (BIGNUM_ZERO_P (bignum)) \ + return (0); \ + { \ + utype accumulator = 0; \ + bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); \ + bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); \ + while (start < scan) \ + accumulator = ((accumulator << BIGNUM_DIGIT_LENGTH) + (*--scan)); \ + return ((BIGNUM_NEGATIVE_P (bignum)) ? (-((type)accumulator)) : accumulator); \ + } \ + } + +/* all of the below allocate memory */ +BIGNUM_TO_FOO(cell,CELL,CELL); +BIGNUM_TO_FOO(fixnum,F_FIXNUM,CELL); +BIGNUM_TO_FOO(long_long,s64,u64) +BIGNUM_TO_FOO(ulong_long,u64,u64) + +double +bignum_to_double(bignum_type bignum) +{ + if (BIGNUM_ZERO_P (bignum)) + return (0); + { + double accumulator = 0; + bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); + bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); + while (start < scan) + accumulator = ((accumulator * BIGNUM_RADIX) + (*--scan)); + return ((BIGNUM_NEGATIVE_P (bignum)) ? (-accumulator) : accumulator); + } +} + +#define DTB_WRITE_DIGIT(factor) \ +{ \ + significand *= (factor); \ + digit = ((bignum_digit_type) significand); \ + (*--scan) = digit; \ + significand -= ((double) digit); \ +} + +/* allocates memory */ +#define inf std::numeric_limits::infinity() + +bignum_type +double_to_bignum(double x) +{ + if (x == inf || x == -inf || x != x) return (BIGNUM_ZERO ()); + int exponent; + double significand = (frexp (x, (&exponent))); + if (exponent <= 0) return (BIGNUM_ZERO ()); + if (exponent == 1) return (BIGNUM_ONE (x < 0)); + if (significand < 0) significand = (-significand); + { + bignum_length_type length = (BIGNUM_BITS_TO_DIGITS (exponent)); + bignum_type result = (allot_bignum (length, (x < 0))); + bignum_digit_type * start = (BIGNUM_START_PTR (result)); + bignum_digit_type * scan = (start + length); + bignum_digit_type digit; + int odd_bits = (exponent % BIGNUM_DIGIT_LENGTH); + if (odd_bits > 0) + DTB_WRITE_DIGIT ((F_FIXNUM)1 << odd_bits); + while (start < scan) + { + if (significand == 0) + { + while (start < scan) + (*--scan) = 0; + break; + } + DTB_WRITE_DIGIT (BIGNUM_RADIX); + } + return (result); + } +} + +#undef DTB_WRITE_DIGIT + +/* Comparisons */ + +int +bignum_equal_p_unsigned(bignum_type x, bignum_type y) +{ + bignum_length_type length = (BIGNUM_LENGTH (x)); + if (length != (BIGNUM_LENGTH (y))) + return (0); + else + { + bignum_digit_type * scan_x = (BIGNUM_START_PTR (x)); + bignum_digit_type * scan_y = (BIGNUM_START_PTR (y)); + bignum_digit_type * end_x = (scan_x + length); + while (scan_x < end_x) + if ((*scan_x++) != (*scan_y++)) + return (0); + return (1); + } +} + +enum bignum_comparison +bignum_compare_unsigned(bignum_type x, bignum_type y) +{ + bignum_length_type x_length = (BIGNUM_LENGTH (x)); + bignum_length_type y_length = (BIGNUM_LENGTH (y)); + if (x_length < y_length) + return (bignum_comparison_less); + if (x_length > y_length) + return (bignum_comparison_greater); + { + bignum_digit_type * start_x = (BIGNUM_START_PTR (x)); + bignum_digit_type * scan_x = (start_x + x_length); + bignum_digit_type * scan_y = ((BIGNUM_START_PTR (y)) + y_length); + while (start_x < scan_x) + { + bignum_digit_type digit_x = (*--scan_x); + bignum_digit_type digit_y = (*--scan_y); + if (digit_x < digit_y) + return (bignum_comparison_less); + if (digit_x > digit_y) + return (bignum_comparison_greater); + } + } + return (bignum_comparison_equal); +} + +/* Addition */ + +/* allocates memory */ +bignum_type +bignum_add_unsigned(bignum_type x, bignum_type y, int negative_p) +{ + if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x))) + { + bignum_type z = x; + x = y; + y = z; + } + { + bignum_length_type x_length = (BIGNUM_LENGTH (x)); + + REGISTER_BIGNUM(x); + REGISTER_BIGNUM(y); + bignum_type r = (allot_bignum ((x_length + 1), negative_p)); + UNREGISTER_BIGNUM(y); + UNREGISTER_BIGNUM(x); + + bignum_digit_type sum; + bignum_digit_type carry = 0; + bignum_digit_type * scan_x = (BIGNUM_START_PTR (x)); + bignum_digit_type * scan_r = (BIGNUM_START_PTR (r)); + { + bignum_digit_type * scan_y = (BIGNUM_START_PTR (y)); + bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y))); + while (scan_y < end_y) + { + sum = ((*scan_x++) + (*scan_y++) + carry); + if (sum < BIGNUM_RADIX) + { + (*scan_r++) = sum; + carry = 0; + } + else + { + (*scan_r++) = (sum - BIGNUM_RADIX); + carry = 1; + } + } + } + { + bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length); + if (carry != 0) + while (scan_x < end_x) + { + sum = ((*scan_x++) + 1); + if (sum < BIGNUM_RADIX) + { + (*scan_r++) = sum; + carry = 0; + break; + } + else + (*scan_r++) = (sum - BIGNUM_RADIX); + } + while (scan_x < end_x) + (*scan_r++) = (*scan_x++); + } + if (carry != 0) + { + (*scan_r) = 1; + return (r); + } + return (bignum_shorten_length (r, x_length)); + } +} + +/* Subtraction */ + +/* allocates memory */ +bignum_type +bignum_subtract_unsigned(bignum_type x, bignum_type y) +{ + int negative_p = 0; + switch (bignum_compare_unsigned (x, y)) + { + case bignum_comparison_equal: + return (BIGNUM_ZERO ()); + case bignum_comparison_less: + { + bignum_type z = x; + x = y; + y = z; + } + negative_p = 1; + break; + case bignum_comparison_greater: + negative_p = 0; + break; + } + { + bignum_length_type x_length = (BIGNUM_LENGTH (x)); + + REGISTER_BIGNUM(x); + REGISTER_BIGNUM(y); + bignum_type r = (allot_bignum (x_length, negative_p)); + UNREGISTER_BIGNUM(y); + UNREGISTER_BIGNUM(x); + + bignum_digit_type difference; + bignum_digit_type borrow = 0; + bignum_digit_type * scan_x = (BIGNUM_START_PTR (x)); + bignum_digit_type * scan_r = (BIGNUM_START_PTR (r)); + { + bignum_digit_type * scan_y = (BIGNUM_START_PTR (y)); + bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y))); + while (scan_y < end_y) + { + difference = (((*scan_x++) - (*scan_y++)) - borrow); + if (difference < 0) + { + (*scan_r++) = (difference + BIGNUM_RADIX); + borrow = 1; + } + else + { + (*scan_r++) = difference; + borrow = 0; + } + } + } + { + bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length); + if (borrow != 0) + while (scan_x < end_x) + { + difference = ((*scan_x++) - borrow); + if (difference < 0) + (*scan_r++) = (difference + BIGNUM_RADIX); + else + { + (*scan_r++) = difference; + borrow = 0; + break; + } + } + BIGNUM_ASSERT (borrow == 0); + while (scan_x < end_x) + (*scan_r++) = (*scan_x++); + } + return (bignum_trim (r)); + } +} + +/* Multiplication + Maximum value for product_low or product_high: + ((R * R) + (R * (R - 2)) + (R - 1)) + Maximum value for carry: ((R * (R - 1)) + (R - 1)) + where R == BIGNUM_RADIX_ROOT */ + +/* allocates memory */ +bignum_type +bignum_multiply_unsigned(bignum_type x, bignum_type y, int negative_p) +{ + if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x))) + { + bignum_type z = x; + x = y; + y = z; + } + { + bignum_digit_type carry; + bignum_digit_type y_digit_low; + bignum_digit_type y_digit_high; + bignum_digit_type x_digit_low; + bignum_digit_type x_digit_high; + bignum_digit_type product_low; + bignum_digit_type * scan_r; + bignum_digit_type * scan_y; + bignum_length_type x_length = (BIGNUM_LENGTH (x)); + bignum_length_type y_length = (BIGNUM_LENGTH (y)); + + REGISTER_BIGNUM(x); + REGISTER_BIGNUM(y); + bignum_type r = + (allot_bignum_zeroed ((x_length + y_length), negative_p)); + UNREGISTER_BIGNUM(y); + UNREGISTER_BIGNUM(x); + + bignum_digit_type * scan_x = (BIGNUM_START_PTR (x)); + bignum_digit_type * end_x = (scan_x + x_length); + bignum_digit_type * start_y = (BIGNUM_START_PTR (y)); + bignum_digit_type * end_y = (start_y + y_length); + bignum_digit_type * start_r = (BIGNUM_START_PTR (r)); +#define x_digit x_digit_high +#define y_digit y_digit_high +#define product_high carry + while (scan_x < end_x) + { + x_digit = (*scan_x++); + x_digit_low = (HD_LOW (x_digit)); + x_digit_high = (HD_HIGH (x_digit)); + carry = 0; + scan_y = start_y; + scan_r = (start_r++); + while (scan_y < end_y) + { + y_digit = (*scan_y++); + y_digit_low = (HD_LOW (y_digit)); + y_digit_high = (HD_HIGH (y_digit)); + product_low = + ((*scan_r) + + (x_digit_low * y_digit_low) + + (HD_LOW (carry))); + product_high = + ((x_digit_high * y_digit_low) + + (x_digit_low * y_digit_high) + + (HD_HIGH (product_low)) + + (HD_HIGH (carry))); + (*scan_r++) = + (HD_CONS ((HD_LOW (product_high)), (HD_LOW (product_low)))); + carry = + ((x_digit_high * y_digit_high) + + (HD_HIGH (product_high))); + } + (*scan_r) += carry; + } + return (bignum_trim (r)); +#undef x_digit +#undef y_digit +#undef product_high + } +} + +/* allocates memory */ +bignum_type +bignum_multiply_unsigned_small_factor(bignum_type x, bignum_digit_type y, + int negative_p) +{ + bignum_length_type length_x = (BIGNUM_LENGTH (x)); + + REGISTER_BIGNUM(x); + bignum_type p = (allot_bignum ((length_x + 1), negative_p)); + UNREGISTER_BIGNUM(x); + + bignum_destructive_copy (x, p); + (BIGNUM_REF (p, length_x)) = 0; + bignum_destructive_scale_up (p, y); + return (bignum_trim (p)); +} + +void +bignum_destructive_add(bignum_type bignum, bignum_digit_type n) +{ + bignum_digit_type * scan = (BIGNUM_START_PTR (bignum)); + bignum_digit_type digit; + digit = ((*scan) + n); + if (digit < BIGNUM_RADIX) + { + (*scan) = digit; + return; + } + (*scan++) = (digit - BIGNUM_RADIX); + while (1) + { + digit = ((*scan) + 1); + if (digit < BIGNUM_RADIX) + { + (*scan) = digit; + return; + } + (*scan++) = (digit - BIGNUM_RADIX); + } +} + +void +bignum_destructive_scale_up(bignum_type bignum, bignum_digit_type factor) +{ + bignum_digit_type carry = 0; + bignum_digit_type * scan = (BIGNUM_START_PTR (bignum)); + bignum_digit_type two_digits; + bignum_digit_type product_low; +#define product_high carry + bignum_digit_type * end = (scan + (BIGNUM_LENGTH (bignum))); + BIGNUM_ASSERT ((factor > 1) && (factor < BIGNUM_RADIX_ROOT)); + while (scan < end) + { + two_digits = (*scan); + product_low = ((factor * (HD_LOW (two_digits))) + (HD_LOW (carry))); + product_high = + ((factor * (HD_HIGH (two_digits))) + + (HD_HIGH (product_low)) + + (HD_HIGH (carry))); + (*scan++) = (HD_CONS ((HD_LOW (product_high)), (HD_LOW (product_low)))); + carry = (HD_HIGH (product_high)); + } + /* A carry here would be an overflow, i.e. it would not fit. + Hopefully the callers allocate enough space that this will + never happen. + */ + BIGNUM_ASSERT (carry == 0); + return; +#undef product_high +} + +/* Division */ + +/* For help understanding this algorithm, see: + Knuth, Donald E., "The Art of Computer Programming", + volume 2, "Seminumerical Algorithms" + section 4.3.1, "Multiple-Precision Arithmetic". */ + +/* allocates memory */ +void +bignum_divide_unsigned_large_denominator(bignum_type numerator, + bignum_type denominator, + bignum_type * quotient, + bignum_type * remainder, + int q_negative_p, + int r_negative_p) +{ + bignum_length_type length_n = ((BIGNUM_LENGTH (numerator)) + 1); + bignum_length_type length_d = (BIGNUM_LENGTH (denominator)); + + REGISTER_BIGNUM(numerator); + REGISTER_BIGNUM(denominator); + + bignum_type q = + ((quotient != ((bignum_type *) 0)) + ? (allot_bignum ((length_n - length_d), q_negative_p)) + : BIGNUM_OUT_OF_BAND); + + REGISTER_BIGNUM(q); + bignum_type u = (allot_bignum (length_n, r_negative_p)); + UNREGISTER_BIGNUM(q); + + UNREGISTER_BIGNUM(denominator); + UNREGISTER_BIGNUM(numerator); + + int shift = 0; + BIGNUM_ASSERT (length_d > 1); + { + bignum_digit_type v1 = (BIGNUM_REF ((denominator), (length_d - 1))); + while (v1 < (BIGNUM_RADIX / 2)) + { + v1 <<= 1; + shift += 1; + } + } + if (shift == 0) + { + bignum_destructive_copy (numerator, u); + (BIGNUM_REF (u, (length_n - 1))) = 0; + bignum_divide_unsigned_normalized (u, denominator, q); + } + else + { + REGISTER_BIGNUM(numerator); + REGISTER_BIGNUM(denominator); + REGISTER_BIGNUM(u); + REGISTER_BIGNUM(q); + bignum_type v = (allot_bignum (length_d, 0)); + UNREGISTER_BIGNUM(q); + UNREGISTER_BIGNUM(u); + UNREGISTER_BIGNUM(denominator); + UNREGISTER_BIGNUM(numerator); + + bignum_destructive_normalization (numerator, u, shift); + bignum_destructive_normalization (denominator, v, shift); + bignum_divide_unsigned_normalized (u, v, q); + if (remainder != ((bignum_type *) 0)) + bignum_destructive_unnormalization (u, shift); + } + + REGISTER_BIGNUM(u); + if(q) + q = bignum_trim (q); + UNREGISTER_BIGNUM(u); + + REGISTER_BIGNUM(q); + u = bignum_trim (u); + UNREGISTER_BIGNUM(q); + + if (quotient != ((bignum_type *) 0)) + (*quotient) = q; + + if (remainder != ((bignum_type *) 0)) + (*remainder) = u; + + return; +} + +void +bignum_divide_unsigned_normalized(bignum_type u, bignum_type v, bignum_type q) +{ + bignum_length_type u_length = (BIGNUM_LENGTH (u)); + bignum_length_type v_length = (BIGNUM_LENGTH (v)); + bignum_digit_type * u_start = (BIGNUM_START_PTR (u)); + bignum_digit_type * u_scan = (u_start + u_length); + bignum_digit_type * u_scan_limit = (u_start + v_length); + bignum_digit_type * u_scan_start = (u_scan - v_length); + bignum_digit_type * v_start = (BIGNUM_START_PTR (v)); + bignum_digit_type * v_end = (v_start + v_length); + bignum_digit_type * q_scan = NULL; + bignum_digit_type v1 = (v_end[-1]); + bignum_digit_type v2 = (v_end[-2]); + bignum_digit_type ph; /* high half of double-digit product */ + bignum_digit_type pl; /* low half of double-digit product */ + bignum_digit_type guess; + bignum_digit_type gh; /* high half-digit of guess */ + bignum_digit_type ch; /* high half of double-digit comparand */ + bignum_digit_type v2l = (HD_LOW (v2)); + bignum_digit_type v2h = (HD_HIGH (v2)); + bignum_digit_type cl; /* low half of double-digit comparand */ +#define gl ph /* low half-digit of guess */ +#define uj pl +#define qj ph + bignum_digit_type gm; /* memory loc for reference parameter */ + if (q != BIGNUM_OUT_OF_BAND) + q_scan = ((BIGNUM_START_PTR (q)) + (BIGNUM_LENGTH (q))); + while (u_scan_limit < u_scan) + { + uj = (*--u_scan); + if (uj != v1) + { + /* comparand = + (((((uj * BIGNUM_RADIX) + uj1) % v1) * BIGNUM_RADIX) + uj2); + guess = (((uj * BIGNUM_RADIX) + uj1) / v1); */ + cl = (u_scan[-2]); + ch = (bignum_digit_divide (uj, (u_scan[-1]), v1, (&gm))); + guess = gm; + } + else + { + cl = (u_scan[-2]); + ch = ((u_scan[-1]) + v1); + guess = (BIGNUM_RADIX - 1); + } + while (1) + { + /* product = (guess * v2); */ + gl = (HD_LOW (guess)); + gh = (HD_HIGH (guess)); + pl = (v2l * gl); + ph = ((v2l * gh) + (v2h * gl) + (HD_HIGH (pl))); + pl = (HD_CONS ((HD_LOW (ph)), (HD_LOW (pl)))); + ph = ((v2h * gh) + (HD_HIGH (ph))); + /* if (comparand >= product) */ + if ((ch > ph) || ((ch == ph) && (cl >= pl))) + break; + guess -= 1; + /* comparand += (v1 << BIGNUM_DIGIT_LENGTH) */ + ch += v1; + /* if (comparand >= (BIGNUM_RADIX * BIGNUM_RADIX)) */ + if (ch >= BIGNUM_RADIX) + break; + } + qj = (bignum_divide_subtract (v_start, v_end, guess, (--u_scan_start))); + if (q != BIGNUM_OUT_OF_BAND) + (*--q_scan) = qj; + } + return; +#undef gl +#undef uj +#undef qj +} + +bignum_digit_type +bignum_divide_subtract(bignum_digit_type * v_start, + bignum_digit_type * v_end, + bignum_digit_type guess, + bignum_digit_type * u_start) +{ + bignum_digit_type * v_scan = v_start; + bignum_digit_type * u_scan = u_start; + bignum_digit_type carry = 0; + if (guess == 0) return (0); + { + bignum_digit_type gl = (HD_LOW (guess)); + bignum_digit_type gh = (HD_HIGH (guess)); + bignum_digit_type v; + bignum_digit_type pl; + bignum_digit_type vl; +#define vh v +#define ph carry +#define diff pl + while (v_scan < v_end) + { + v = (*v_scan++); + vl = (HD_LOW (v)); + vh = (HD_HIGH (v)); + pl = ((vl * gl) + (HD_LOW (carry))); + ph = ((vl * gh) + (vh * gl) + (HD_HIGH (pl)) + (HD_HIGH (carry))); + diff = ((*u_scan) - (HD_CONS ((HD_LOW (ph)), (HD_LOW (pl))))); + if (diff < 0) + { + (*u_scan++) = (diff + BIGNUM_RADIX); + carry = ((vh * gh) + (HD_HIGH (ph)) + 1); + } + else + { + (*u_scan++) = diff; + carry = ((vh * gh) + (HD_HIGH (ph))); + } + } + if (carry == 0) + return (guess); + diff = ((*u_scan) - carry); + if (diff < 0) + (*u_scan) = (diff + BIGNUM_RADIX); + else + { + (*u_scan) = diff; + return (guess); + } +#undef vh +#undef ph +#undef diff + } + /* Subtraction generated carry, implying guess is one too large. + Add v back in to bring it back down. */ + v_scan = v_start; + u_scan = u_start; + carry = 0; + while (v_scan < v_end) + { + bignum_digit_type sum = ((*v_scan++) + (*u_scan) + carry); + if (sum < BIGNUM_RADIX) + { + (*u_scan++) = sum; + carry = 0; + } + else + { + (*u_scan++) = (sum - BIGNUM_RADIX); + carry = 1; + } + } + if (carry == 1) + { + bignum_digit_type sum = ((*u_scan) + carry); + (*u_scan) = ((sum < BIGNUM_RADIX) ? sum : (sum - BIGNUM_RADIX)); + } + return (guess - 1); +} + +/* allocates memory */ +void +bignum_divide_unsigned_medium_denominator(bignum_type numerator, + bignum_digit_type denominator, + bignum_type * quotient, + bignum_type * remainder, + int q_negative_p, + int r_negative_p) +{ + bignum_length_type length_n = (BIGNUM_LENGTH (numerator)); + bignum_length_type length_q; + bignum_type q; + int shift = 0; + /* Because `bignum_digit_divide' requires a normalized denominator. */ + while (denominator < (BIGNUM_RADIX / 2)) + { + denominator <<= 1; + shift += 1; + } + if (shift == 0) + { + length_q = length_n; + + REGISTER_BIGNUM(numerator); + q = (allot_bignum (length_q, q_negative_p)); + UNREGISTER_BIGNUM(numerator); + + bignum_destructive_copy (numerator, q); + } + else + { + length_q = (length_n + 1); + + REGISTER_BIGNUM(numerator); + q = (allot_bignum (length_q, q_negative_p)); + UNREGISTER_BIGNUM(numerator); + + bignum_destructive_normalization (numerator, q, shift); + } + { + bignum_digit_type r = 0; + bignum_digit_type * start = (BIGNUM_START_PTR (q)); + bignum_digit_type * scan = (start + length_q); + bignum_digit_type qj; + + while (start < scan) + { + r = (bignum_digit_divide (r, (*--scan), denominator, (&qj))); + (*scan) = qj; + } + + q = bignum_trim (q); + + if (remainder != ((bignum_type *) 0)) + { + if (shift != 0) + r >>= shift; + + REGISTER_BIGNUM(q); + (*remainder) = (bignum_digit_to_bignum (r, r_negative_p)); + UNREGISTER_BIGNUM(q); + } + + if (quotient != ((bignum_type *) 0)) + (*quotient) = q; + } + return; +} + +void +bignum_destructive_normalization(bignum_type source, bignum_type target, + int shift_left) +{ + bignum_digit_type digit; + bignum_digit_type * scan_source = (BIGNUM_START_PTR (source)); + bignum_digit_type carry = 0; + bignum_digit_type * scan_target = (BIGNUM_START_PTR (target)); + bignum_digit_type * end_source = (scan_source + (BIGNUM_LENGTH (source))); + bignum_digit_type * end_target = (scan_target + (BIGNUM_LENGTH (target))); + int shift_right = (BIGNUM_DIGIT_LENGTH - shift_left); + bignum_digit_type mask = (((CELL)1 << shift_right) - 1); + while (scan_source < end_source) + { + digit = (*scan_source++); + (*scan_target++) = (((digit & mask) << shift_left) | carry); + carry = (digit >> shift_right); + } + if (scan_target < end_target) + (*scan_target) = carry; + else + BIGNUM_ASSERT (carry == 0); + return; +} + +void +bignum_destructive_unnormalization(bignum_type bignum, int shift_right) +{ + bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); + bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); + bignum_digit_type digit; + bignum_digit_type carry = 0; + int shift_left = (BIGNUM_DIGIT_LENGTH - shift_right); + bignum_digit_type mask = (((F_FIXNUM)1 << shift_right) - 1); + while (start < scan) + { + digit = (*--scan); + (*scan) = ((digit >> shift_right) | carry); + carry = ((digit & mask) << shift_left); + } + BIGNUM_ASSERT (carry == 0); + return; +} + +/* This is a reduced version of the division algorithm, applied to the + case of dividing two bignum digits by one bignum digit. It is + assumed that the numerator, denominator are normalized. */ + +#define BDD_STEP(qn, j) \ +{ \ + uj = (u[j]); \ + if (uj != v1) \ + { \ + uj_uj1 = (HD_CONS (uj, (u[j + 1]))); \ + guess = (uj_uj1 / v1); \ + comparand = (HD_CONS ((uj_uj1 % v1), (u[j + 2]))); \ + } \ + else \ + { \ + guess = (BIGNUM_RADIX_ROOT - 1); \ + comparand = (HD_CONS (((u[j + 1]) + v1), (u[j + 2]))); \ + } \ + while ((guess * v2) > comparand) \ + { \ + guess -= 1; \ + comparand += (v1 << BIGNUM_HALF_DIGIT_LENGTH); \ + if (comparand >= BIGNUM_RADIX) \ + break; \ + } \ + qn = (bignum_digit_divide_subtract (v1, v2, guess, (&u[j]))); \ +} + +bignum_digit_type +bignum_digit_divide(bignum_digit_type uh, bignum_digit_type ul, + bignum_digit_type v, + bignum_digit_type * q) /* return value */ +{ + bignum_digit_type guess; + bignum_digit_type comparand; + bignum_digit_type v1 = (HD_HIGH (v)); + bignum_digit_type v2 = (HD_LOW (v)); + bignum_digit_type uj; + bignum_digit_type uj_uj1; + bignum_digit_type q1; + bignum_digit_type q2; + bignum_digit_type u [4]; + if (uh == 0) + { + if (ul < v) + { + (*q) = 0; + return (ul); + } + else if (ul == v) + { + (*q) = 1; + return (0); + } + } + (u[0]) = (HD_HIGH (uh)); + (u[1]) = (HD_LOW (uh)); + (u[2]) = (HD_HIGH (ul)); + (u[3]) = (HD_LOW (ul)); + v1 = (HD_HIGH (v)); + v2 = (HD_LOW (v)); + BDD_STEP (q1, 0); + BDD_STEP (q2, 1); + (*q) = (HD_CONS (q1, q2)); + return (HD_CONS ((u[2]), (u[3]))); +} + +#undef BDD_STEP + +#define BDDS_MULSUB(vn, un, carry_in) \ +{ \ + product = ((vn * guess) + carry_in); \ + diff = (un - (HD_LOW (product))); \ + if (diff < 0) \ + { \ + un = (diff + BIGNUM_RADIX_ROOT); \ + carry = ((HD_HIGH (product)) + 1); \ + } \ + else \ + { \ + un = diff; \ + carry = (HD_HIGH (product)); \ + } \ +} + +#define BDDS_ADD(vn, un, carry_in) \ +{ \ + sum = (vn + un + carry_in); \ + if (sum < BIGNUM_RADIX_ROOT) \ + { \ + un = sum; \ + carry = 0; \ + } \ + else \ + { \ + un = (sum - BIGNUM_RADIX_ROOT); \ + carry = 1; \ + } \ +} + +bignum_digit_type +bignum_digit_divide_subtract(bignum_digit_type v1, bignum_digit_type v2, + bignum_digit_type guess, bignum_digit_type * u) +{ + { + bignum_digit_type product; + bignum_digit_type diff; + bignum_digit_type carry; + BDDS_MULSUB (v2, (u[2]), 0); + BDDS_MULSUB (v1, (u[1]), carry); + if (carry == 0) + return (guess); + diff = ((u[0]) - carry); + if (diff < 0) + (u[0]) = (diff + BIGNUM_RADIX); + else + { + (u[0]) = diff; + return (guess); + } + } + { + bignum_digit_type sum; + bignum_digit_type carry; + BDDS_ADD(v2, (u[2]), 0); + BDDS_ADD(v1, (u[1]), carry); + if (carry == 1) + (u[0]) += 1; + } + return (guess - 1); +} + +#undef BDDS_MULSUB +#undef BDDS_ADD + +/* allocates memory */ +void +bignum_divide_unsigned_small_denominator(bignum_type numerator, + bignum_digit_type denominator, + bignum_type * quotient, + bignum_type * remainder, + int q_negative_p, + int r_negative_p) +{ + REGISTER_BIGNUM(numerator); + bignum_type q = (bignum_new_sign (numerator, q_negative_p)); + UNREGISTER_BIGNUM(numerator); + + bignum_digit_type r = (bignum_destructive_scale_down (q, denominator)); + + q = (bignum_trim (q)); + + if (remainder != ((bignum_type *) 0)) + { + REGISTER_BIGNUM(q); + (*remainder) = (bignum_digit_to_bignum (r, r_negative_p)); + UNREGISTER_BIGNUM(q); + } + + (*quotient) = q; + + return; +} + +/* Given (denominator > 1), it is fairly easy to show that + (quotient_high < BIGNUM_RADIX_ROOT), after which it is easy to see + that all digits are < BIGNUM_RADIX. */ + +bignum_digit_type +bignum_destructive_scale_down(bignum_type bignum, bignum_digit_type denominator) +{ + bignum_digit_type numerator; + bignum_digit_type remainder = 0; + bignum_digit_type two_digits; +#define quotient_high remainder + bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); + bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); + BIGNUM_ASSERT ((denominator > 1) && (denominator < BIGNUM_RADIX_ROOT)); + while (start < scan) + { + two_digits = (*--scan); + numerator = (HD_CONS (remainder, (HD_HIGH (two_digits)))); + quotient_high = (numerator / denominator); + numerator = (HD_CONS ((numerator % denominator), (HD_LOW (two_digits)))); + (*scan) = (HD_CONS (quotient_high, (numerator / denominator))); + remainder = (numerator % denominator); + } + return (remainder); +#undef quotient_high +} + +/* allocates memory */ +bignum_type +bignum_remainder_unsigned_small_denominator( + bignum_type n, bignum_digit_type d, int negative_p) +{ + bignum_digit_type two_digits; + bignum_digit_type * start = (BIGNUM_START_PTR (n)); + bignum_digit_type * scan = (start + (BIGNUM_LENGTH (n))); + bignum_digit_type r = 0; + BIGNUM_ASSERT ((d > 1) && (d < BIGNUM_RADIX_ROOT)); + while (start < scan) + { + two_digits = (*--scan); + r = + ((HD_CONS (((HD_CONS (r, (HD_HIGH (two_digits)))) % d), + (HD_LOW (two_digits)))) + % d); + } + return (bignum_digit_to_bignum (r, negative_p)); +} + +/* allocates memory */ +bignum_type +bignum_digit_to_bignum(bignum_digit_type digit, int negative_p) +{ + if (digit == 0) + return (BIGNUM_ZERO ()); + else + { + bignum_type result = (allot_bignum (1, negative_p)); + (BIGNUM_REF (result, 0)) = digit; + return (result); + } +} + +/* allocates memory */ +bignum_type +allot_bignum(bignum_length_type length, int negative_p) +{ + BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX)); + bignum_type result = allot_array_internal(BIGNUM_TYPE,length + 1); + BIGNUM_SET_NEGATIVE_P (result, negative_p); + return (result); +} + +/* allocates memory */ +bignum_type +allot_bignum_zeroed(bignum_length_type length, int negative_p) +{ + bignum_type result = allot_bignum(length,negative_p); + bignum_digit_type * scan = (BIGNUM_START_PTR (result)); + bignum_digit_type * end = (scan + length); + while (scan < end) + (*scan++) = 0; + return (result); +} + +#define BIGNUM_REDUCE_LENGTH(source, length) \ + source = reallot_array(source,length + 1) + +/* allocates memory */ +bignum_type +bignum_shorten_length(bignum_type bignum, bignum_length_type length) +{ + bignum_length_type current_length = (BIGNUM_LENGTH (bignum)); + BIGNUM_ASSERT ((length >= 0) || (length <= current_length)); + if (length < current_length) + { + BIGNUM_REDUCE_LENGTH (bignum, length); + BIGNUM_SET_NEGATIVE_P (bignum, (length != 0) && (BIGNUM_NEGATIVE_P (bignum))); + } + return (bignum); +} + +/* allocates memory */ +bignum_type +bignum_trim(bignum_type bignum) +{ + bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); + bignum_digit_type * end = (start + (BIGNUM_LENGTH (bignum))); + bignum_digit_type * scan = end; + while ((start <= scan) && ((*--scan) == 0)) + ; + scan += 1; + if (scan < end) + { + bignum_length_type length = (scan - start); + BIGNUM_REDUCE_LENGTH (bignum, length); + BIGNUM_SET_NEGATIVE_P (bignum, (length != 0) && (BIGNUM_NEGATIVE_P (bignum))); + } + return (bignum); +} + +/* Copying */ + +/* allocates memory */ +bignum_type +bignum_new_sign(bignum_type bignum, int negative_p) +{ + REGISTER_BIGNUM(bignum); + bignum_type result = + (allot_bignum ((BIGNUM_LENGTH (bignum)), negative_p)); + UNREGISTER_BIGNUM(bignum); + + bignum_destructive_copy (bignum, result); + return (result); +} + +/* allocates memory */ +bignum_type +bignum_maybe_new_sign(bignum_type bignum, int negative_p) +{ + if ((BIGNUM_NEGATIVE_P (bignum)) ? negative_p : (! negative_p)) + return (bignum); + else + { + bignum_type result = + (allot_bignum ((BIGNUM_LENGTH (bignum)), negative_p)); + bignum_destructive_copy (bignum, result); + return (result); + } +} + +void +bignum_destructive_copy(bignum_type source, bignum_type target) +{ + bignum_digit_type * scan_source = (BIGNUM_START_PTR (source)); + bignum_digit_type * end_source = + (scan_source + (BIGNUM_LENGTH (source))); + bignum_digit_type * scan_target = (BIGNUM_START_PTR (target)); + while (scan_source < end_source) + (*scan_target++) = (*scan_source++); + return; +} + +/* + * Added bitwise operations (and oddp). + */ + +/* allocates memory */ +bignum_type +bignum_bitwise_not(bignum_type x) +{ + return bignum_subtract(BIGNUM_ONE(1), x); +} + +/* allocates memory */ +bignum_type +bignum_arithmetic_shift(bignum_type arg1, F_FIXNUM n) +{ + if (BIGNUM_NEGATIVE_P(arg1) && n < 0) + return bignum_bitwise_not(bignum_magnitude_ash(bignum_bitwise_not(arg1), n)); + else + return bignum_magnitude_ash(arg1, n); +} + +#define AND_OP 0 +#define IOR_OP 1 +#define XOR_OP 2 + +/* allocates memory */ +bignum_type +bignum_bitwise_and(bignum_type arg1, bignum_type arg2) +{ + return( + (BIGNUM_NEGATIVE_P (arg1)) + ? (BIGNUM_NEGATIVE_P (arg2)) + ? bignum_negneg_bitwise_op(AND_OP, arg1, arg2) + : bignum_posneg_bitwise_op(AND_OP, arg2, arg1) + : (BIGNUM_NEGATIVE_P (arg2)) + ? bignum_posneg_bitwise_op(AND_OP, arg1, arg2) + : bignum_pospos_bitwise_op(AND_OP, arg1, arg2) + ); +} + +/* allocates memory */ +bignum_type +bignum_bitwise_ior(bignum_type arg1, bignum_type arg2) +{ + return( + (BIGNUM_NEGATIVE_P (arg1)) + ? (BIGNUM_NEGATIVE_P (arg2)) + ? bignum_negneg_bitwise_op(IOR_OP, arg1, arg2) + : bignum_posneg_bitwise_op(IOR_OP, arg2, arg1) + : (BIGNUM_NEGATIVE_P (arg2)) + ? bignum_posneg_bitwise_op(IOR_OP, arg1, arg2) + : bignum_pospos_bitwise_op(IOR_OP, arg1, arg2) + ); +} + +/* allocates memory */ +bignum_type +bignum_bitwise_xor(bignum_type arg1, bignum_type arg2) +{ + return( + (BIGNUM_NEGATIVE_P (arg1)) + ? (BIGNUM_NEGATIVE_P (arg2)) + ? bignum_negneg_bitwise_op(XOR_OP, arg1, arg2) + : bignum_posneg_bitwise_op(XOR_OP, arg2, arg1) + : (BIGNUM_NEGATIVE_P (arg2)) + ? bignum_posneg_bitwise_op(XOR_OP, arg1, arg2) + : bignum_pospos_bitwise_op(XOR_OP, arg1, arg2) + ); +} + +/* allocates memory */ +/* ash for the magnitude */ +/* assume arg1 is a big number, n is a long */ +bignum_type +bignum_magnitude_ash(bignum_type arg1, F_FIXNUM n) +{ + bignum_type result = NULL; + bignum_digit_type *scan1; + bignum_digit_type *scanr; + bignum_digit_type *end; + + F_FIXNUM digit_offset,bit_offset; + + if (BIGNUM_ZERO_P (arg1)) return (arg1); + + if (n > 0) { + digit_offset = n / BIGNUM_DIGIT_LENGTH; + bit_offset = n % BIGNUM_DIGIT_LENGTH; + + REGISTER_BIGNUM(arg1); + result = allot_bignum_zeroed (BIGNUM_LENGTH (arg1) + digit_offset + 1, + BIGNUM_NEGATIVE_P(arg1)); + UNREGISTER_BIGNUM(arg1); + + scanr = BIGNUM_START_PTR (result) + digit_offset; + scan1 = BIGNUM_START_PTR (arg1); + end = scan1 + BIGNUM_LENGTH (arg1); + + while (scan1 < end) { + *scanr = *scanr | (*scan1 & BIGNUM_DIGIT_MASK) << bit_offset; + *scanr = *scanr & BIGNUM_DIGIT_MASK; + scanr++; + *scanr = *scan1++ >> (BIGNUM_DIGIT_LENGTH - bit_offset); + *scanr = *scanr & BIGNUM_DIGIT_MASK; + } + } + else if (n < 0 + && (-n >= (BIGNUM_LENGTH (arg1) * (bignum_length_type) BIGNUM_DIGIT_LENGTH))) + result = BIGNUM_ZERO (); + + else if (n < 0) { + digit_offset = -n / BIGNUM_DIGIT_LENGTH; + bit_offset = -n % BIGNUM_DIGIT_LENGTH; + + REGISTER_BIGNUM(arg1); + result = allot_bignum_zeroed (BIGNUM_LENGTH (arg1) - digit_offset, + BIGNUM_NEGATIVE_P(arg1)); + UNREGISTER_BIGNUM(arg1); + + scanr = BIGNUM_START_PTR (result); + scan1 = BIGNUM_START_PTR (arg1) + digit_offset; + end = scanr + BIGNUM_LENGTH (result) - 1; + + while (scanr < end) { + *scanr = (*scan1++ & BIGNUM_DIGIT_MASK) >> bit_offset ; + *scanr = (*scanr | + *scan1 << (BIGNUM_DIGIT_LENGTH - bit_offset)) & BIGNUM_DIGIT_MASK; + scanr++; + } + *scanr = (*scan1++ & BIGNUM_DIGIT_MASK) >> bit_offset ; + } + else if (n == 0) result = arg1; + + return (bignum_trim (result)); +} + +/* allocates memory */ +bignum_type +bignum_pospos_bitwise_op(int op, bignum_type arg1, bignum_type arg2) +{ + bignum_type result; + bignum_length_type max_length; + + bignum_digit_type *scan1, *end1, digit1; + bignum_digit_type *scan2, *end2, digit2; + bignum_digit_type *scanr, *endr; + + max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2)) + ? BIGNUM_LENGTH(arg1) : BIGNUM_LENGTH(arg2); + + REGISTER_BIGNUM(arg1); + REGISTER_BIGNUM(arg2); + result = allot_bignum(max_length, 0); + UNREGISTER_BIGNUM(arg2); + UNREGISTER_BIGNUM(arg1); + + scanr = BIGNUM_START_PTR(result); + scan1 = BIGNUM_START_PTR(arg1); + scan2 = BIGNUM_START_PTR(arg2); + endr = scanr + max_length; + end1 = scan1 + BIGNUM_LENGTH(arg1); + end2 = scan2 + BIGNUM_LENGTH(arg2); + + while (scanr < endr) { + digit1 = (scan1 < end1) ? *scan1++ : 0; + digit2 = (scan2 < end2) ? *scan2++ : 0; + *scanr++ = (op == AND_OP) ? digit1 & digit2 : + (op == IOR_OP) ? digit1 | digit2 : + digit1 ^ digit2; + } + return bignum_trim(result); +} + +/* allocates memory */ +bignum_type +bignum_posneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2) +{ + bignum_type result; + bignum_length_type max_length; + + bignum_digit_type *scan1, *end1, digit1; + bignum_digit_type *scan2, *end2, digit2, carry2; + bignum_digit_type *scanr, *endr; + + char neg_p = op == IOR_OP || op == XOR_OP; + + max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2) + 1) + ? BIGNUM_LENGTH(arg1) : BIGNUM_LENGTH(arg2) + 1; + + REGISTER_BIGNUM(arg1); + REGISTER_BIGNUM(arg2); + result = allot_bignum(max_length, neg_p); + UNREGISTER_BIGNUM(arg2); + UNREGISTER_BIGNUM(arg1); + + scanr = BIGNUM_START_PTR(result); + scan1 = BIGNUM_START_PTR(arg1); + scan2 = BIGNUM_START_PTR(arg2); + endr = scanr + max_length; + end1 = scan1 + BIGNUM_LENGTH(arg1); + end2 = scan2 + BIGNUM_LENGTH(arg2); + + carry2 = 1; + + while (scanr < endr) { + digit1 = (scan1 < end1) ? *scan1++ : 0; + digit2 = (~((scan2 < end2) ? *scan2++ : 0) & BIGNUM_DIGIT_MASK) + + carry2; + + if (digit2 < BIGNUM_RADIX) + carry2 = 0; + else + { + digit2 = (digit2 - BIGNUM_RADIX); + carry2 = 1; + } + + *scanr++ = (op == AND_OP) ? digit1 & digit2 : + (op == IOR_OP) ? digit1 | digit2 : + digit1 ^ digit2; + } + + if (neg_p) + bignum_negate_magnitude(result); + + return bignum_trim(result); +} + +/* allocates memory */ +bignum_type +bignum_negneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2) +{ + bignum_type result; + bignum_length_type max_length; + + bignum_digit_type *scan1, *end1, digit1, carry1; + bignum_digit_type *scan2, *end2, digit2, carry2; + bignum_digit_type *scanr, *endr; + + char neg_p = op == AND_OP || op == IOR_OP; + + max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2)) + ? BIGNUM_LENGTH(arg1) + 1 : BIGNUM_LENGTH(arg2) + 1; + + REGISTER_BIGNUM(arg1); + REGISTER_BIGNUM(arg2); + result = allot_bignum(max_length, neg_p); + UNREGISTER_BIGNUM(arg2); + UNREGISTER_BIGNUM(arg1); + + scanr = BIGNUM_START_PTR(result); + scan1 = BIGNUM_START_PTR(arg1); + scan2 = BIGNUM_START_PTR(arg2); + endr = scanr + max_length; + end1 = scan1 + BIGNUM_LENGTH(arg1); + end2 = scan2 + BIGNUM_LENGTH(arg2); + + carry1 = 1; + carry2 = 1; + + while (scanr < endr) { + digit1 = (~((scan1 < end1) ? *scan1++ : 0) & BIGNUM_DIGIT_MASK) + carry1; + digit2 = (~((scan2 < end2) ? *scan2++ : 0) & BIGNUM_DIGIT_MASK) + carry2; + + if (digit1 < BIGNUM_RADIX) + carry1 = 0; + else + { + digit1 = (digit1 - BIGNUM_RADIX); + carry1 = 1; + } + + if (digit2 < BIGNUM_RADIX) + carry2 = 0; + else + { + digit2 = (digit2 - BIGNUM_RADIX); + carry2 = 1; + } + + *scanr++ = (op == AND_OP) ? digit1 & digit2 : + (op == IOR_OP) ? digit1 | digit2 : + digit1 ^ digit2; + } + + if (neg_p) + bignum_negate_magnitude(result); + + return bignum_trim(result); +} + +void +bignum_negate_magnitude(bignum_type arg) +{ + bignum_digit_type *scan; + bignum_digit_type *end; + bignum_digit_type digit; + bignum_digit_type carry; + + scan = BIGNUM_START_PTR(arg); + end = scan + BIGNUM_LENGTH(arg); + + carry = 1; + + while (scan < end) { + digit = (~*scan & BIGNUM_DIGIT_MASK) + carry; + + if (digit < BIGNUM_RADIX) + carry = 0; + else + { + digit = (digit - BIGNUM_RADIX); + carry = 1; + } + + *scan++ = digit; + } +} + +/* Allocates memory */ +bignum_type +bignum_integer_length(bignum_type bignum) +{ + bignum_length_type index = ((BIGNUM_LENGTH (bignum)) - 1); + bignum_digit_type digit = (BIGNUM_REF (bignum, index)); + + REGISTER_BIGNUM(bignum); + bignum_type result = (allot_bignum (2, 0)); + UNREGISTER_BIGNUM(bignum); + + (BIGNUM_REF (result, 0)) = index; + (BIGNUM_REF (result, 1)) = 0; + bignum_destructive_scale_up (result, BIGNUM_DIGIT_LENGTH); + while (digit > 1) + { + bignum_destructive_add (result, ((bignum_digit_type) 1)); + digit >>= 1; + } + return (bignum_trim (result)); +} + +/* Allocates memory */ +int +bignum_logbitp(int shift, bignum_type arg) +{ + return((BIGNUM_NEGATIVE_P (arg)) + ? !bignum_unsigned_logbitp (shift, bignum_bitwise_not (arg)) + : bignum_unsigned_logbitp (shift,arg)); +} + +int +bignum_unsigned_logbitp(int shift, bignum_type bignum) +{ + bignum_length_type len = (BIGNUM_LENGTH (bignum)); + int index = shift / BIGNUM_DIGIT_LENGTH; + if (index >= len) + return 0; + bignum_digit_type digit = (BIGNUM_REF (bignum, index)); + int p = shift % BIGNUM_DIGIT_LENGTH; + bignum_digit_type mask = ((F_FIXNUM)1) << p; + return (digit & mask) ? 1 : 0; +} + +/* Allocates memory */ +bignum_type +digit_stream_to_bignum(unsigned int n_digits, + unsigned int (*producer)(unsigned int), + unsigned int radix, + int negative_p) +{ + BIGNUM_ASSERT ((radix > 1) && (radix <= BIGNUM_RADIX_ROOT)); + if (n_digits == 0) + return (BIGNUM_ZERO ()); + if (n_digits == 1) + { + F_FIXNUM digit = ((F_FIXNUM) ((*producer) (0))); + return (fixnum_to_bignum (negative_p ? (- digit) : digit)); + } + { + bignum_length_type length; + { + unsigned int radix_copy = radix; + unsigned int log_radix = 0; + while (radix_copy > 0) + { + radix_copy >>= 1; + log_radix += 1; + } + /* This length will be at least as large as needed. */ + length = (BIGNUM_BITS_TO_DIGITS (n_digits * log_radix)); + } + { + bignum_type result = (allot_bignum_zeroed (length, negative_p)); + while ((n_digits--) > 0) + { + bignum_destructive_scale_up (result, ((bignum_digit_type) radix)); + bignum_destructive_add + (result, ((bignum_digit_type) ((*producer) (n_digits)))); + } + return (bignum_trim (result)); + } + } +} diff --git a/vmpp/bignum.hpp b/vmpp/bignum.hpp new file mode 100644 index 0000000000..02309cad34 --- /dev/null +++ b/vmpp/bignum.hpp @@ -0,0 +1,127 @@ +/* :tabSize=2:indentSize=2:noTabs=true: + +Copyright (C) 1989-1992 Massachusetts Institute of Technology +Portions copyright (C) 2004-2007 Slava Pestov + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy and modify this software, to +redistribute either the original software or a modified version, and +to use this software for any purpose is granted, subject to the +following restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. */ + +typedef F_ARRAY * bignum_type; +#define BIGNUM_OUT_OF_BAND ((bignum_type) 0) + +enum bignum_comparison +{ + bignum_comparison_equal = 0, + bignum_comparison_less = -1, + bignum_comparison_greater = 1 +}; + +int bignum_equal_p(bignum_type, bignum_type); +enum bignum_comparison bignum_compare(bignum_type, bignum_type); +bignum_type bignum_add(bignum_type, bignum_type); +bignum_type bignum_subtract(bignum_type, bignum_type); +bignum_type bignum_negate(bignum_type); +bignum_type bignum_multiply(bignum_type, bignum_type); +void +bignum_divide(bignum_type numerator, bignum_type denominator, + bignum_type * quotient, bignum_type * remainder); +bignum_type bignum_quotient(bignum_type, bignum_type); +bignum_type bignum_remainder(bignum_type, bignum_type); +DLLEXPORT bignum_type fixnum_to_bignum(F_FIXNUM); +DLLEXPORT bignum_type cell_to_bignum(CELL); +DLLEXPORT bignum_type long_long_to_bignum(s64 n); +DLLEXPORT bignum_type ulong_long_to_bignum(u64 n); +F_FIXNUM bignum_to_fixnum(bignum_type); +CELL bignum_to_cell(bignum_type); +s64 bignum_to_long_long(bignum_type); +u64 bignum_to_ulong_long(bignum_type); +bignum_type double_to_bignum(double); +double bignum_to_double(bignum_type); + +/* Added bitwise operators. */ + +DLLEXPORT bignum_type bignum_bitwise_not(bignum_type), + bignum_arithmetic_shift(bignum_type, F_FIXNUM), + bignum_bitwise_and(bignum_type, bignum_type), + bignum_bitwise_ior(bignum_type, bignum_type), + bignum_bitwise_xor(bignum_type, bignum_type); + +/* Forward references */ +int bignum_equal_p_unsigned(bignum_type, bignum_type); +enum bignum_comparison bignum_compare_unsigned(bignum_type, bignum_type); +bignum_type bignum_add_unsigned(bignum_type, bignum_type, int); +bignum_type bignum_subtract_unsigned(bignum_type, bignum_type); +bignum_type bignum_multiply_unsigned(bignum_type, bignum_type, int); +bignum_type bignum_multiply_unsigned_small_factor + (bignum_type, bignum_digit_type, int); +void bignum_destructive_scale_up(bignum_type, bignum_digit_type); +void bignum_destructive_add(bignum_type, bignum_digit_type); +void bignum_divide_unsigned_large_denominator + (bignum_type, bignum_type, bignum_type *, bignum_type *, int, int); +void bignum_destructive_normalization(bignum_type, bignum_type, int); +void bignum_destructive_unnormalization(bignum_type, int); +void bignum_divide_unsigned_normalized(bignum_type, bignum_type, bignum_type); +bignum_digit_type bignum_divide_subtract + (bignum_digit_type *, bignum_digit_type *, bignum_digit_type, + bignum_digit_type *); +void bignum_divide_unsigned_medium_denominator + (bignum_type, bignum_digit_type, bignum_type *, bignum_type *, int, int); +bignum_digit_type bignum_digit_divide + (bignum_digit_type, bignum_digit_type, bignum_digit_type, bignum_digit_type *); +bignum_digit_type bignum_digit_divide_subtract + (bignum_digit_type, bignum_digit_type, bignum_digit_type, bignum_digit_type *); +void bignum_divide_unsigned_small_denominator + (bignum_type, bignum_digit_type, bignum_type *, bignum_type *, int, int); +bignum_digit_type bignum_destructive_scale_down + (bignum_type, bignum_digit_type); +bignum_type bignum_remainder_unsigned_small_denominator + (bignum_type, bignum_digit_type, int); +bignum_type bignum_digit_to_bignum(bignum_digit_type, int); +bignum_type allot_bignum(bignum_length_type, int); +bignum_type allot_bignum_zeroed(bignum_length_type, int); +bignum_type bignum_shorten_length(bignum_type, bignum_length_type); +bignum_type bignum_trim(bignum_type); +bignum_type bignum_new_sign(bignum_type, int); +bignum_type bignum_maybe_new_sign(bignum_type, int); +void bignum_destructive_copy(bignum_type, bignum_type); + +/* Added for bitwise operations. */ +bignum_type bignum_magnitude_ash(bignum_type arg1, F_FIXNUM n); +bignum_type bignum_pospos_bitwise_op(int op, bignum_type, bignum_type); +bignum_type bignum_posneg_bitwise_op(int op, bignum_type, bignum_type); +bignum_type bignum_negneg_bitwise_op(int op, bignum_type, bignum_type); +void bignum_negate_magnitude(bignum_type); + +bignum_type bignum_integer_length(bignum_type arg1); +int bignum_unsigned_logbitp(int shift, bignum_type bignum); +int bignum_logbitp(int shift, bignum_type arg); +bignum_type digit_stream_to_bignum(unsigned int n_digits, + unsigned int (*producer)(unsigned int), + unsigned int radix, + int negative_p); diff --git a/vmpp/bignumint.hpp b/vmpp/bignumint.hpp new file mode 100644 index 0000000000..9a8ff806ef --- /dev/null +++ b/vmpp/bignumint.hpp @@ -0,0 +1,100 @@ +/* -*-C-*- + +$Id: s48_bignumint.h,v 1.14 2005/12/21 02:36:52 spestov Exp $ + +Copyright (c) 1989-1992 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy and modify this software, to +redistribute either the original software or a modified version, and +to use this software for any purpose is granted, subject to the +following restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. */ + +/* Internal Interface to Bignum Code */ +#undef BIGNUM_ZERO_P +#undef BIGNUM_NEGATIVE_P + +/* The memory model is based on the following definitions, and on the + definition of the type `bignum_type'. The only other special + definition is `CHAR_BIT', which is defined in the Ansi C header + file "limits.h". */ + +typedef F_FIXNUM bignum_digit_type; +typedef F_FIXNUM bignum_length_type; + +/* BIGNUM_TO_POINTER casts a bignum object to a digit array pointer. */ +#define BIGNUM_TO_POINTER(bignum) ((bignum_digit_type *)AREF(bignum,0)) + +/* BIGNUM_EXCEPTION is invoked to handle assertion violations. */ +#define BIGNUM_EXCEPTION abort + + +#define BIGNUM_DIGIT_LENGTH (((sizeof (bignum_digit_type)) * CHAR_BIT) - 2) +#define BIGNUM_HALF_DIGIT_LENGTH (BIGNUM_DIGIT_LENGTH / 2) +#define BIGNUM_RADIX (bignum_digit_type)(((CELL) 1) << BIGNUM_DIGIT_LENGTH) +#define BIGNUM_RADIX_ROOT (((bignum_digit_type) 1) << BIGNUM_HALF_DIGIT_LENGTH) +#define BIGNUM_DIGIT_MASK (BIGNUM_RADIX - 1) +#define BIGNUM_HALF_DIGIT_MASK (BIGNUM_RADIX_ROOT - 1) + +#define BIGNUM_START_PTR(bignum) \ + ((BIGNUM_TO_POINTER (bignum)) + 1) + +#define BIGNUM_LENGTH(bignum) (untag_fixnum_fast((bignum)->capacity) - 1) + +#define BIGNUM_NEGATIVE_P(bignum) (get(AREF(bignum,0)) != 0) +#define BIGNUM_SET_NEGATIVE_P(bignum,neg) put(AREF(bignum,0),neg) + +#define BIGNUM_ZERO_P(bignum) \ + ((BIGNUM_LENGTH (bignum)) == 0) + +#define BIGNUM_REF(bignum, index) \ + (* ((BIGNUM_START_PTR (bignum)) + (index))) + +/* These definitions are here to facilitate caching of the constants + 0, 1, and -1. */ +#define BIGNUM_ZERO() untag_bignum_fast(bignum_zero) +#define BIGNUM_ONE(neg_p) \ + untag_bignum_fast(neg_p ? bignum_neg_one : bignum_pos_one) + +#define HD_LOW(digit) ((digit) & BIGNUM_HALF_DIGIT_MASK) +#define HD_HIGH(digit) ((digit) >> BIGNUM_HALF_DIGIT_LENGTH) +#define HD_CONS(high, low) (((high) << BIGNUM_HALF_DIGIT_LENGTH) | (low)) + +#define BIGNUM_BITS_TO_DIGITS(n) \ + (((n) + (BIGNUM_DIGIT_LENGTH - 1)) / BIGNUM_DIGIT_LENGTH) + +#define BIGNUM_DIGITS_FOR(type) \ + (BIGNUM_BITS_TO_DIGITS ((sizeof (type)) * CHAR_BIT)) + +#ifndef BIGNUM_DISABLE_ASSERTION_CHECKS + +#define BIGNUM_ASSERT(expression) \ +{ \ + if (! (expression)) \ + BIGNUM_EXCEPTION (); \ +} + +#endif /* not BIGNUM_DISABLE_ASSERTION_CHECKS */ diff --git a/vmpp/booleans.cpp b/vmpp/booleans.cpp new file mode 100644 index 0000000000..8cee090467 --- /dev/null +++ b/vmpp/booleans.cpp @@ -0,0 +1,13 @@ +#include "master.hpp" + +/* FFI calls this */ +void box_boolean(bool value) +{ + dpush(value ? T : F); +} + +/* FFI calls this */ +bool to_boolean(CELL value) +{ + return value != F; +} diff --git a/vmpp/booleans.hpp b/vmpp/booleans.hpp new file mode 100644 index 0000000000..ae49652dd8 --- /dev/null +++ b/vmpp/booleans.hpp @@ -0,0 +1,7 @@ +INLINE CELL tag_boolean(CELL untagged) +{ + return (untagged == false ? F : T); +} + +DLLEXPORT void box_boolean(bool value); +DLLEXPORT bool to_boolean(CELL value); diff --git a/vmpp/byte_arrays.cpp b/vmpp/byte_arrays.cpp new file mode 100644 index 0000000000..3a4b155587 --- /dev/null +++ b/vmpp/byte_arrays.cpp @@ -0,0 +1,84 @@ +#include "master.hpp" + +/* must fill out array before next GC */ +F_BYTE_ARRAY *allot_byte_array_internal(CELL size) +{ + F_BYTE_ARRAY *array = (F_BYTE_ARRAY *)allot_object(BYTE_ARRAY_TYPE,byte_array_size(size)); + array->capacity = tag_fixnum(size); + return array; +} + +/* size is in bytes this time */ +F_BYTE_ARRAY *allot_byte_array(CELL size) +{ + F_BYTE_ARRAY *array = allot_byte_array_internal(size); + memset(array + 1,0,size); + return array; +} + +/* push a new byte array on the stack */ +void primitive_byte_array(void) +{ + CELL size = unbox_array_size(); + dpush(tag_object(allot_byte_array(size))); +} + +void primitive_uninitialized_byte_array(void) +{ + CELL size = unbox_array_size(); + dpush(tag_object(allot_byte_array_internal(size))); +} + +static bool reallot_byte_array_in_place_p(F_BYTE_ARRAY *array, CELL capacity) +{ + return in_zone(&nursery,(CELL)array) && capacity <= array_capacity(array); +} + +F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity) +{ +#ifdef FACTOR_DEBUG + assert(untag_header(array->header) == BYTE_ARRAY_TYPE); +#endif + if(reallot_byte_array_in_place_p(array,capacity)) + { + array->capacity = tag_fixnum(capacity); + return array; + } + else + { + CELL to_copy = array_capacity(array); + if(capacity < to_copy) + to_copy = capacity; + + REGISTER_UNTAGGED(array); + F_BYTE_ARRAY *new_array = allot_byte_array_internal(capacity); + UNREGISTER_UNTAGGED(F_BYTE_ARRAY,array); + + memcpy(new_array + 1,array + 1,to_copy); + + return new_array; + } +} + +void primitive_resize_byte_array(void) +{ + F_BYTE_ARRAY* array = untag_byte_array(dpop()); + CELL capacity = unbox_array_size(); + dpush(tag_object(reallot_byte_array(array,capacity))); +} + +void growable_byte_array_append(F_GROWABLE_BYTE_ARRAY *array, void *elts, CELL len) +{ + CELL new_size = array->count + len; + F_BYTE_ARRAY *underlying = untag_byte_array_fast(array->array); + + if(new_size >= byte_array_capacity(underlying)) + { + underlying = reallot_byte_array(underlying,new_size * 2); + array->array = tag_object(underlying); + } + + memcpy((void *)BREF(underlying,array->count),elts,len); + + array->count += len; +} diff --git a/vmpp/byte_arrays.hpp b/vmpp/byte_arrays.hpp new file mode 100644 index 0000000000..a297eff85d --- /dev/null +++ b/vmpp/byte_arrays.hpp @@ -0,0 +1,40 @@ +DEFINE_UNTAG(F_BYTE_ARRAY,BYTE_ARRAY_TYPE,byte_array) + +INLINE CELL byte_array_capacity(F_BYTE_ARRAY *array) +{ + return untag_fixnum_fast(array->capacity); +} + +INLINE CELL byte_array_size(CELL size) +{ + return sizeof(F_BYTE_ARRAY) + size; +} + +F_BYTE_ARRAY *allot_byte_array(CELL size); +F_BYTE_ARRAY *allot_byte_array_internal(CELL size); +F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity); + +void primitive_byte_array(void); +void primitive_uninitialized_byte_array(void); +void primitive_resize_byte_array(void); + +/* Macros to simulate a byte vector in C */ +typedef struct { + CELL count; + CELL array; +} F_GROWABLE_BYTE_ARRAY; + +INLINE F_GROWABLE_BYTE_ARRAY make_growable_byte_array(void) +{ + F_GROWABLE_BYTE_ARRAY result; + result.count = 0; + result.array = tag_object(allot_byte_array(2)); + return result; +} + +void growable_byte_array_append(F_GROWABLE_BYTE_ARRAY *result, void *elts, CELL len); + +INLINE void growable_byte_array_trim(F_GROWABLE_BYTE_ARRAY *byte_array) +{ + byte_array->array = tag_object(reallot_byte_array(untag_byte_array_fast(byte_array->array),byte_array->count)); +} diff --git a/vmpp/callstack.cpp b/vmpp/callstack.cpp new file mode 100755 index 0000000000..325e91ebf6 --- /dev/null +++ b/vmpp/callstack.cpp @@ -0,0 +1,230 @@ +#include "master.hpp" + +/* called before entry into Factor code. */ +F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom) +{ + stack_chain->callstack_bottom = callstack_bottom; +} + +void iterate_callstack(CELL top, CELL bottom, CALLSTACK_ITER iterator) +{ + F_STACK_FRAME *frame = (F_STACK_FRAME *)bottom - 1; + + while((CELL)frame >= top) + { + F_STACK_FRAME *next = frame_successor(frame); + iterator(frame); + frame = next; + } +} + +void iterate_callstack_object(F_CALLSTACK *stack, CALLSTACK_ITER iterator) +{ + CELL top = (CELL)FIRST_STACK_FRAME(stack); + CELL bottom = top + untag_fixnum_fast(stack->length); + + iterate_callstack(top,bottom,iterator); +} + +F_CALLSTACK *allot_callstack(CELL size) +{ + F_CALLSTACK *callstack = (F_CALLSTACK *)allot_object( + CALLSTACK_TYPE, + callstack_size(size)); + callstack->length = tag_fixnum(size); + return callstack; +} + +F_STACK_FRAME *fix_callstack_top(F_STACK_FRAME *top, F_STACK_FRAME *bottom) +{ + F_STACK_FRAME *frame = bottom - 1; + + while(frame >= top) + frame = frame_successor(frame); + + return frame + 1; +} + +/* We ignore the topmost frame, the one calling 'callstack', +so that set-callstack doesn't get stuck in an infinite loop. + +This means that if 'callstack' is called in tail position, we +will have popped a necessary frame... however this word is only +called by continuation implementation, and user code shouldn't +be calling it at all, so we leave it as it is for now. */ +F_STACK_FRAME *capture_start(void) +{ + F_STACK_FRAME *frame = stack_chain->callstack_bottom - 1; + while(frame >= stack_chain->callstack_top + && frame_successor(frame) >= stack_chain->callstack_top) + { + frame = frame_successor(frame); + } + return frame + 1; +} + +void primitive_callstack(void) +{ + F_STACK_FRAME *top = capture_start(); + F_STACK_FRAME *bottom = stack_chain->callstack_bottom; + + F_FIXNUM size = (CELL)bottom - (CELL)top; + if(size < 0) + size = 0; + + F_CALLSTACK *callstack = allot_callstack(size); + memcpy(FIRST_STACK_FRAME(callstack),top,size); + dpush(tag_object(callstack)); +} + +void primitive_set_callstack(void) +{ + F_CALLSTACK *stack = untag_callstack(dpop()); + + set_callstack(stack_chain->callstack_bottom, + FIRST_STACK_FRAME(stack), + untag_fixnum_fast(stack->length), + memcpy); + + /* We cannot return here ... */ + critical_error("Bug in set_callstack()",0); +} + +F_CODE_BLOCK *frame_code(F_STACK_FRAME *frame) +{ + return (F_CODE_BLOCK *)frame->xt - 1; +} + +CELL frame_type(F_STACK_FRAME *frame) +{ + return frame_code(frame)->block.type; +} + +CELL frame_executing(F_STACK_FRAME *frame) +{ + F_CODE_BLOCK *compiled = frame_code(frame); + if(compiled->literals == F || !stack_traces_p()) + return F; + else + { + F_ARRAY *array = untag_array_fast(compiled->literals); + return array_nth(array,0); + } +} + +F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame) +{ + if(frame->size == 0) + critical_error("Stack frame has zero size",(CELL)frame); + return (F_STACK_FRAME *)((CELL)frame - frame->size); +} + +CELL frame_scan(F_STACK_FRAME *frame) +{ + if(frame_type(frame) == QUOTATION_TYPE) + { + CELL quot = frame_executing(frame); + if(quot == F) + return F; + else + { + char *return_addr = (char *)FRAME_RETURN_ADDRESS(frame); + char *quot_xt = (char *)(frame_code(frame) + 1); + + return tag_fixnum(quot_code_offset_to_scan( + quot,(CELL)(return_addr - quot_xt))); + } + } + else + return F; +} + +/* C doesn't have closures... */ +static CELL frame_count; + +void count_stack_frame(F_STACK_FRAME *frame) +{ + frame_count += 2; +} + +static CELL frame_index; +static F_ARRAY *array; + +void stack_frame_to_array(F_STACK_FRAME *frame) +{ + set_array_nth(array,frame_index++,frame_executing(frame)); + set_array_nth(array,frame_index++,frame_scan(frame)); +} + +void primitive_callstack_to_array(void) +{ + F_CALLSTACK *stack = untag_callstack(dpop()); + + frame_count = 0; + iterate_callstack_object(stack,count_stack_frame); + + REGISTER_UNTAGGED(stack); + array = allot_array_internal(ARRAY_TYPE,frame_count); + UNREGISTER_UNTAGGED(F_CALLSTACK,stack); + + frame_index = 0; + iterate_callstack_object(stack,stack_frame_to_array); + + dpush(tag_array(array)); +} + +F_STACK_FRAME *innermost_stack_frame(F_CALLSTACK *callstack) +{ + F_STACK_FRAME *top = FIRST_STACK_FRAME(callstack); + CELL bottom = (CELL)top + untag_fixnum_fast(callstack->length); + + F_STACK_FRAME *frame = (F_STACK_FRAME *)bottom - 1; + + while(frame >= top && frame_successor(frame) >= top) + frame = frame_successor(frame); + + return frame; +} + +/* Some primitives implementing a limited form of callstack mutation. +Used by the single stepper. */ +void primitive_innermost_stack_frame_quot(void) +{ + F_STACK_FRAME *inner = innermost_stack_frame( + untag_callstack(dpop())); + type_check(QUOTATION_TYPE,frame_executing(inner)); + + dpush(frame_executing(inner)); +} + +void primitive_innermost_stack_frame_scan(void) +{ + F_STACK_FRAME *inner = innermost_stack_frame( + untag_callstack(dpop())); + type_check(QUOTATION_TYPE,frame_executing(inner)); + + dpush(frame_scan(inner)); +} + +void primitive_set_innermost_stack_frame_quot(void) +{ + F_CALLSTACK *callstack = untag_callstack(dpop()); + F_QUOTATION *quot = untag_quotation(dpop()); + + REGISTER_UNTAGGED(callstack); + REGISTER_UNTAGGED(quot); + + jit_compile(tag_quotation(quot),true); + + UNREGISTER_UNTAGGED(F_QUOTATION,quot); + UNREGISTER_UNTAGGED(F_CALLSTACK,callstack); + + F_STACK_FRAME *inner = innermost_stack_frame(callstack); + type_check(QUOTATION_TYPE,frame_executing(inner)); + + CELL offset = (char *)FRAME_RETURN_ADDRESS(inner) - (char *)inner->xt; + + inner->xt = quot->xt; + + FRAME_RETURN_ADDRESS(inner) = (char *)quot->xt + offset; +} diff --git a/vmpp/callstack.hpp b/vmpp/callstack.hpp new file mode 100755 index 0000000000..36d35960ac --- /dev/null +++ b/vmpp/callstack.hpp @@ -0,0 +1,28 @@ +INLINE CELL callstack_size(CELL size) +{ + return sizeof(F_CALLSTACK) + size; +} + +DEFINE_UNTAG(F_CALLSTACK,CALLSTACK_TYPE,callstack) + +#define FIRST_STACK_FRAME(stack) (F_STACK_FRAME *)((stack) + 1) + +typedef void (*CALLSTACK_ITER)(F_STACK_FRAME *frame); + +F_STACK_FRAME *fix_callstack_top(F_STACK_FRAME *top, F_STACK_FRAME *bottom); +void iterate_callstack(CELL top, CELL bottom, CALLSTACK_ITER iterator); +void iterate_callstack_object(F_CALLSTACK *stack, CALLSTACK_ITER iterator); +F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame); +F_CODE_BLOCK *frame_code(F_STACK_FRAME *frame); +CELL frame_executing(F_STACK_FRAME *frame); +CELL frame_scan(F_STACK_FRAME *frame); +CELL frame_type(F_STACK_FRAME *frame); + +void primitive_callstack(void); +void primitive_set_callstack(void); +void primitive_callstack_to_array(void); +void primitive_innermost_stack_frame_quot(void); +void primitive_innermost_stack_frame_scan(void); +void primitive_set_innermost_stack_frame_quot(void); + +F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom); diff --git a/vmpp/code_block.cpp b/vmpp/code_block.cpp new file mode 100644 index 0000000000..606eac1d66 --- /dev/null +++ b/vmpp/code_block.cpp @@ -0,0 +1,504 @@ +#include "master.hpp" + +void flush_icache_for(F_CODE_BLOCK *block) +{ + flush_icache((CELL)block,block->block.size); +} + +void iterate_relocations(F_CODE_BLOCK *compiled, RELOCATION_ITERATOR iter) +{ + if(compiled->relocation != F) + { + F_BYTE_ARRAY *relocation = untag_byte_array_fast(compiled->relocation); + + CELL index = stack_traces_p() ? 1 : 0; + + F_REL *rel = (F_REL *)(relocation + 1); + F_REL *rel_end = (F_REL *)((char *)rel + byte_array_capacity(relocation)); + + while(rel < rel_end) + { + iter(*rel,index,compiled); + + switch(REL_TYPE(*rel)) + { + case RT_PRIMITIVE: + case RT_XT: + case RT_XT_DIRECT: + case RT_IMMEDIATE: + case RT_HERE: + case RT_UNTAGGED: + index++; + break; + case RT_DLSYM: + index += 2; + break; + case RT_THIS: + case RT_STACK_CHAIN: + break; + default: + critical_error("Bad rel type",*rel); + return; /* Can't happen */ + } + + rel++; + } + } +} + +/* Store a 32-bit value into a PowerPC LIS/ORI sequence */ +INLINE void store_address_2_2(CELL cell, CELL value) +{ + put(cell - CELLS,((get(cell - CELLS) & ~0xffff) | ((value >> 16) & 0xffff))); + put(cell,((get(cell) & ~0xffff) | (value & 0xffff))); +} + +/* Store a value into a bitfield of a PowerPC instruction */ +INLINE void store_address_masked(CELL cell, F_FIXNUM value, CELL mask, F_FIXNUM shift) +{ + /* This is unaccurate but good enough */ + F_FIXNUM test = (F_FIXNUM)mask >> 1; + if(value <= -test || value >= test) + critical_error("Value does not fit inside relocation",0); + + u32 original = *(u32*)cell; + original &= ~mask; + *(u32*)cell = (original | ((value >> shift) & mask)); +} + +/* Perform a fixup on a code block */ +void store_address_in_code_block(CELL klass, CELL offset, F_FIXNUM absolute_value) +{ + F_FIXNUM relative_value = absolute_value - offset; + + switch(klass) + { + case RC_ABSOLUTE_CELL: + put(offset,absolute_value); + break; + case RC_ABSOLUTE: + *(u32*)offset = absolute_value; + break; + case RC_RELATIVE: + *(u32*)offset = relative_value - sizeof(u32); + break; + case RC_ABSOLUTE_PPC_2_2: + store_address_2_2(offset,absolute_value); + break; + case RC_RELATIVE_PPC_2: + store_address_masked(offset,relative_value,REL_RELATIVE_PPC_2_MASK,0); + break; + case RC_RELATIVE_PPC_3: + store_address_masked(offset,relative_value,REL_RELATIVE_PPC_3_MASK,0); + break; + case RC_RELATIVE_ARM_3: + store_address_masked(offset,relative_value - CELLS * 2, + REL_RELATIVE_ARM_3_MASK,2); + break; + case RC_INDIRECT_ARM: + store_address_masked(offset,relative_value - CELLS, + REL_INDIRECT_ARM_MASK,0); + break; + case RC_INDIRECT_ARM_PC: + store_address_masked(offset,relative_value - CELLS * 2, + REL_INDIRECT_ARM_MASK,0); + break; + default: + critical_error("Bad rel class",klass); + break; + } +} + +void update_literal_references_step(F_REL rel, CELL index, F_CODE_BLOCK *compiled) +{ + if(REL_TYPE(rel) == RT_IMMEDIATE) + { + CELL offset = REL_OFFSET(rel) + (CELL)(compiled + 1); + F_ARRAY *literals = untag_array_fast(compiled->literals); + F_FIXNUM absolute_value = array_nth(literals,index); + store_address_in_code_block(REL_CLASS(rel),offset,absolute_value); + } +} + +/* Update pointers to literals from compiled code. */ +void update_literal_references(F_CODE_BLOCK *compiled) +{ + iterate_relocations(compiled,update_literal_references_step); + flush_icache_for(compiled); +} + +/* Copy all literals referenced from a code block to newspace. Only for +aging and nursery collections */ +void copy_literal_references(F_CODE_BLOCK *compiled) +{ + if(collecting_gen >= compiled->block.last_scan) + { + if(collecting_accumulation_gen_p()) + compiled->block.last_scan = collecting_gen; + else + compiled->block.last_scan = collecting_gen + 1; + + /* initialize chase pointer */ + CELL scan = newspace->here; + + copy_handle(&compiled->literals); + copy_handle(&compiled->relocation); + + /* do some tracing so that all reachable literals are now + at their final address */ + copy_reachable_objects(scan,&newspace->here); + + update_literal_references(compiled); + } +} + +CELL object_xt(CELL obj) +{ + if(TAG(obj) == QUOTATION_TYPE) + { + F_QUOTATION *quot = untag_quotation_fast(obj); + return (CELL)quot->xt; + } + else + { + F_WORD *word = untag_word_fast(obj); + return (CELL)word->xt; + } +} + +CELL word_direct_xt(CELL obj) +{ + F_WORD *word = untag_word_fast(obj); + CELL quot = word->direct_entry_def; + if(quot == F || max_pic_size == 0) + return (CELL)word->xt; + else + { + F_QUOTATION *untagged = untag_quotation_fast(quot); + if(untagged->compiledp == F) + return (CELL)word->xt; + else + return (CELL)untagged->xt; + } +} + +void update_word_references_step(F_REL rel, CELL index, F_CODE_BLOCK *compiled) +{ + F_RELTYPE type = REL_TYPE(rel); + if(type == RT_XT || type == RT_XT_DIRECT) + { + CELL offset = REL_OFFSET(rel) + (CELL)(compiled + 1); + F_ARRAY *literals = untag_array_fast(compiled->literals); + CELL obj = array_nth(literals,index); + + CELL xt; + if(type == RT_XT) + xt = object_xt(obj); + else + xt = word_direct_xt(obj); + + store_address_in_code_block(REL_CLASS(rel),offset,xt); + } +} + +/* Relocate new code blocks completely; updating references to literals, +dlsyms, and words. For all other words in the code heap, we only need +to update references to other words, without worrying about literals +or dlsyms. */ +void update_word_references(F_CODE_BLOCK *compiled) +{ + if(compiled->block.needs_fixup) + relocate_code_block(compiled); + /* update_word_references() is always applied to every block in + the code heap. Since it resets all call sites to point to + their canonical XT (cold entry point for non-tail calls, + standard entry point for tail calls), it means that no PICs + are referenced after this is done. So instead of polluting + the code heap with dead PICs that will be freed on the next + GC, we add them to the free list immediately. */ + else if(compiled->block.type == PIC_TYPE) + { + fflush(stdout); + heap_free(&code_heap,&compiled->block); + } + else + { + iterate_relocations(compiled,update_word_references_step); + flush_icache_for(compiled); + } +} + +void update_literal_and_word_references(F_CODE_BLOCK *compiled) +{ + update_literal_references(compiled); + update_word_references(compiled); +} + +INLINE void check_code_address(CELL address) +{ +#ifdef FACTOR_DEBUG + assert(address >= code_heap.segment->start && address < code_heap.segment->end); +#endif +} + +/* Update references to words. This is done after a new code block +is added to the heap. */ + +/* Mark all literals referenced from a word XT. Only for tenured +collections */ +void mark_code_block(F_CODE_BLOCK *compiled) +{ + check_code_address((CELL)compiled); + + mark_block(&compiled->block); + + copy_handle(&compiled->literals); + copy_handle(&compiled->relocation); +} + +void mark_stack_frame_step(F_STACK_FRAME *frame) +{ + mark_code_block(frame_code(frame)); +} + +/* Mark code blocks executing in currently active stack frames. */ +void mark_active_blocks(F_CONTEXT *stacks) +{ + if(collecting_gen == TENURED) + { + CELL top = (CELL)stacks->callstack_top; + CELL bottom = (CELL)stacks->callstack_bottom; + + iterate_callstack(top,bottom,mark_stack_frame_step); + } +} + +void mark_object_code_block(CELL scan) +{ + F_WORD *word; + F_QUOTATION *quot; + F_CALLSTACK *stack; + + switch(hi_tag(scan)) + { + case WORD_TYPE: + word = (F_WORD *)scan; + if(word->code) + mark_code_block(word->code); + if(word->profiling) + mark_code_block(word->profiling); + break; + case QUOTATION_TYPE: + quot = (F_QUOTATION *)scan; + if(quot->compiledp != F) + mark_code_block(quot->code); + break; + case CALLSTACK_TYPE: + stack = (F_CALLSTACK *)scan; + iterate_callstack_object(stack,mark_stack_frame_step); + break; + } +} + +/* References to undefined symbols are patched up to call this function on +image load */ +void undefined_symbol(void) +{ + general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL); +} + +/* Look up an external library symbol referenced by a compiled code block */ +void *get_rel_symbol(F_ARRAY *literals, CELL index) +{ + CELL symbol = array_nth(literals,index); + CELL library = array_nth(literals,index + 1); + + F_DLL *dll = (library == F ? NULL : untag_dll(library)); + + if(dll != NULL && !dll->dll) + return (void *)undefined_symbol; + + if(type_of(symbol) == BYTE_ARRAY_TYPE) + { + F_SYMBOL *name = alien_offset(symbol); + void *sym = ffi_dlsym(dll,name); + + if(sym) + return sym; + } + else if(type_of(symbol) == ARRAY_TYPE) + { + CELL i; + F_ARRAY *names = untag_array_fast(symbol); + for(i = 0; i < array_capacity(names); i++) + { + F_SYMBOL *name = alien_offset(array_nth(names,i)); + void *sym = ffi_dlsym(dll,name); + + if(sym) + return sym; + } + } + +#ifdef FACTOR_DEBUG + print_obj(symbol); nl(); fflush(stdout); +#endif + + return (void *)undefined_symbol; +} + +/* Compute an address to store at a relocation */ +void relocate_code_block_step(F_REL rel, CELL index, F_CODE_BLOCK *compiled) +{ +#ifdef FACTOR_DEBUG + type_check(ARRAY_TYPE,compiled->literals); + type_check(BYTE_ARRAY_TYPE,compiled->relocation); +#endif + + CELL offset = REL_OFFSET(rel) + (CELL)(compiled + 1); + F_ARRAY *literals = untag_array_fast(compiled->literals); + F_FIXNUM absolute_value; + + switch(REL_TYPE(rel)) + { + case RT_PRIMITIVE: + absolute_value = (CELL)primitives[to_fixnum(array_nth(literals,index))]; + break; + case RT_DLSYM: + absolute_value = (CELL)get_rel_symbol(literals,index); + break; + case RT_IMMEDIATE: + absolute_value = array_nth(literals,index); + break; + case RT_XT: + absolute_value = object_xt(array_nth(literals,index)); + break; + case RT_XT_DIRECT: + absolute_value = word_direct_xt(array_nth(literals,index)); + break; + case RT_HERE: + absolute_value = offset + (short)to_fixnum(array_nth(literals,index)); + break; + case RT_THIS: + absolute_value = (CELL)(compiled + 1); + break; + case RT_STACK_CHAIN: + absolute_value = (CELL)&stack_chain; + break; + case RT_UNTAGGED: + absolute_value = to_fixnum(array_nth(literals,index)); + break; + default: + critical_error("Bad rel type",rel); + return; /* Can't happen */ + } + + store_address_in_code_block(REL_CLASS(rel),offset,absolute_value); +} + +/* Perform all fixups on a code block */ +void relocate_code_block(F_CODE_BLOCK *compiled) +{ + compiled->block.last_scan = NURSERY; + compiled->block.needs_fixup = false; + iterate_relocations(compiled,relocate_code_block_step); + flush_icache_for(compiled); +} + +/* Fixup labels. This is done at compile time, not image load time */ +void fixup_labels(F_ARRAY *labels, F_CODE_BLOCK *compiled) +{ + CELL i; + CELL size = array_capacity(labels); + + for(i = 0; i < size; i += 3) + { + CELL klass = to_fixnum(array_nth(labels,i)); + CELL offset = to_fixnum(array_nth(labels,i + 1)); + CELL target = to_fixnum(array_nth(labels,i + 2)); + + store_address_in_code_block(klass, + offset + (CELL)(compiled + 1), + target + (CELL)(compiled + 1)); + } +} + +/* Might GC */ +F_CODE_BLOCK *allot_code_block(CELL size) +{ + F_BLOCK *block = heap_allot(&code_heap,size + sizeof(F_CODE_BLOCK)); + + /* If allocation failed, do a code GC */ + if(block == NULL) + { + gc(); + block = heap_allot(&code_heap,size + sizeof(F_CODE_BLOCK)); + + /* Insufficient room even after code GC, give up */ + if(block == NULL) + { + CELL used, total_free, max_free; + heap_usage(&code_heap,&used,&total_free,&max_free); + + print_string("Code heap stats:\n"); + print_string("Used: "); print_cell(used); nl(); + print_string("Total free space: "); print_cell(total_free); nl(); + print_string("Largest free block: "); print_cell(max_free); nl(); + fatal_error("Out of memory in add-compiled-block",0); + } + } + + return (F_CODE_BLOCK *)block; +} + +/* Might GC */ +F_CODE_BLOCK *add_code_block( + CELL type, + F_BYTE_ARRAY *code, + F_ARRAY *labels, + CELL relocation, + CELL literals) +{ +#ifdef FACTOR_DEBUG + type_check(ARRAY_TYPE,literals); + type_check(BYTE_ARRAY_TYPE,relocation); + assert(untag_header(code->header) == BYTE_ARRAY_TYPE); +#endif + + CELL code_length = align8(array_capacity(code)); + + REGISTER_ROOT(literals); + REGISTER_ROOT(relocation); + REGISTER_UNTAGGED(code); + REGISTER_UNTAGGED(labels); + + F_CODE_BLOCK *compiled = allot_code_block(code_length); + + UNREGISTER_UNTAGGED(F_ARRAY,labels); + UNREGISTER_UNTAGGED(F_BYTE_ARRAY,code); + UNREGISTER_ROOT(relocation); + UNREGISTER_ROOT(literals); + + /* slight space optimization */ + if(type_of(literals) == ARRAY_TYPE && array_capacity(untag_array_fast(literals)) == 0) + literals = F; + + /* compiled header */ + compiled->block.type = type; + compiled->block.last_scan = NURSERY; + compiled->block.needs_fixup = true; + compiled->literals = literals; + compiled->relocation = relocation; + + /* code */ + memcpy(compiled + 1,code + 1,code_length); + + /* fixup labels */ + if(labels) fixup_labels(labels,compiled); + + /* next time we do a minor GC, we have to scan the code heap for + literals */ + last_code_heap_scan = NURSERY; + + return compiled; +} diff --git a/vmpp/code_block.hpp b/vmpp/code_block.hpp new file mode 100644 index 0000000000..a8350ad5cb --- /dev/null +++ b/vmpp/code_block.hpp @@ -0,0 +1,92 @@ +typedef enum { + /* arg is a primitive number */ + RT_PRIMITIVE, + /* arg is a literal table index, holding an array pair (symbol/dll) */ + RT_DLSYM, + /* a pointer to a compiled word reference */ + RT_DISPATCH, + /* a word's general entry point XT */ + RT_XT, + /* a word's direct entry point XT */ + RT_XT_DIRECT, + /* current offset */ + RT_HERE, + /* current code block */ + RT_THIS, + /* immediate literal */ + RT_IMMEDIATE, + /* address of stack_chain var */ + RT_STACK_CHAIN, + /* untagged fixnum literal */ + RT_UNTAGGED, +} F_RELTYPE; + +typedef enum { + /* absolute address in a 64-bit location */ + RC_ABSOLUTE_CELL, + /* absolute address in a 32-bit location */ + RC_ABSOLUTE, + /* relative address in a 32-bit location */ + RC_RELATIVE, + /* relative address in a PowerPC LIS/ORI sequence */ + RC_ABSOLUTE_PPC_2_2, + /* relative address in a PowerPC LWZ/STW/BC instruction */ + RC_RELATIVE_PPC_2, + /* relative address in a PowerPC B/BL instruction */ + RC_RELATIVE_PPC_3, + /* relative address in an ARM B/BL instruction */ + RC_RELATIVE_ARM_3, + /* pointer to address in an ARM LDR/STR instruction */ + RC_INDIRECT_ARM, + /* pointer to address in an ARM LDR/STR instruction offset by 8 bytes */ + RC_INDIRECT_ARM_PC +} F_RELCLASS; + +#define REL_RELATIVE_PPC_2_MASK 0xfffc +#define REL_RELATIVE_PPC_3_MASK 0x3fffffc +#define REL_INDIRECT_ARM_MASK 0xfff +#define REL_RELATIVE_ARM_3_MASK 0xffffff + +/* code relocation table consists of a table of entries for each fixup */ +typedef u32 F_REL; +#define REL_TYPE(r) (F_RELTYPE)(((r) & 0xf0000000) >> 28) +#define REL_CLASS(r) (F_RELCLASS)(((r) & 0x0f000000) >> 24) +#define REL_OFFSET(r) ((r) & 0x00ffffff) + +void flush_icache_for(F_CODE_BLOCK *compiled); + +typedef void (*RELOCATION_ITERATOR)(F_REL rel, CELL index, F_CODE_BLOCK *compiled); + +void iterate_relocations(F_CODE_BLOCK *compiled, RELOCATION_ITERATOR iter); + +void store_address_in_code_block(CELL klass, CELL offset, F_FIXNUM absolute_value); + +void relocate_code_block(F_CODE_BLOCK *compiled); + +void update_literal_references(F_CODE_BLOCK *compiled); + +void copy_literal_references(F_CODE_BLOCK *compiled); + +void update_word_references(F_CODE_BLOCK *compiled); + +void update_literal_and_word_references(F_CODE_BLOCK *compiled); + +void mark_code_block(F_CODE_BLOCK *compiled); + +void mark_active_blocks(F_CONTEXT *stacks); + +void mark_object_code_block(CELL scan); + +void relocate_code_block(F_CODE_BLOCK *relocating); + +INLINE bool stack_traces_p(void) +{ + return userenv[STACK_TRACES_ENV] != F; +} + +F_CODE_BLOCK *add_code_block( + CELL type, + F_BYTE_ARRAY *code, + F_ARRAY *labels, + CELL relocation, + CELL literals); diff --git a/vmpp/code_gc.cpp b/vmpp/code_gc.cpp new file mode 100755 index 0000000000..174622ff17 --- /dev/null +++ b/vmpp/code_gc.cpp @@ -0,0 +1,336 @@ +#include "master.hpp" + +static void clear_free_list(F_HEAP *heap) +{ + memset(&heap->free,0,sizeof(F_HEAP_FREE_LIST)); +} + +/* This malloc-style heap code is reasonably generic. Maybe in the future, it +will be used for the data heap too, if we ever get incremental +mark/sweep/compact GC. */ +void new_heap(F_HEAP *heap, CELL size) +{ + heap->segment = alloc_segment(align_page(size)); + if(!heap->segment) + fatal_error("Out of memory in new_heap",size); + + clear_free_list(heap); +} + +static void add_to_free_list(F_HEAP *heap, F_FREE_BLOCK *block) +{ + if(block->block.size < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT) + { + int index = block->block.size / BLOCK_SIZE_INCREMENT; + block->next_free = heap->free.small_blocks[index]; + heap->free.small_blocks[index] = block; + } + else + { + block->next_free = heap->free.large_blocks; + heap->free.large_blocks = block; + } +} + +/* Called after reading the code heap from the image file, and after code GC. + +In the former case, we must add a large free block from compiling.base + size to +compiling.limit. */ +void build_free_list(F_HEAP *heap, CELL size) +{ + F_BLOCK *prev = NULL; + + clear_free_list(heap); + + size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1); + + F_BLOCK *scan = first_block(heap); + F_FREE_BLOCK *end = (F_FREE_BLOCK *)(heap->segment->start + size); + + /* Add all free blocks to the free list */ + while(scan && scan < (F_BLOCK *)end) + { + switch(scan->status) + { + case B_FREE: + add_to_free_list(heap,(F_FREE_BLOCK *)scan); + break; + case B_ALLOCATED: + break; + default: + critical_error("Invalid scan->status",(CELL)scan); + break; + } + + prev = scan; + scan = next_block(heap,scan); + } + + /* If there is room at the end of the heap, add a free block. This + branch is only taken after loading a new image, not after code GC */ + if((CELL)(end + 1) <= heap->segment->end) + { + end->block.status = B_FREE; + end->block.size = heap->segment->end - (CELL)end; + + /* add final free block */ + add_to_free_list(heap,end); + } + /* This branch is taken if the newly loaded image fits exactly, or + after code GC */ + else + { + /* even if there's no room at the end of the heap for a new + free block, we might have to jigger it up by a few bytes in + case prev + prev->size */ + if(prev) prev->size = heap->segment->end - (CELL)prev; + } + +} + +static void assert_free_block(F_FREE_BLOCK *block) +{ + if(block->block.status != B_FREE) + critical_error("Invalid block in free list",(CELL)block); +} + +static F_FREE_BLOCK *find_free_block(F_HEAP *heap, CELL size) +{ + CELL attempt = size; + + while(attempt < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT) + { + int index = attempt / BLOCK_SIZE_INCREMENT; + F_FREE_BLOCK *block = heap->free.small_blocks[index]; + if(block) + { + assert_free_block(block); + heap->free.small_blocks[index] = block->next_free; + return block; + } + + attempt *= 2; + } + + F_FREE_BLOCK *prev = NULL; + F_FREE_BLOCK *block = heap->free.large_blocks; + + while(block) + { + assert_free_block(block); + if(block->block.size >= size) + { + if(prev) + prev->next_free = block->next_free; + else + heap->free.large_blocks = block->next_free; + return block; + } + + prev = block; + block = block->next_free; + } + + return NULL; +} + +static F_FREE_BLOCK *split_free_block(F_HEAP *heap, F_FREE_BLOCK *block, CELL size) +{ + if(block->block.size != size ) + { + /* split the block in two */ + F_FREE_BLOCK *split = (F_FREE_BLOCK *)((CELL)block + size); + split->block.status = B_FREE; + split->block.size = block->block.size - size; + split->next_free = block->next_free; + block->block.size = size; + add_to_free_list(heap,split); + } + + return block; +} + +/* Allocate a block of memory from the mark and sweep GC heap */ +F_BLOCK *heap_allot(F_HEAP *heap, CELL size) +{ + size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1); + + F_FREE_BLOCK *block = find_free_block(heap,size); + if(block) + { + block = split_free_block(heap,block,size); + + block->block.status = B_ALLOCATED; + return &block->block; + } + else + return NULL; +} + +/* Deallocates a block manually */ +void heap_free(F_HEAP *heap, F_BLOCK *block) +{ + block->status = B_FREE; + add_to_free_list(heap,(F_FREE_BLOCK *)block); +} + +void mark_block(F_BLOCK *block) +{ + /* If already marked, do nothing */ + switch(block->status) + { + case B_MARKED: + return; + case B_ALLOCATED: + block->status = B_MARKED; + break; + default: + critical_error("Marking the wrong block",(CELL)block); + break; + } +} + +/* If in the middle of code GC, we have to grow the heap, data GC restarts from +scratch, so we have to unmark any marked blocks. */ +void unmark_marked(F_HEAP *heap) +{ + F_BLOCK *scan = first_block(heap); + + while(scan) + { + if(scan->status == B_MARKED) + scan->status = B_ALLOCATED; + + scan = next_block(heap,scan); + } +} + +/* After code GC, all referenced code blocks have status set to B_MARKED, so any +which are allocated and not marked can be reclaimed. */ +void free_unmarked(F_HEAP *heap, HEAP_ITERATOR iter) +{ + clear_free_list(heap); + + F_BLOCK *prev = NULL; + F_BLOCK *scan = first_block(heap); + + while(scan) + { + switch(scan->status) + { + case B_ALLOCATED: + if(secure_gc) + memset(scan + 1,0,scan->size - sizeof(F_BLOCK)); + + if(prev && prev->status == B_FREE) + prev->size += scan->size; + else + { + scan->status = B_FREE; + prev = scan; + } + break; + case B_FREE: + if(prev && prev->status == B_FREE) + prev->size += scan->size; + else + prev = scan; + break; + case B_MARKED: + if(prev && prev->status == B_FREE) + add_to_free_list(heap,(F_FREE_BLOCK *)prev); + scan->status = B_ALLOCATED; + prev = scan; + iter(scan); + break; + default: + critical_error("Invalid scan->status",(CELL)scan); + } + + scan = next_block(heap,scan); + } + + if(prev && prev->status == B_FREE) + add_to_free_list(heap,(F_FREE_BLOCK *)prev); +} + +/* Compute total sum of sizes of free blocks, and size of largest free block */ +void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free) +{ + *used = 0; + *total_free = 0; + *max_free = 0; + + F_BLOCK *scan = first_block(heap); + + while(scan) + { + switch(scan->status) + { + case B_ALLOCATED: + *used += scan->size; + break; + case B_FREE: + *total_free += scan->size; + if(scan->size > *max_free) + *max_free = scan->size; + break; + default: + critical_error("Invalid scan->status",(CELL)scan); + } + + scan = next_block(heap,scan); + } +} + +/* The size of the heap, not including the last block if it's free */ +CELL heap_size(F_HEAP *heap) +{ + F_BLOCK *scan = first_block(heap); + + while(next_block(heap,scan) != NULL) + scan = next_block(heap,scan); + + /* this is the last block in the heap, and it is free */ + if(scan->status == B_FREE) + return (CELL)scan - heap->segment->start; + /* otherwise the last block is allocated */ + else + return heap->segment->size; +} + +/* Compute where each block is going to go, after compaction */ +CELL compute_heap_forwarding(F_HEAP *heap) +{ + F_BLOCK *scan = first_block(heap); + CELL address = (CELL)first_block(heap); + + while(scan) + { + if(scan->status == B_ALLOCATED) + { + scan->forwarding = (F_BLOCK *)address; + address += scan->size; + } + else if(scan->status == B_MARKED) + critical_error("Why is the block marked?",0); + + scan = next_block(heap,scan); + } + + return address - heap->segment->start; +} + +void compact_heap(F_HEAP *heap) +{ + F_BLOCK *scan = first_block(heap); + + while(scan) + { + F_BLOCK *next = next_block(heap,scan); + + if(scan->status == B_ALLOCATED && scan != scan->forwarding) + memcpy(scan->forwarding,scan,scan->size); + scan = next; + } +} diff --git a/vmpp/code_gc.hpp b/vmpp/code_gc.hpp new file mode 100755 index 0000000000..35f8d66d90 --- /dev/null +++ b/vmpp/code_gc.hpp @@ -0,0 +1,45 @@ +#define FREE_LIST_COUNT 16 +#define BLOCK_SIZE_INCREMENT 32 + +typedef struct { + F_FREE_BLOCK *small_blocks[FREE_LIST_COUNT]; + F_FREE_BLOCK *large_blocks; +} F_HEAP_FREE_LIST; + +typedef struct { + F_SEGMENT *segment; + F_HEAP_FREE_LIST free; +} F_HEAP; + +typedef void (*HEAP_ITERATOR)(F_BLOCK *compiled); + +void new_heap(F_HEAP *heap, CELL size); +void build_free_list(F_HEAP *heap, CELL size); +F_BLOCK *heap_allot(F_HEAP *heap, CELL size); +void heap_free(F_HEAP *heap, F_BLOCK *block); +void mark_block(F_BLOCK *block); +void unmark_marked(F_HEAP *heap); +void free_unmarked(F_HEAP *heap, HEAP_ITERATOR iter); +void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free); +CELL heap_size(F_HEAP *heap); +CELL compute_heap_forwarding(F_HEAP *heap); +void compact_heap(F_HEAP *heap); + +INLINE F_BLOCK *next_block(F_HEAP *heap, F_BLOCK *block) +{ + CELL next = ((CELL)block + block->size); + if(next == heap->segment->end) + return NULL; + else + return (F_BLOCK *)next; +} + +INLINE F_BLOCK *first_block(F_HEAP *heap) +{ + return (F_BLOCK *)heap->segment->start; +} + +INLINE F_BLOCK *last_block(F_HEAP *heap) +{ + return (F_BLOCK *)heap->segment->end; +} diff --git a/vmpp/code_heap.cpp b/vmpp/code_heap.cpp new file mode 100755 index 0000000000..1545dbeaf6 --- /dev/null +++ b/vmpp/code_heap.cpp @@ -0,0 +1,228 @@ +#include "master.hpp" + +F_HEAP code_heap; + +/* Allocate a code heap during startup */ +void init_code_heap(CELL size) +{ + new_heap(&code_heap,size); +} + +bool in_code_heap_p(CELL ptr) +{ + return (ptr >= code_heap.segment->start + && ptr <= code_heap.segment->end); +} + +/* Compile a word definition with the non-optimizing compiler. Allocates memory */ +void jit_compile_word(F_WORD *word, CELL def, bool relocate) +{ + REGISTER_ROOT(def); + REGISTER_UNTAGGED(word); + jit_compile(def,relocate); + UNREGISTER_UNTAGGED(F_WORD,word); + UNREGISTER_ROOT(def); + + word->code = untag_quotation(def)->code; + + if(word->direct_entry_def != F) + jit_compile(word->direct_entry_def,relocate); +} + +/* Apply a function to every code block */ +void iterate_code_heap(CODE_HEAP_ITERATOR iter) +{ + F_BLOCK *scan = first_block(&code_heap); + + while(scan) + { + if(scan->status != B_FREE) + iter((F_CODE_BLOCK *)scan); + scan = next_block(&code_heap,scan); + } +} + +/* Copy literals referenced from all code blocks to newspace. Only for +aging and nursery collections */ +void copy_code_heap_roots(void) +{ + iterate_code_heap(copy_literal_references); +} + +/* Update pointers to words referenced from all code blocks. Only after +defining a new word. */ +void update_code_heap_words(void) +{ + iterate_code_heap(update_word_references); +} + +void primitive_modify_code_heap(void) +{ + F_ARRAY *alist = untag_array(dpop()); + + CELL count = untag_fixnum_fast(alist->capacity); + if(count == 0) + return; + + CELL i; + for(i = 0; i < count; i++) + { + F_ARRAY *pair = untag_array(array_nth(alist,i)); + + F_WORD *word = untag_word(array_nth(pair,0)); + + CELL data = array_nth(pair,1); + + if(type_of(data) == QUOTATION_TYPE) + { + REGISTER_UNTAGGED(alist); + REGISTER_UNTAGGED(word); + jit_compile_word(word,data,false); + UNREGISTER_UNTAGGED(F_WORD,word); + UNREGISTER_UNTAGGED(F_ARRAY,alist); + } + else if(type_of(data) == ARRAY_TYPE) + { + F_ARRAY *compiled_code = untag_array(data); + + CELL literals = array_nth(compiled_code,0); + CELL relocation = array_nth(compiled_code,1); + F_ARRAY *labels = untag_array(array_nth(compiled_code,2)); + F_BYTE_ARRAY *code = untag_byte_array(array_nth(compiled_code,3)); + + REGISTER_UNTAGGED(alist); + REGISTER_UNTAGGED(word); + + F_CODE_BLOCK *compiled = add_code_block( + WORD_TYPE, + code, + labels, + relocation, + literals); + + UNREGISTER_UNTAGGED(F_WORD,word); + UNREGISTER_UNTAGGED(F_ARRAY,alist); + + word->code = compiled; + } + else + critical_error("Expected a quotation or an array",data); + + REGISTER_UNTAGGED(alist); + update_word_xt(word); + UNREGISTER_UNTAGGED(F_ARRAY,alist); + } + + update_code_heap_words(); +} + +/* Push the free space and total size of the code heap */ +void primitive_code_room(void) +{ + CELL used, total_free, max_free; + heap_usage(&code_heap,&used,&total_free,&max_free); + dpush(tag_fixnum((code_heap.segment->size) / 1024)); + dpush(tag_fixnum(used / 1024)); + dpush(tag_fixnum(total_free / 1024)); + dpush(tag_fixnum(max_free / 1024)); +} + +F_CODE_BLOCK *forward_xt(F_CODE_BLOCK *compiled) +{ + return (F_CODE_BLOCK *)compiled->block.forwarding; +} + +void forward_frame_xt(F_STACK_FRAME *frame) +{ + CELL offset = (CELL)FRAME_RETURN_ADDRESS(frame) - (CELL)frame_code(frame); + F_CODE_BLOCK *forwarded = forward_xt(frame_code(frame)); + frame->xt = (XT)(forwarded + 1); + FRAME_RETURN_ADDRESS(frame) = (XT)((CELL)forwarded + offset); +} + +void forward_object_xts(void) +{ + begin_scan(); + + CELL obj; + + while((obj = next_object()) != F) + { + if(type_of(obj) == WORD_TYPE) + { + F_WORD *word = untag_word_fast(obj); + + word->code = forward_xt(word->code); + if(word->profiling) + word->profiling = forward_xt(word->profiling); + } + else if(type_of(obj) == QUOTATION_TYPE) + { + F_QUOTATION *quot = untag_quotation_fast(obj); + + if(quot->compiledp != F) + quot->code = forward_xt(quot->code); + } + else if(type_of(obj) == CALLSTACK_TYPE) + { + F_CALLSTACK *stack = untag_callstack_fast(obj); + iterate_callstack_object(stack,forward_frame_xt); + } + } + + /* End the heap scan */ + gc_off = false; +} + +/* Set the XT fields now that the heap has been compacted */ +void fixup_object_xts(void) +{ + begin_scan(); + + CELL obj; + + while((obj = next_object()) != F) + { + if(type_of(obj) == WORD_TYPE) + { + F_WORD *word = untag_word_fast(obj); + update_word_xt(word); + } + else if(type_of(obj) == QUOTATION_TYPE) + { + F_QUOTATION *quot = untag_quotation_fast(obj); + + if(quot->compiledp != F) + set_quot_xt(quot,quot->code); + } + } + + /* End the heap scan */ + gc_off = false; +} + +/* Move all free space to the end of the code heap. This is not very efficient, +since it makes several passes over the code and data heaps, but we only ever +do this before saving a deployed image and exiting, so performaance is not +critical here */ +void compact_code_heap(void) +{ + /* Free all unreachable code blocks */ + gc(); + + /* Figure out where the code heap blocks are going to end up */ + CELL size = compute_heap_forwarding(&code_heap); + + /* Update word and quotation code pointers */ + forward_object_xts(); + + /* Actually perform the compaction */ + compact_heap(&code_heap); + + /* Update word and quotation XTs */ + fixup_object_xts(); + + /* Now update the free list; there will be a single free block at + the end */ + build_free_list(&code_heap,size); +} diff --git a/vmpp/code_heap.hpp b/vmpp/code_heap.hpp new file mode 100755 index 0000000000..e312d0ccd4 --- /dev/null +++ b/vmpp/code_heap.hpp @@ -0,0 +1,27 @@ +/* compiled code */ +extern F_HEAP code_heap; + +void init_code_heap(CELL size); + +bool in_code_heap_p(CELL ptr); + +void jit_compile_word(F_WORD *word, CELL def, bool relocate); + +typedef void (*CODE_HEAP_ITERATOR)(F_CODE_BLOCK *compiled); + +void iterate_code_heap(CODE_HEAP_ITERATOR iter); + +void copy_code_heap_roots(void); + +void primitive_modify_code_heap(void); + +void primitive_code_room(void); + +void compact_code_heap(void); + +INLINE void check_code_pointer(CELL pointer) +{ +#ifdef FACTOR_DEBUG + assert(pointer >= code_heap.segment->start && pointer < code_heap.segment->end); +#endif +} diff --git a/vmpp/cpu-arm.S b/vmpp/cpu-arm.S new file mode 100755 index 0000000000..09e3331b99 --- /dev/null +++ b/vmpp/cpu-arm.S @@ -0,0 +1,127 @@ +#include "asm.h" + +/* Note that the XT is passed to the quotation in r12 */ +#define CALL_QUOT \ + ldr r12,[r0, #9] /* load quotation-xt slot */ ; \ + mov lr,pc ; \ + mov pc,r12 + +#define JUMP_QUOT \ + ldr r12,[r0, #9] /* load quotation-xt slot */ ; \ + mov pc,r12 + +#define SAVED_REGS_SIZE 32 + +#define FRAME (RESERVED_SIZE + SAVED_REGS_SIZE + 8) + +#define LR_SAVE [sp, #-4] +#define RESERVED_SIZE 8 + +#define SAVE_LR str lr,LR_SAVE + +#define LOAD_LR ldr lr,LR_SAVE + +#define SAVE_AT(offset) (RESERVED_SIZE + 4 * offset) + +#define SAVE(register,offset) str register,[sp, #SAVE_AT(offset)] + +#define RESTORE(register,offset) ldr register,[sp, #SAVE_AT(offset)] + +#define PROLOGUE \ + SAVE_LR ; \ + sub sp,sp,#FRAME + +#define EPILOGUE \ + add sp,sp,#FRAME ; \ + LOAD_LR + +DEF(void,c_to_factor,(CELL quot)): + PROLOGUE + + SAVE(r4,0) /* save GPRs */ + /* don't save ds pointer */ + /* don't save rs pointer */ + SAVE(r7,3) + SAVE(r8,4) + SAVE(r9,5) + SAVE(r10,6) + SAVE(r11,7) + SAVE(r0,8) /* save quotation since we're about to mangle it */ + + sub r0,sp,#4 /* pass call stack pointer as an argument */ + bl MANGLE(save_callstack_bottom) + + RESTORE(r0,8) /* restore quotation */ + CALL_QUOT + + RESTORE(r11,7) /* restore GPRs */ + RESTORE(r10,6) + RESTORE(r9,5) + RESTORE(r8,4) + RESTORE(r7,3) + /* don't restore rs pointer */ + /* don't restore ds pointer */ + RESTORE(r4,0) + + EPILOGUE + mov pc,lr + +/* The JIT compiles an 'mov r1',sp in front of every primitive call, since a +word which was defined as a primitive will not change its definition for the +lifetime of the image -- adding new primitives requires a bootstrap. However, +an undefined word can certainly become defined, + +DEFER: foo +... +: foo ... ; + +And calls to non-primitives do not have this one-instruction prologue, so we +set the XT of undefined words to this symbol. */ +DEF(void,undefined,(CELL word)): + sub r1,sp,#4 + b MANGLE(undefined_error) + +/* Here we have two entry points. The first one is taken when profiling is +enabled */ +DEF(void,docol_profiling,(CELL word)): + ldr r1,[r0, #25] /* load profile-count slot */ + add r1,r1,#8 /* increment count */ + str r1,[r0, #25] /* store profile-count slot */ +DEF(void,docol,(CELL word)): + ldr r0,[r0, #13] /* load word-def slot */ + JUMP_QUOT + +/* We must pass the XT to the quotation in r12. */ +DEF(void,primitive_call,(void)): + ldr r0,[r5], #-4 /* load quotation from data stack */ + JUMP_QUOT + +/* We must preserve r1 here in case we're calling a primitive */ +DEF(void,primitive_execute,(void)): + ldr r0,[r5], #-4 /* load word from data stack */ + ldr pc,[r0, #29] /* jump to word-xt */ + +DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length)): + sub sp,r0,r2 /* compute new stack pointer */ + mov r0,sp /* start of destination of memcpy() */ + sub sp,sp,#12 /* alignment */ + bl MANGLE(memcpy) /* go */ + add sp,sp,#16 /* point SP at innermost frame */ + ldr pc,LR_SAVE /* return */ + +DEF(void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)): + add sp,r1,#4 /* compute new stack pointer */ + ldr lr,LR_SAVE /* we have rewound the stack; load return address */ + JUMP_QUOT /* call the quotation */ + +DEF(void,lazy_jit_compile,(CELL quot)): + mov r1,sp /* save stack pointer */ + PROLOGUE + bl MANGLE(lazy_jit_compile_impl) + EPILOGUE + JUMP_QUOT /* call the quotation */ + +#ifdef WINCE + .section .drectve + .ascii " -export:c_to_factor" +#endif diff --git a/vmpp/cpu-arm.hpp b/vmpp/cpu-arm.hpp new file mode 100755 index 0000000000..e6ea0a1158 --- /dev/null +++ b/vmpp/cpu-arm.hpp @@ -0,0 +1,13 @@ +#define FACTOR_CPU_STRING "arm" + +register CELL ds asm("r5"); +register CELL rs asm("r6"); + +#define F_FASTCALL + +#define FRAME_RETURN_ADDRESS(frame) *(XT *)(frame_successor(frame) + 1) + +void c_to_factor(CELL quot); +void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy); +void throw_impl(CELL quot, F_STACK_FRAME *rewind); +void lazy_jit_compile(CELL quot); diff --git a/vmpp/cpu-ppc.S b/vmpp/cpu-ppc.S new file mode 100755 index 0000000000..5e77c004aa --- /dev/null +++ b/vmpp/cpu-ppc.S @@ -0,0 +1,236 @@ +/* Parts of this file were snarfed from SBCL src/runtime/ppc-assem.S, which is +in the public domain. */ +#include "asm.h" + +#define DS_REG r29 + +DEF(void,primitive_fixnum_add,(void)): + lwz r3,0(DS_REG) + lwz r4,-4(DS_REG) + subi DS_REG,DS_REG,4 + li r0,0 + mtxer r0 + addo. r5,r3,r4 + bso add_overflow + stw r5,0(DS_REG) + blr +add_overflow: + b MANGLE(overflow_fixnum_add) + +DEF(void,primitive_fixnum_subtract,(void)): + lwz r3,-4(DS_REG) + lwz r4,0(DS_REG) + subi DS_REG,DS_REG,4 + li r0,0 + mtxer r0 + subfo. r5,r4,r3 + bso sub_overflow + stw r5,0(DS_REG) + blr +sub_overflow: + b MANGLE(overflow_fixnum_subtract) + +DEF(void,primitive_fixnum_multiply,(void)): + lwz r3,0(DS_REG) + lwz r4,-4(DS_REG) + subi DS_REG,DS_REG,4 + srawi r3,r3,3 + mullwo. r5,r3,r4 + bso multiply_overflow + stw r5,0(DS_REG) + blr +multiply_overflow: + srawi r4,r4,3 + b MANGLE(overflow_fixnum_multiply) + +/* Note that the XT is passed to the quotation in r11 */ +#define CALL_OR_JUMP_QUOT \ + lwz r11,14(r3) /* load quotation-xt slot */ XX \ + +#define CALL_QUOT \ + CALL_OR_JUMP_QUOT XX \ + mtlr r11 /* prepare to call XT with quotation in r3 */ XX \ + blrl /* go */ + +#define JUMP_QUOT \ + CALL_OR_JUMP_QUOT XX \ + mtctr r11 /* prepare to call XT with quotation in r3 */ XX \ + bctr /* go */ + +#define PARAM_SIZE 32 + +#define SAVED_INT_REGS_SIZE 96 + +#define SAVED_FP_REGS_SIZE 144 + +#define FRAME (RESERVED_SIZE + PARAM_SIZE + SAVED_INT_REGS_SIZE + SAVED_FP_REGS_SIZE + 8) + +#if defined( __APPLE__) + #define LR_SAVE 8 + #define RESERVED_SIZE 24 +#else + #define LR_SAVE 4 + #define RESERVED_SIZE 8 +#endif + +#define SAVE_LR(reg) stw reg,(LR_SAVE + FRAME)(r1) + +#define LOAD_LR(reg) lwz reg,(LR_SAVE + FRAME)(r1) + +#define SAVE_AT(offset) (RESERVED_SIZE + PARAM_SIZE + 4 * offset) + +#define SAVE_INT(register,offset) stw register,SAVE_AT(offset)(r1) +#define RESTORE_INT(register,offset) lwz register,SAVE_AT(offset)(r1) + +#define SAVE_FP(register,offset) stfd register,SAVE_AT(offset)(r1) +#define RESTORE_FP(register,offset) lfd register,SAVE_AT(offset)(r1) + +#define PROLOGUE \ + mflr r0 XX /* get caller's return address */ \ + stwu r1,-FRAME(r1) XX /* create a stack frame to hold non-volatile registers */ \ + SAVE_LR(r0) + +#define EPILOGUE \ + LOAD_LR(r0) XX \ + lwz r1,0(r1) XX /* destroy the stack frame */ \ + mtlr r0 /* get ready to return */ + +/* We have to save and restore nonvolatile registers because +the Factor compiler treats the entire register file as volatile. */ +DEF(void,c_to_factor,(CELL quot)): + PROLOGUE + + SAVE_INT(r13,0) /* save GPRs */ + SAVE_INT(r14,1) + SAVE_INT(r15,2) + SAVE_INT(r16,3) + SAVE_INT(r17,4) + SAVE_INT(r18,5) + SAVE_INT(r19,6) + SAVE_INT(r20,7) + SAVE_INT(r21,8) + SAVE_INT(r22,9) + SAVE_INT(r23,10) + SAVE_INT(r24,11) + SAVE_INT(r25,12) + SAVE_INT(r26,13) + SAVE_INT(r27,14) + SAVE_INT(r28,15) + SAVE_INT(r31,16) + + SAVE_FP(f14,20) /* save FPRs */ + SAVE_FP(f15,22) + SAVE_FP(f16,24) + SAVE_FP(f17,26) + SAVE_FP(f18,28) + SAVE_FP(f19,30) + SAVE_FP(f20,32) + SAVE_FP(f21,34) + SAVE_FP(f22,36) + SAVE_FP(f23,38) + SAVE_FP(f24,40) + SAVE_FP(f25,42) + SAVE_FP(f26,44) + SAVE_FP(f27,46) + SAVE_FP(f28,48) + SAVE_FP(f29,50) + SAVE_FP(f30,52) + SAVE_FP(f31,54) + + SAVE_INT(r3,19) /* save quotation since we're about to mangle it */ + + mr r3,r1 /* pass call stack pointer as an argument */ + bl MANGLE(save_callstack_bottom) + + RESTORE_INT(r3,19) /* restore quotation */ + CALL_QUOT + + RESTORE_FP(f31,54) + RESTORE_FP(f30,52) + RESTORE_FP(f29,50) + RESTORE_FP(f28,48) + RESTORE_FP(f27,46) + RESTORE_FP(f26,44) + RESTORE_FP(f25,42) + RESTORE_FP(f24,40) + RESTORE_FP(f23,38) + RESTORE_FP(f22,36) + RESTORE_FP(f21,34) + RESTORE_FP(f20,32) + RESTORE_FP(f19,30) + RESTORE_FP(f18,28) + RESTORE_FP(f17,26) + RESTORE_FP(f16,24) + RESTORE_FP(f15,22) + RESTORE_FP(f14,20) /* save FPRs */ + + RESTORE_INT(r31,16) /* restore GPRs */ + RESTORE_INT(r28,15) + RESTORE_INT(r27,14) + RESTORE_INT(r26,13) + RESTORE_INT(r25,12) + RESTORE_INT(r24,11) + RESTORE_INT(r23,10) + RESTORE_INT(r22,9) + RESTORE_INT(r21,8) + RESTORE_INT(r20,7) + RESTORE_INT(r19,6) + RESTORE_INT(r18,5) + RESTORE_INT(r17,4) + RESTORE_INT(r16,3) + RESTORE_INT(r15,2) + RESTORE_INT(r14,1) + RESTORE_INT(r13,0) + + EPILOGUE + blr + +/* We pass a function pointer to memcpy in r6 to work around a Mac OS X ABI +limitation which would otherwise require us to do a bizzaro PC-relative +trampoline to retrieve the function address */ +DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy)): + sub r1,r3,r5 /* compute new stack pointer */ + mr r3,r1 /* start of destination of memcpy() */ + stwu r1,-64(r1) /* setup fake stack frame for memcpy() */ + mtlr r6 /* prepare to call memcpy() */ + blrl /* go */ + lwz r1,0(r1) /* tear down fake stack frame */ + lwz r0,LR_SAVE(r1) /* we have restored the stack; load return address */ + mtlr r0 /* prepare to return to restored callstack */ + blr /* go */ + +DEF(void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)): + mr r1,r4 /* compute new stack pointer */ + lwz r0,LR_SAVE(r1) /* we have rewound the stack; load return address */ + mtlr r0 + JUMP_QUOT /* call the quotation */ + +DEF(void,lazy_jit_compile,(CELL quot)): + mr r4,r1 /* save stack pointer */ + PROLOGUE + bl MANGLE(lazy_jit_compile_impl) + EPILOGUE + JUMP_QUOT /* call the quotation */ + +/* Thanks to Joshua Grams for this code. + +On PowerPC processors, we must flush the instruction cache manually +after writing to the code heap. */ + +DEF(void,flush_icache,(void *start, int len)): + /* compute number of cache lines to flush */ + add r4,r4,r3 + clrrwi r3,r3,5 /* align addr to next lower cache line boundary */ + sub r4,r4,r3 /* then n_lines = (len + 0x1f) / 0x20 */ + addi r4,r4,0x1f + srwi. r4,r4,5 /* note '.' suffix */ + beqlr /* if n_lines == 0, just return. */ + mtctr r4 /* flush cache lines */ +0: dcbf 0,r3 /* for each line... */ + sync + icbi 0,r3 + addi r3,r3,0x20 + bdnz 0b + sync /* finish up */ + isync + blr diff --git a/vmpp/cpu-ppc.hpp b/vmpp/cpu-ppc.hpp new file mode 100755 index 0000000000..298e21aa7d --- /dev/null +++ b/vmpp/cpu-ppc.hpp @@ -0,0 +1,12 @@ +#define FACTOR_CPU_STRING "ppc" +#define F_FASTCALL + +register CELL ds asm("r29"); +register CELL rs asm("r30"); + +void c_to_factor(CELL quot); +void undefined(CELL word); +void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy); +void throw_impl(CELL quot, F_STACK_FRAME *rewind); +void lazy_jit_compile(CELL quot); +void flush_icache(CELL start, CELL len); diff --git a/vmpp/cpu-x86.32.S b/vmpp/cpu-x86.32.S new file mode 100755 index 0000000000..3c0db36935 --- /dev/null +++ b/vmpp/cpu-x86.32.S @@ -0,0 +1,76 @@ +#include "asm.h" + +/* Note that primitive word definitions are compiled with +__attribute__((regparm 2), so the pointer to the word object is passed in EAX, +and the callstack top is passed in EDX */ + +#define ARG0 %eax +#define ARG1 %edx +#define STACK_REG %esp +#define DS_REG %esi +#define RETURN_REG %eax + +#define NV_TEMP_REG %ebx + +#define ARITH_TEMP_1 %ebp +#define ARITH_TEMP_2 %ebx +#define DIV_RESULT %eax + +#define CELL_SIZE 4 +#define STACK_PADDING 12 + +#define PUSH_NONVOLATILE \ + push %ebx ; \ + push %ebp ; \ + push %ebp + +#define POP_NONVOLATILE \ + pop %ebp ; \ + pop %ebp ; \ + pop %ebx + +#define QUOT_XT_OFFSET 16 +#define WORD_XT_OFFSET 30 + +/* We pass a function pointer to memcpy to work around a Mac OS X +ABI limitation which would otherwise require us to do a bizzaro PC-relative +trampoline to retrieve the function address */ +DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy)): + mov 4(%esp),%ebp /* to */ + mov 8(%esp),%edx /* from */ + mov 12(%esp),%ecx /* length */ + mov 16(%esp),%eax /* memcpy */ + sub %ecx,%ebp /* compute new stack pointer */ + mov %ebp,%esp + push %ecx /* pass length */ + push %edx /* pass src */ + push %ebp /* pass dst */ + call *%eax /* call memcpy */ + add $12,%esp /* pop args from the stack */ + ret /* return _with new stack_ */ + +/* cpu.x86.32 calls this */ +DEF(bool,check_sse2,(void)): + push %ebx + mov $1,%eax + cpuid + shr $26,%edx + and $1,%edx + pop %ebx + mov %edx,%eax + ret + +DEF(F_FASTCALL void,primitive_inline_cache_miss,(void)): + mov (%esp),%eax + sub $8,%esp + push %eax + call MANGLE(inline_cache_miss) + add $12,%esp + jmp *%eax + +#include "cpu-x86.S" + +#ifdef WINDOWS + .section .drectve + .ascii " -export:check_sse2" +#endif diff --git a/vmpp/cpu-x86.32.hpp b/vmpp/cpu-x86.32.hpp new file mode 100755 index 0000000000..0f99ce6130 --- /dev/null +++ b/vmpp/cpu-x86.32.hpp @@ -0,0 +1,6 @@ +#define FACTOR_CPU_STRING "x86.32" + +register CELL ds asm("esi"); +register CELL rs asm("edi"); + +#define F_FASTCALL extern "C" __attribute__ ((regparm (2))) diff --git a/vmpp/cpu-x86.64.S b/vmpp/cpu-x86.64.S new file mode 100644 index 0000000000..a110bf1d51 --- /dev/null +++ b/vmpp/cpu-x86.64.S @@ -0,0 +1,83 @@ +#include "asm.h" + +#define STACK_REG %rsp +#define DS_REG %r14 +#define RETURN_REG %rax + +#define CELL_SIZE 8 +#define STACK_PADDING 56 + +#define NV_TEMP_REG %rbp + +#define ARITH_TEMP_1 %r8 +#define ARITH_TEMP_2 %r9 +#define DIV_RESULT %rax + +#ifdef WINDOWS + + #define ARG0 %rcx + #define ARG1 %rdx + #define ARG2 %r8 + #define ARG3 %r9 + + #define PUSH_NONVOLATILE \ + push %r12 ; \ + push %r13 ; \ + push %rdi ; \ + push %rsi ; \ + push %rbx ; \ + push %rbp ; \ + push %rbp + + #define POP_NONVOLATILE \ + pop %rbp ; \ + pop %rbp ; \ + pop %rbx ; \ + pop %rsi ; \ + pop %rdi ; \ + pop %r13 ; \ + pop %r12 + +#else + + #define ARG0 %rdi + #define ARG1 %rsi + #define ARG2 %rdx + #define ARG3 %rcx + + #define PUSH_NONVOLATILE \ + push %rbx ; \ + push %rbp ; \ + push %r12 ; \ + push %r13 ; \ + push %r13 + + #define POP_NONVOLATILE \ + pop %r13 ; \ + pop %r13 ; \ + pop %r12 ; \ + pop %rbp ; \ + pop %rbx + +#endif + +#define QUOT_XT_OFFSET 36 +#define WORD_XT_OFFSET 66 + +/* We pass a function pointer to memcpy to work around a Mac OS X +ABI limitation which would otherwise require us to do a bizzaro PC-relative +trampoline to retrieve the function address */ +DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy)): + sub ARG2,ARG0 /* compute new stack pointer */ + mov ARG0,%rsp + call *ARG3 /* call memcpy */ + ret /* return _with new stack_ */ + +DEF(F_FASTCALL void,primitive_inline_cache_miss,(void)): + mov (%rsp),ARG0 + sub $STACK_PADDING,%rsp + call MANGLE(inline_cache_miss) + add $STACK_PADDING,%rsp + jmp *%rax + +#include "cpu-x86.S" diff --git a/vmpp/cpu-x86.64.hpp b/vmpp/cpu-x86.64.hpp new file mode 100644 index 0000000000..2876823b20 --- /dev/null +++ b/vmpp/cpu-x86.64.hpp @@ -0,0 +1,6 @@ +#define FACTOR_CPU_STRING "x86.64" + +register CELL ds asm("r14"); +register CELL rs asm("r15"); + +#define F_FASTCALL extern "C" diff --git a/vmpp/cpu-x86.S b/vmpp/cpu-x86.S new file mode 100755 index 0000000000..e83bb0fd7d --- /dev/null +++ b/vmpp/cpu-x86.S @@ -0,0 +1,74 @@ +DEF(void,primitive_fixnum_add,(void)): + mov (DS_REG),ARG0 + mov -CELL_SIZE(DS_REG),ARG1 + sub $CELL_SIZE,DS_REG + mov ARG1,ARITH_TEMP_1 + add ARG0,ARITH_TEMP_1 + jo MANGLE(overflow_fixnum_add) + mov ARITH_TEMP_1,(DS_REG) + ret + +DEF(void,primitive_fixnum_subtract,(void)): + mov (DS_REG),ARG1 + mov -CELL_SIZE(DS_REG),ARG0 + sub $CELL_SIZE,DS_REG + mov ARG0,ARITH_TEMP_1 + sub ARG1,ARITH_TEMP_1 + jo MANGLE(overflow_fixnum_subtract) + mov ARITH_TEMP_1,(DS_REG) + ret + +DEF(void,primitive_fixnum_multiply,(void)): + mov (DS_REG),ARITH_TEMP_1 + mov ARITH_TEMP_1,DIV_RESULT + mov -CELL_SIZE(DS_REG),ARITH_TEMP_2 + sar $3,ARITH_TEMP_2 + sub $CELL_SIZE,DS_REG + imul ARITH_TEMP_2 + jo multiply_overflow + mov DIV_RESULT,(DS_REG) + ret +multiply_overflow: + sar $3,ARITH_TEMP_1 + mov ARITH_TEMP_1,ARG0 + mov ARITH_TEMP_2,ARG1 + jmp MANGLE(overflow_fixnum_multiply) + +DEF(F_FASTCALL void,c_to_factor,(CELL quot)): + PUSH_NONVOLATILE + mov ARG0,NV_TEMP_REG + + /* Create register shadow area for Win64 */ + sub $32,STACK_REG + + /* Save stack pointer */ + lea -CELL_SIZE(STACK_REG),ARG0 + call MANGLE(save_callstack_bottom) + + /* Call quot-xt */ + mov NV_TEMP_REG,ARG0 + call *QUOT_XT_OFFSET(ARG0) + + /* Tear down register shadow area */ + add $32,STACK_REG + + POP_NONVOLATILE + ret + +DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)): + /* rewind_to */ + mov ARG1,STACK_REG + jmp *QUOT_XT_OFFSET(ARG0) + +DEF(F_FASTCALL void,lazy_jit_compile,(CELL quot)): + mov STACK_REG,ARG1 /* Save stack pointer */ + sub $STACK_PADDING,STACK_REG + call MANGLE(lazy_jit_compile_impl) + mov RETURN_REG,ARG0 /* No-op on 32-bit */ + add $STACK_PADDING,STACK_REG + jmp *QUOT_XT_OFFSET(ARG0) /* Call the quotation */ + +#ifdef WINDOWS + .section .drectve + .ascii " -export:c_to_factor" +#endif diff --git a/vmpp/cpu-x86.hpp b/vmpp/cpu-x86.hpp new file mode 100755 index 0000000000..4b3ac13819 --- /dev/null +++ b/vmpp/cpu-x86.hpp @@ -0,0 +1,45 @@ +#include + +#define FRAME_RETURN_ADDRESS(frame) *(XT *)(frame_successor(frame) + 1) + +INLINE void flush_icache(CELL start, CELL len) {} + +INLINE void check_call_site(CELL return_address) +{ + /* An x86 CALL instruction looks like so: + |e8|..|..|..|..| + where the ... are a PC-relative jump address. + The return_address points to right after the + instruction. */ +#ifdef FACTOR_DEBUG + assert(*(unsigned char *)(return_address - 5) == 0xe8); +#endif +} + +INLINE CELL get_call_target(CELL return_address) +{ + check_call_site(return_address); + return *(int *)(return_address - 4) + return_address; +} + +INLINE void set_call_target(CELL return_address, CELL target) +{ + check_call_site(return_address); + *(int *)(return_address - 4) = (target - return_address); +} + +/* Defined in assembly */ +extern "C" void primitive_fixnum_add(void); +extern "C" void primitive_fixnum_subtract(void); +extern "C" void primitive_fixnum_multiply(void); + +F_FASTCALL void c_to_factor(CELL quot); +F_FASTCALL void throw_impl(CELL quot, F_STACK_FRAME *rewind_to); +F_FASTCALL void lazy_jit_compile(CELL quot); + +extern "C" void set_callstack(F_STACK_FRAME *to, + F_STACK_FRAME *from, + CELL length, + void *(*memcpy)(void*,const void*, size_t)); + +extern "C" void primitive_inline_cache_miss(void); diff --git a/vmpp/data_gc.cpp b/vmpp/data_gc.cpp new file mode 100755 index 0000000000..07242d4d56 --- /dev/null +++ b/vmpp/data_gc.cpp @@ -0,0 +1,672 @@ +#include "master.hpp" + +/* used during garbage collection only */ +F_ZONE *newspace; +bool performing_gc; +bool performing_compaction; +CELL collecting_gen; + +/* if true, we collecting AGING space for the second time, so if it is still +full, we go on to collect TENURED */ +bool collecting_aging_again; + +/* in case a generation fills up in the middle of a gc, we jump back +up to try collecting the next generation. */ +jmp_buf gc_jmp; + +F_GC_STATS gc_stats[MAX_GEN_COUNT]; +u64 cards_scanned; +u64 decks_scanned; +u64 card_scan_time; +CELL code_heap_scans; + +/* What generation was being collected when copy_code_heap_roots() was last +called? Until the next call to add_code_block(), future +collections of younger generations don't have to touch the code +heap. */ +CELL last_code_heap_scan; + +/* sometimes we grow the heap */ +bool growing_data_heap; +F_DATA_HEAP *old_data_heap; + +void init_data_gc(void) +{ + performing_gc = false; + last_code_heap_scan = NURSERY; + collecting_aging_again = false; +} + +/* Scan all the objects in the card */ +void copy_card(F_CARD *ptr, CELL gen, CELL here) +{ + CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + CARD_OFFSET(ptr); + CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1); + + if(here < card_end) + card_end = here; + + copy_reachable_objects(card_scan,&card_end); + + cards_scanned++; +} + +void copy_card_deck(F_DECK *deck, CELL gen, F_CARD mask, F_CARD unmask) +{ + F_CARD *first_card = DECK_TO_CARD(deck); + F_CARD *last_card = DECK_TO_CARD(deck + 1); + + CELL here = data_heap->generations[gen].here; + + u32 *quad_ptr; + u32 quad_mask = mask | (mask << 8) | (mask << 16) | (mask << 24); + + for(quad_ptr = (u32 *)first_card; quad_ptr < (u32 *)last_card; quad_ptr++) + { + if(*quad_ptr & quad_mask) + { + F_CARD *ptr = (F_CARD *)quad_ptr; + + int card; + for(card = 0; card < 4; card++) + { + if(ptr[card] & mask) + { + copy_card(&ptr[card],gen,here); + ptr[card] &= ~unmask; + } + } + } + } + + decks_scanned++; +} + +/* Copy all newspace objects referenced from marked cards to the destination */ +void copy_gen_cards(CELL gen) +{ + F_DECK *first_deck = ADDR_TO_DECK(data_heap->generations[gen].start); + F_DECK *last_deck = ADDR_TO_DECK(data_heap->generations[gen].end); + + F_CARD mask, unmask; + + /* if we are collecting the nursery, we care about old->nursery pointers + but not old->aging pointers */ + if(collecting_gen == NURSERY) + { + mask = CARD_POINTS_TO_NURSERY; + + /* after the collection, no old->nursery pointers remain + anywhere, but old->aging pointers might remain in tenured + space */ + if(gen == TENURED) + unmask = CARD_POINTS_TO_NURSERY; + /* after the collection, all cards in aging space can be + cleared */ + else if(HAVE_AGING_P && gen == AGING) + unmask = CARD_MARK_MASK; + else + { + critical_error("bug in copy_gen_cards",gen); + return; + } + } + /* if we are collecting aging space into tenured space, we care about + all old->nursery and old->aging pointers. no old->aging pointers can + remain */ + else if(HAVE_AGING_P && collecting_gen == AGING) + { + if(collecting_aging_again) + { + mask = CARD_POINTS_TO_AGING; + unmask = CARD_MARK_MASK; + } + /* after we collect aging space into the aging semispace, no + old->nursery pointers remain but tenured space might still have + pointers to aging space. */ + else + { + mask = CARD_POINTS_TO_AGING; + unmask = CARD_POINTS_TO_NURSERY; + } + } + else + { + critical_error("bug in copy_gen_cards",gen); + return; + } + + F_DECK *ptr; + + for(ptr = first_deck; ptr < last_deck; ptr++) + { + if(*ptr & mask) + { + copy_card_deck(ptr,gen,mask,unmask); + *ptr &= ~unmask; + } + } +} + +/* Scan cards in all generations older than the one being collected, copying +old->new references */ +void copy_cards(void) +{ + u64 start = current_micros(); + + CELL i; + for(i = collecting_gen + 1; i < data_heap->gen_count; i++) + copy_gen_cards(i); + + card_scan_time += (current_micros() - start); +} + +/* Copy all tagged pointers in a range of memory */ +void copy_stack_elements(F_SEGMENT *region, CELL top) +{ + CELL ptr = region->start; + + for(; ptr <= top; ptr += CELLS) + copy_handle((CELL*)ptr); +} + +void copy_registered_locals(void) +{ + CELL ptr = gc_locals_region->start; + + for(; ptr <= gc_locals; ptr += CELLS) + copy_handle(*(CELL **)ptr); +} + +/* Copy roots over at the start of GC, namely various constants, stacks, +the user environment and extra roots registered with REGISTER_ROOT */ +void copy_roots(void) +{ + copy_handle(&T); + copy_handle(&bignum_zero); + copy_handle(&bignum_pos_one); + copy_handle(&bignum_neg_one); + + copy_registered_locals(); + copy_stack_elements(extra_roots_region,extra_roots); + + if(!performing_compaction) + { + save_stacks(); + F_CONTEXT *stacks = stack_chain; + + while(stacks) + { + copy_stack_elements(stacks->datastack_region,stacks->datastack); + copy_stack_elements(stacks->retainstack_region,stacks->retainstack); + + copy_handle(&stacks->catchstack_save); + copy_handle(&stacks->current_callback_save); + + mark_active_blocks(stacks); + + stacks = stacks->next; + } + } + + int i; + for(i = 0; i < USER_ENV; i++) + copy_handle(&userenv[i]); +} + +/* Given a pointer to oldspace, copy it to newspace */ +INLINE void *copy_untagged_object(void *pointer, CELL size) +{ + if(newspace->here + size >= newspace->end) + longjmp(gc_jmp,1); + allot_barrier(newspace->here); + void *newpointer = allot_zone(newspace,size); + + F_GC_STATS *s = &gc_stats[collecting_gen]; + s->object_count++; + s->bytes_copied += size; + + memcpy(newpointer,pointer,size); + return newpointer; +} + +INLINE void forward_object(CELL pointer, CELL newpointer) +{ + if(pointer != newpointer) + put(UNTAG(pointer),RETAG(newpointer,GC_COLLECTED)); +} + +INLINE CELL copy_object_impl(CELL pointer) +{ + CELL newpointer = (CELL)copy_untagged_object( + (void*)UNTAG(pointer), + object_size(pointer)); + forward_object(pointer,newpointer); + return newpointer; +} + +bool should_copy_p(CELL untagged) +{ + if(in_zone(newspace,untagged)) + return false; + if(collecting_gen == TENURED) + return true; + else if(HAVE_AGING_P && collecting_gen == AGING) + return !in_zone(&data_heap->generations[TENURED],untagged); + else if(collecting_gen == NURSERY) + return in_zone(&nursery,untagged); + else + { + critical_error("Bug in should_copy_p",untagged); + return false; + } +} + +/* Follow a chain of forwarding pointers */ +CELL resolve_forwarding(CELL untagged, CELL tag) +{ + check_data_pointer(untagged); + + CELL header = get(untagged); + /* another forwarding pointer */ + if(TAG(header) == GC_COLLECTED) + return resolve_forwarding(UNTAG(header),tag); + /* we've found the destination */ + else + { + check_header(header); + CELL pointer = RETAG(untagged,tag); + if(should_copy_p(untagged)) + pointer = RETAG(copy_object_impl(pointer),tag); + return pointer; + } +} + +/* Given a pointer to a tagged pointer to oldspace, copy it to newspace. +If the object has already been copied, return the forwarding +pointer address without copying anything; otherwise, install +a new forwarding pointer. */ +INLINE CELL copy_object(CELL pointer) +{ + check_data_pointer(pointer); + + CELL tag = TAG(pointer); + CELL header = get(UNTAG(pointer)); + + if(TAG(header) == GC_COLLECTED) + return resolve_forwarding(UNTAG(header),tag); + else + { + check_header(header); + return RETAG(copy_object_impl(pointer),tag); + } +} + +void copy_handle(CELL *handle) +{ + CELL pointer = *handle; + + if(!immediate_p(pointer)) + { + check_data_pointer(pointer); + if(should_copy_p(pointer)) + *handle = copy_object(pointer); + } +} + +CELL copy_next_from_nursery(CELL scan) +{ + CELL *obj = (CELL *)scan; + CELL *end = (CELL *)(scan + binary_payload_start(scan)); + + if(obj != end) + { + obj++; + + CELL nursery_start = nursery.start; + CELL nursery_end = nursery.end; + + for(; obj < end; obj++) + { + CELL pointer = *obj; + + if(!immediate_p(pointer)) + { + check_data_pointer(pointer); + if(pointer >= nursery_start && pointer < nursery_end) + *obj = copy_object(pointer); + } + } + } + + return scan + untagged_object_size(scan); +} + +CELL copy_next_from_aging(CELL scan) +{ + CELL *obj = (CELL *)scan; + CELL *end = (CELL *)(scan + binary_payload_start(scan)); + + if(obj != end) + { + obj++; + + CELL tenured_start = data_heap->generations[TENURED].start; + CELL tenured_end = data_heap->generations[TENURED].end; + + CELL newspace_start = newspace->start; + CELL newspace_end = newspace->end; + + for(; obj < end; obj++) + { + CELL pointer = *obj; + + if(!immediate_p(pointer)) + { + check_data_pointer(pointer); + if(!(pointer >= newspace_start && pointer < newspace_end) + && !(pointer >= tenured_start && pointer < tenured_end)) + *obj = copy_object(pointer); + } + } + } + + return scan + untagged_object_size(scan); +} + +CELL copy_next_from_tenured(CELL scan) +{ + CELL *obj = (CELL *)scan; + CELL *end = (CELL *)(scan + binary_payload_start(scan)); + + if(obj != end) + { + obj++; + + CELL newspace_start = newspace->start; + CELL newspace_end = newspace->end; + + for(; obj < end; obj++) + { + CELL pointer = *obj; + + if(!immediate_p(pointer)) + { + check_data_pointer(pointer); + if(!(pointer >= newspace_start && pointer < newspace_end)) + *obj = copy_object(pointer); + } + } + } + + mark_object_code_block(scan); + + return scan + untagged_object_size(scan); +} + +void copy_reachable_objects(CELL scan, CELL *end) +{ + if(collecting_gen == NURSERY) + { + while(scan < *end) + scan = copy_next_from_nursery(scan); + } + else if(HAVE_AGING_P && collecting_gen == AGING) + { + while(scan < *end) + scan = copy_next_from_aging(scan); + } + else if(collecting_gen == TENURED) + { + while(scan < *end) + scan = copy_next_from_tenured(scan); + } +} + +/* Prepare to start copying reachable objects into an unused zone */ +void begin_gc(CELL requested_bytes) +{ + if(growing_data_heap) + { + if(collecting_gen != TENURED) + critical_error("Invalid parameters to begin_gc",0); + + old_data_heap = data_heap; + set_data_heap(grow_data_heap(old_data_heap,requested_bytes)); + newspace = &data_heap->generations[TENURED]; + } + else if(collecting_accumulation_gen_p()) + { + /* when collecting one of these generations, rotate it + with the semispace */ + F_ZONE z = data_heap->generations[collecting_gen]; + data_heap->generations[collecting_gen] = data_heap->semispaces[collecting_gen]; + data_heap->semispaces[collecting_gen] = z; + reset_generation(collecting_gen); + newspace = &data_heap->generations[collecting_gen]; + clear_cards(collecting_gen,collecting_gen); + clear_decks(collecting_gen,collecting_gen); + clear_allot_markers(collecting_gen,collecting_gen); + } + else + { + /* when collecting a younger generation, we copy + reachable objects to the next oldest generation, + so we set the newspace so the next generation. */ + newspace = &data_heap->generations[collecting_gen + 1]; + } +} + +void end_gc(CELL gc_elapsed) +{ + F_GC_STATS *s = &gc_stats[collecting_gen]; + + s->collections++; + s->gc_time += gc_elapsed; + if(s->max_gc_time < gc_elapsed) + s->max_gc_time = gc_elapsed; + + if(growing_data_heap) + { + dealloc_data_heap(old_data_heap); + old_data_heap = NULL; + growing_data_heap = false; + } + + if(collecting_accumulation_gen_p()) + { + /* all younger generations except are now empty. + if collecting_gen == NURSERY here, we only have 1 generation; + old-school Cheney collector */ + if(collecting_gen != NURSERY) + reset_generations(NURSERY,collecting_gen - 1); + } + else if(collecting_gen == NURSERY) + { + nursery.here = nursery.start; + } + else + { + /* all generations up to and including the one + collected are now empty */ + reset_generations(NURSERY,collecting_gen); + } + + collecting_aging_again = false; +} + +/* Collect gen and all younger generations. +If growing_data_heap_ is true, we must grow the data heap to such a size that +an allocation of requested_bytes won't fail */ +void garbage_collection(CELL gen, + bool growing_data_heap_, + CELL requested_bytes) +{ + if(gc_off) + { + critical_error("GC disabled",gen); + return; + } + + u64 start = current_micros(); + + performing_gc = true; + growing_data_heap = growing_data_heap_; + collecting_gen = gen; + + /* we come back here if a generation is full */ + if(setjmp(gc_jmp)) + { + /* We have no older generations we can try collecting, so we + resort to growing the data heap */ + if(collecting_gen == TENURED) + { + growing_data_heap = true; + + /* see the comment in unmark_marked() */ + unmark_marked(&code_heap); + } + /* we try collecting AGING space twice before going on to + collect TENURED */ + else if(HAVE_AGING_P + && collecting_gen == AGING + && !collecting_aging_again) + { + collecting_aging_again = true; + } + /* Collect the next oldest generation */ + else + { + collecting_gen++; + } + } + + begin_gc(requested_bytes); + + /* initialize chase pointer */ + CELL scan = newspace->here; + + /* collect objects referenced from stacks and environment */ + copy_roots(); + /* collect objects referenced from older generations */ + copy_cards(); + + /* do some tracing */ + copy_reachable_objects(scan,&newspace->here); + + /* don't scan code heap unless it has pointers to this + generation or younger */ + if(collecting_gen >= last_code_heap_scan) + { + code_heap_scans++; + + if(collecting_gen == TENURED) + free_unmarked(&code_heap,(HEAP_ITERATOR)update_literal_and_word_references); + else + copy_code_heap_roots(); + + if(collecting_accumulation_gen_p()) + last_code_heap_scan = collecting_gen; + else + last_code_heap_scan = collecting_gen + 1; + } + + CELL gc_elapsed = (current_micros() - start); + + end_gc(gc_elapsed); + + performing_gc = false; +} + +void gc(void) +{ + garbage_collection(TENURED,false,0); +} + +void minor_gc(void) +{ + garbage_collection(NURSERY,false,0); +} + +void primitive_gc(void) +{ + gc(); +} + +void primitive_gc_stats(void) +{ + GROWABLE_ARRAY(stats); + + CELL i; + u64 total_gc_time = 0; + + for(i = 0; i < MAX_GEN_COUNT; i++) + { + F_GC_STATS *s = &gc_stats[i]; + GROWABLE_ARRAY_ADD(stats,allot_cell(s->collections)); + GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(s->gc_time))); + GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(s->max_gc_time))); + GROWABLE_ARRAY_ADD(stats,allot_cell(s->collections == 0 ? 0 : s->gc_time / s->collections)); + GROWABLE_ARRAY_ADD(stats,allot_cell(s->object_count)); + GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(s->bytes_copied))); + + total_gc_time += s->gc_time; + } + + GROWABLE_ARRAY_ADD(stats,tag_bignum(ulong_long_to_bignum(total_gc_time))); + GROWABLE_ARRAY_ADD(stats,tag_bignum(ulong_long_to_bignum(cards_scanned))); + GROWABLE_ARRAY_ADD(stats,tag_bignum(ulong_long_to_bignum(decks_scanned))); + GROWABLE_ARRAY_ADD(stats,tag_bignum(ulong_long_to_bignum(card_scan_time))); + GROWABLE_ARRAY_ADD(stats,allot_cell(code_heap_scans)); + + GROWABLE_ARRAY_TRIM(stats); + GROWABLE_ARRAY_DONE(stats); + dpush(stats); +} + +void clear_gc_stats(void) +{ + int i; + for(i = 0; i < MAX_GEN_COUNT; i++) + memset(&gc_stats[i],0,sizeof(F_GC_STATS)); + + cards_scanned = 0; + decks_scanned = 0; + card_scan_time = 0; + code_heap_scans = 0; +} + +void primitive_clear_gc_stats(void) +{ + clear_gc_stats(); +} + +/* classes.tuple uses this to reshape tuples; tools.deploy.shaker uses this + to coalesce equal but distinct quotations and wrappers. */ +void primitive_become(void) +{ + F_ARRAY *new_objects = untag_array(dpop()); + F_ARRAY *old_objects = untag_array(dpop()); + + CELL capacity = array_capacity(new_objects); + if(capacity != array_capacity(old_objects)) + critical_error("bad parameters to become",0); + + CELL i; + + for(i = 0; i < capacity; i++) + { + CELL old_obj = array_nth(old_objects,i); + CELL new_obj = array_nth(new_objects,i); + + forward_object(old_obj,new_obj); + } + + gc(); + + /* If a word's definition quotation was in old_objects and the + quotation in new_objects is not compiled, we might leak memory + by referencing the old quotation unless we recompile all + unoptimized words. */ + compile_all_words(); +} diff --git a/vmpp/data_gc.h b/vmpp/data_gc.h new file mode 100644 index 0000000000..1def24ae73 --- /dev/null +++ b/vmpp/data_gc.h @@ -0,0 +1,159 @@ +void gc(void); +DLLEXPORT void minor_gc(void); + +/* used during garbage collection only */ + +F_ZONE *newspace; +bool performing_gc; +bool performing_compaction; +CELL collecting_gen; + +/* if true, we collecting AGING space for the second time, so if it is still +full, we go on to collect TENURED */ +bool collecting_aging_again; + +/* in case a generation fills up in the middle of a gc, we jump back +up to try collecting the next generation. */ +jmp_buf gc_jmp; + +/* statistics */ +typedef struct { + CELL collections; + u64 gc_time; + u64 max_gc_time; + CELL object_count; + u64 bytes_copied; +} F_GC_STATS; + +F_GC_STATS gc_stats[MAX_GEN_COUNT]; +u64 cards_scanned; +u64 decks_scanned; +u64 card_scan_time; +CELL code_heap_scans; + +/* What generation was being collected when copy_code_heap_roots() was last +called? Until the next call to add_code_block(), future +collections of younger generations don't have to touch the code +heap. */ +CELL last_code_heap_scan; + +/* sometimes we grow the heap */ +bool growing_data_heap; +F_DATA_HEAP *old_data_heap; + +INLINE bool collecting_accumulation_gen_p(void) +{ + return ((HAVE_AGING_P + && collecting_gen == AGING + && !collecting_aging_again) + || collecting_gen == TENURED); +} + +/* test if the pointer is in generation being collected, or a younger one. */ +INLINE bool should_copy(CELL untagged) +{ + if(in_zone(newspace,untagged)) + return false; + if(collecting_gen == TENURED) + return true; + else if(HAVE_AGING_P && collecting_gen == AGING) + return !in_zone(&data_heap->generations[TENURED],untagged); + else if(collecting_gen == NURSERY) + return in_zone(&nursery,untagged); + else + { + critical_error("Bug in should_copy",untagged); + return false; + } +} + +void copy_handle(CELL *handle); + +void garbage_collection(volatile CELL gen, + bool growing_data_heap_, + CELL requested_bytes); + +/* We leave this many bytes free at the top of the nursery so that inline +allocation (which does not call GC because of possible roots in volatile +registers) does not run out of memory */ +#define ALLOT_BUFFER_ZONE 1024 + +/* If this is defined, we GC every allocation. This catches missing local roots */ + +/* + * It is up to the caller to fill in the object's fields in a meaningful + * fashion! + */ + +INLINE void *allot_object(CELL type, CELL a) +{ +#ifdef GC_DEBUG + if(!gc_off) + gc(); +#endif + + CELL *object; + + if(nursery.size - ALLOT_BUFFER_ZONE > a) + { + /* If there is insufficient room, collect the nursery */ + if(nursery.here + ALLOT_BUFFER_ZONE + a > nursery.end) + garbage_collection(NURSERY,false,0); + + CELL h = nursery.here; + nursery.here = h + align8(a); + object = (CELL*)h; + } + /* If the object is bigger than the nursery, allocate it in + tenured space */ + else + { + F_ZONE *tenured = &data_heap->generations[TENURED]; + + /* If tenured space does not have enough room, collect */ + if(tenured->here + a > tenured->end) + { + gc(); + tenured = &data_heap->generations[TENURED]; + } + + /* If it still won't fit, grow the heap */ + if(tenured->here + a > tenured->end) + { + garbage_collection(TENURED,true,a); + tenured = &data_heap->generations[TENURED]; + } + + object = (CELL *)allot_zone(tenured,a); + + /* We have to do this */ + allot_barrier((CELL)object); + + /* Allows initialization code to store old->new pointers + without hitting the write barrier in the common case of + a nursery allocation */ + write_barrier((CELL)object); + } + + *object = tag_header(type); + return object; +} + +void copy_reachable_objects(CELL scan, CELL *end); + +void primitive_gc(void); +void primitive_gc_stats(void); +void clear_gc_stats(void); +void primitive_clear_gc_stats(void); +void primitive_become(void); + +INLINE void check_data_pointer(CELL pointer) +{ +#ifdef FACTOR_DEBUG + if(!growing_data_heap) + { + assert(pointer >= data_heap->segment->start + && pointer < data_heap->segment->end); + } +#endif +} diff --git a/vmpp/data_gc.hpp b/vmpp/data_gc.hpp new file mode 100755 index 0000000000..2978b20cf6 --- /dev/null +++ b/vmpp/data_gc.hpp @@ -0,0 +1,122 @@ +void init_data_gc(void); + +void gc(void); +DLLEXPORT void minor_gc(void); + +/* statistics */ +typedef struct { + CELL collections; + u64 gc_time; + u64 max_gc_time; + CELL object_count; + u64 bytes_copied; +} F_GC_STATS; + +extern F_ZONE *newspace; + +extern bool performing_compaction; +extern CELL collecting_gen; +extern bool collecting_aging_again; + +INLINE bool collecting_accumulation_gen_p(void) +{ + return ((HAVE_AGING_P + && collecting_gen == AGING + && !collecting_aging_again) + || collecting_gen == TENURED); +} + +extern CELL last_code_heap_scan; + +/* test if the pointer is in generation being collected, or a younger one. */ +bool should_copy_p(CELL untagged); + +void copy_handle(CELL *handle); + +void garbage_collection(volatile CELL gen, + bool growing_data_heap_, + CELL requested_bytes); + +/* We leave this many bytes free at the top of the nursery so that inline +allocation (which does not call GC because of possible roots in volatile +registers) does not run out of memory */ +#define ALLOT_BUFFER_ZONE 1024 + +/* + * It is up to the caller to fill in the object's fields in a meaningful + * fashion! + */ +INLINE void *allot_object(CELL type, CELL a) +{ +#ifdef GC_DEBUG + if(!gc_off) + gc(); +#endif + + CELL *object; + + if(nursery.size - ALLOT_BUFFER_ZONE > a) + { + /* If there is insufficient room, collect the nursery */ + if(nursery.here + ALLOT_BUFFER_ZONE + a > nursery.end) + garbage_collection(NURSERY,false,0); + + CELL h = nursery.here; + nursery.here = h + align8(a); + object = (CELL*)h; + } + /* If the object is bigger than the nursery, allocate it in + tenured space */ + else + { + F_ZONE *tenured = &data_heap->generations[TENURED]; + + /* If tenured space does not have enough room, collect */ + if(tenured->here + a > tenured->end) + { + gc(); + tenured = &data_heap->generations[TENURED]; + } + + /* If it still won't fit, grow the heap */ + if(tenured->here + a > tenured->end) + { + garbage_collection(TENURED,true,a); + tenured = &data_heap->generations[TENURED]; + } + + object = (CELL *)allot_zone(tenured,a); + + /* We have to do this */ + allot_barrier((CELL)object); + + /* Allows initialization code to store old->new pointers + without hitting the write barrier in the common case of + a nursery allocation */ + write_barrier((CELL)object); + } + + *object = tag_header(type); + return object; +} + +void copy_reachable_objects(CELL scan, CELL *end); + +void primitive_gc(void); +void primitive_gc_stats(void); +void clear_gc_stats(void); +void primitive_clear_gc_stats(void); +void primitive_become(void); + +extern bool growing_data_heap; + +INLINE void check_data_pointer(CELL pointer) +{ +#ifdef FACTOR_DEBUG + if(!growing_data_heap) + { + assert(pointer >= data_heap->segment->start + && pointer < data_heap->segment->end); + } +#endif +} diff --git a/vmpp/data_heap.cpp b/vmpp/data_heap.cpp new file mode 100644 index 0000000000..21f4124707 --- /dev/null +++ b/vmpp/data_heap.cpp @@ -0,0 +1,385 @@ +#include "master.hpp" + +/* Set by the -securegc command line argument */ +bool secure_gc; + +/* new objects are allocated here */ +DLLEXPORT F_ZONE nursery; + +/* GC is off during heap walking */ +bool gc_off; + +F_DATA_HEAP *data_heap; + +F_ZONE nursery; + +CELL init_zone(F_ZONE *z, CELL size, CELL start) +{ + z->size = size; + z->start = z->here = start; + z->end = start + size; + return z->end; +} + +void init_card_decks(void) +{ + CELL start = align(data_heap->segment->start,DECK_SIZE); + allot_markers_offset = (CELL)data_heap->allot_markers - (start >> CARD_BITS); + cards_offset = (CELL)data_heap->cards - (start >> CARD_BITS); + decks_offset = (CELL)data_heap->decks - (start >> DECK_BITS); +} + +F_DATA_HEAP *alloc_data_heap(CELL gens, + CELL young_size, + CELL aging_size, + CELL tenured_size) +{ + young_size = align(young_size,DECK_SIZE); + aging_size = align(aging_size,DECK_SIZE); + tenured_size = align(tenured_size,DECK_SIZE); + + F_DATA_HEAP *data_heap = (F_DATA_HEAP *)safe_malloc(sizeof(F_DATA_HEAP)); + data_heap->young_size = young_size; + data_heap->aging_size = aging_size; + data_heap->tenured_size = tenured_size; + data_heap->gen_count = gens; + + CELL total_size; + if(data_heap->gen_count == 2) + total_size = young_size + 2 * tenured_size; + else if(data_heap->gen_count == 3) + total_size = young_size + 2 * aging_size + 2 * tenured_size; + else + { + fatal_error("Invalid number of generations",data_heap->gen_count); + return NULL; /* can't happen */ + } + + total_size += DECK_SIZE; + + data_heap->segment = alloc_segment(total_size); + + data_heap->generations = (F_ZONE *)safe_malloc(sizeof(F_ZONE) * data_heap->gen_count); + data_heap->semispaces = (F_ZONE *)safe_malloc(sizeof(F_ZONE) * data_heap->gen_count); + + CELL cards_size = total_size >> CARD_BITS; + data_heap->allot_markers = (CELL *)safe_malloc(cards_size); + data_heap->allot_markers_end = data_heap->allot_markers + cards_size; + + data_heap->cards = (CELL *)safe_malloc(cards_size); + data_heap->cards_end = data_heap->cards + cards_size; + + CELL decks_size = total_size >> DECK_BITS; + data_heap->decks = (CELL *)safe_malloc(decks_size); + data_heap->decks_end = data_heap->decks + decks_size; + + CELL alloter = align(data_heap->segment->start,DECK_SIZE); + + alloter = init_zone(&data_heap->generations[TENURED],tenured_size,alloter); + alloter = init_zone(&data_heap->semispaces[TENURED],tenured_size,alloter); + + if(data_heap->gen_count == 3) + { + alloter = init_zone(&data_heap->generations[AGING],aging_size,alloter); + alloter = init_zone(&data_heap->semispaces[AGING],aging_size,alloter); + } + + if(data_heap->gen_count >= 2) + { + alloter = init_zone(&data_heap->generations[NURSERY],young_size,alloter); + alloter = init_zone(&data_heap->semispaces[NURSERY],0,alloter); + } + + if(data_heap->segment->end - alloter > DECK_SIZE) + critical_error("Bug in alloc_data_heap",alloter); + + return data_heap; +} + +F_DATA_HEAP *grow_data_heap(F_DATA_HEAP *data_heap, CELL requested_bytes) +{ + CELL new_tenured_size = (data_heap->tenured_size * 2) + requested_bytes; + + return alloc_data_heap(data_heap->gen_count, + data_heap->young_size, + data_heap->aging_size, + new_tenured_size); +} + +void dealloc_data_heap(F_DATA_HEAP *data_heap) +{ + dealloc_segment(data_heap->segment); + free(data_heap->generations); + free(data_heap->semispaces); + free(data_heap->allot_markers); + free(data_heap->cards); + free(data_heap->decks); + free(data_heap); +} + +void clear_cards(CELL from, CELL to) +{ + /* NOTE: reverse order due to heap layout. */ + F_CARD *first_card = ADDR_TO_CARD(data_heap->generations[to].start); + F_CARD *last_card = ADDR_TO_CARD(data_heap->generations[from].end); + memset(first_card,0,last_card - first_card); +} + +void clear_decks(CELL from, CELL to) +{ + /* NOTE: reverse order due to heap layout. */ + F_DECK *first_deck = ADDR_TO_DECK(data_heap->generations[to].start); + F_DECK *last_deck = ADDR_TO_DECK(data_heap->generations[from].end); + memset(first_deck,0,last_deck - first_deck); +} + +void clear_allot_markers(CELL from, CELL to) +{ + /* NOTE: reverse order due to heap layout. */ + F_CARD *first_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[to].start); + F_CARD *last_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[from].end); + memset(first_card,INVALID_ALLOT_MARKER,last_card - first_card); +} + +void reset_generation(CELL i) +{ + F_ZONE *z = (i == NURSERY ? &nursery : &data_heap->generations[i]); + + z->here = z->start; + if(secure_gc) + memset((void*)z->start,69,z->size); +} + +/* After garbage collection, any generations which are now empty need to have +their allocation pointers and cards reset. */ +void reset_generations(CELL from, CELL to) +{ + CELL i; + for(i = from; i <= to; i++) + reset_generation(i); + + clear_cards(from,to); + clear_decks(from,to); + clear_allot_markers(from,to); +} + +void set_data_heap(F_DATA_HEAP *data_heap_) +{ + data_heap = data_heap_; + nursery = data_heap->generations[NURSERY]; + init_card_decks(); + clear_cards(NURSERY,TENURED); + clear_decks(NURSERY,TENURED); + clear_allot_markers(NURSERY,TENURED); +} + +void init_data_heap(CELL gens, + CELL young_size, + CELL aging_size, + CELL tenured_size, + bool secure_gc_) +{ + set_data_heap(alloc_data_heap(gens,young_size,aging_size,tenured_size)); + + gc_locals_region = alloc_segment(getpagesize()); + gc_locals = gc_locals_region->start - CELLS; + + extra_roots_region = alloc_segment(getpagesize()); + extra_roots = extra_roots_region->start - CELLS; + + secure_gc = secure_gc_; + + init_data_gc(); +} + +/* Size of the object pointed to by a tagged pointer */ +CELL object_size(CELL tagged) +{ + if(immediate_p(tagged)) + return 0; + else + return untagged_object_size(UNTAG(tagged)); +} + +/* Size of the object pointed to by an untagged pointer */ +CELL untagged_object_size(CELL pointer) +{ + return align8(unaligned_object_size(pointer)); +} + +/* Size of the data area of an object pointed to by an untagged pointer */ +CELL unaligned_object_size(CELL pointer) +{ + F_TUPLE *tuple; + F_TUPLE_LAYOUT *layout; + + switch(untag_header(get(pointer))) + { + case ARRAY_TYPE: + case BIGNUM_TYPE: + return array_size(array_capacity((F_ARRAY*)pointer)); + case BYTE_ARRAY_TYPE: + return byte_array_size( + byte_array_capacity((F_BYTE_ARRAY*)pointer)); + case STRING_TYPE: + return string_size(string_capacity((F_STRING*)pointer)); + case TUPLE_TYPE: + tuple = untag_tuple_fast(pointer); + layout = untag_tuple_layout(tuple->layout); + return tuple_size(layout); + case QUOTATION_TYPE: + return sizeof(F_QUOTATION); + case WORD_TYPE: + return sizeof(F_WORD); + case FLOAT_TYPE: + return sizeof(F_FLOAT); + case DLL_TYPE: + return sizeof(F_DLL); + case ALIEN_TYPE: + return sizeof(F_ALIEN); + case WRAPPER_TYPE: + return sizeof(F_WRAPPER); + case CALLSTACK_TYPE: + return callstack_size( + untag_fixnum_fast(((F_CALLSTACK *)pointer)->length)); + default: + critical_error("Invalid header",pointer); + return -1; /* can't happen */ + } +} + +void primitive_size(void) +{ + box_unsigned_cell(object_size(dpop())); +} + +/* The number of cells from the start of the object which should be scanned by +the GC. Some types have a binary payload at the end (string, word, DLL) which +we ignore. */ +CELL binary_payload_start(CELL pointer) +{ + F_TUPLE *tuple; + F_TUPLE_LAYOUT *layout; + + switch(untag_header(get(pointer))) + { + /* these objects do not refer to other objects at all */ + case FLOAT_TYPE: + case BYTE_ARRAY_TYPE: + case BIGNUM_TYPE: + case CALLSTACK_TYPE: + return 0; + /* these objects have some binary data at the end */ + case WORD_TYPE: + return sizeof(F_WORD) - CELLS * 3; + case ALIEN_TYPE: + return CELLS * 3; + case DLL_TYPE: + return CELLS * 2; + case QUOTATION_TYPE: + return sizeof(F_QUOTATION) - CELLS * 2; + case STRING_TYPE: + return sizeof(F_STRING); + /* everything else consists entirely of pointers */ + case ARRAY_TYPE: + return array_size(array_capacity((F_ARRAY*)pointer)); + case TUPLE_TYPE: + tuple = untag_tuple_fast(pointer); + layout = untag_tuple_layout(tuple->layout); + return tuple_size(layout); + case WRAPPER_TYPE: + return sizeof(F_WRAPPER); + default: + critical_error("Invalid header",pointer); + return -1; /* can't happen */ + } +} + +/* Push memory usage statistics in data heap */ +void primitive_data_room(void) +{ + dpush(tag_fixnum((data_heap->cards_end - data_heap->cards) >> 10)); + dpush(tag_fixnum((data_heap->decks_end - data_heap->decks) >> 10)); + + GROWABLE_ARRAY(a); + + CELL gen; + for(gen = 0; gen < data_heap->gen_count; gen++) + { + F_ZONE *z = (gen == NURSERY ? &nursery : &data_heap->generations[gen]); + GROWABLE_ARRAY_ADD(a,tag_fixnum((z->end - z->here) >> 10)); + GROWABLE_ARRAY_ADD(a,tag_fixnum((z->size) >> 10)); + } + + GROWABLE_ARRAY_TRIM(a); + GROWABLE_ARRAY_DONE(a); + dpush(a); +} + +/* A heap walk allows useful things to be done, like finding all +references to an object for debugging purposes. */ +CELL heap_scan_ptr; + +/* Disables GC and activates next-object ( -- obj ) primitive */ +void begin_scan(void) +{ + heap_scan_ptr = data_heap->generations[TENURED].start; + gc_off = true; +} + +void primitive_begin_scan(void) +{ + begin_scan(); +} + +CELL next_object(void) +{ + if(!gc_off) + general_error(ERROR_HEAP_SCAN,F,F,NULL); + + CELL value = get(heap_scan_ptr); + CELL obj = heap_scan_ptr; + CELL type; + + if(heap_scan_ptr >= data_heap->generations[TENURED].here) + return F; + + type = untag_header(value); + heap_scan_ptr += untagged_object_size(heap_scan_ptr); + + return RETAG(obj,type < HEADER_TYPE ? type : OBJECT_TYPE); +} + +/* Push object at heap scan cursor and advance; pushes f when done */ +void primitive_next_object(void) +{ + dpush(next_object()); +} + +/* Re-enables GC */ +void primitive_end_scan(void) +{ + gc_off = false; +} + +CELL find_all_words(void) +{ + GROWABLE_ARRAY(words); + + begin_scan(); + + CELL obj; + while((obj = next_object()) != F) + { + if(type_of(obj) == WORD_TYPE) + GROWABLE_ARRAY_ADD(words,obj); + } + + /* End heap scan */ + gc_off = false; + + GROWABLE_ARRAY_TRIM(words); + GROWABLE_ARRAY_DONE(words); + + return words; +} diff --git a/vmpp/data_heap.hpp b/vmpp/data_heap.hpp new file mode 100644 index 0000000000..4753db6d61 --- /dev/null +++ b/vmpp/data_heap.hpp @@ -0,0 +1,134 @@ +/* Set by the -securegc command line argument */ +extern bool secure_gc; + +/* generational copying GC divides memory into zones */ +typedef struct { + /* allocation pointer is 'here'; its offset is hardcoded in the + compiler backends*/ + CELL start; + CELL here; + CELL size; + CELL end; +} F_ZONE; + +typedef struct { + F_SEGMENT *segment; + + CELL young_size; + CELL aging_size; + CELL tenured_size; + + CELL gen_count; + + F_ZONE *generations; + F_ZONE* semispaces; + + CELL *allot_markers; + CELL *allot_markers_end; + + CELL *cards; + CELL *cards_end; + + CELL *decks; + CELL *decks_end; +} F_DATA_HEAP; + +extern F_DATA_HEAP *data_heap; + +/* the 0th generation is where new objects are allocated. */ +#define NURSERY 0 +/* where objects hang around */ +#define AGING (data_heap->gen_count-2) +#define HAVE_AGING_P (data_heap->gen_count>2) +/* the oldest generation */ +#define TENURED (data_heap->gen_count-1) + +#define MIN_GEN_COUNT 1 +#define MAX_GEN_COUNT 3 + +/* new objects are allocated here */ +extern F_ZONE nursery; + +INLINE bool in_zone(F_ZONE *z, CELL pointer) +{ + return pointer >= z->start && pointer < z->end; +} + +CELL init_zone(F_ZONE *z, CELL size, CELL base); + +void init_card_decks(void); + +F_DATA_HEAP *grow_data_heap(F_DATA_HEAP *data_heap, CELL requested_bytes); + +void dealloc_data_heap(F_DATA_HEAP *data_heap); + +void clear_cards(CELL from, CELL to); +void clear_decks(CELL from, CELL to); +void clear_allot_markers(CELL from, CELL to); +void reset_generation(CELL i); +void reset_generations(CELL from, CELL to); + +void set_data_heap(F_DATA_HEAP *data_heap_); + +void init_data_heap(CELL gens, + CELL young_size, + CELL aging_size, + CELL tenured_size, + bool secure_gc_); + +/* set up guard pages to check for under/overflow. +size must be a multiple of the page size */ +F_SEGMENT *alloc_segment(CELL size); +void dealloc_segment(F_SEGMENT *block); + +CELL untagged_object_size(CELL pointer); +CELL unaligned_object_size(CELL pointer); +CELL object_size(CELL pointer); +CELL binary_payload_start(CELL pointer); + +void begin_scan(void); +CELL next_object(void); + +void primitive_data_room(void); +void primitive_size(void); + +void primitive_begin_scan(void); +void primitive_next_object(void); +void primitive_end_scan(void); + +/* GC is off during heap walking */ +extern bool gc_off; + +INLINE bool in_data_heap_p(CELL ptr) +{ + return (ptr >= data_heap->segment->start + && ptr <= data_heap->segment->end); +} + +INLINE void *allot_zone(F_ZONE *z, CELL a) +{ + CELL h = z->here; + z->here = h + align8(a); + return (void*)h; +} + +CELL find_all_words(void); + +/* Every object has a regular representation in the runtime, which makes GC +much simpler. Every slot of the object until binary_payload_start is a pointer +to some other object. */ +INLINE void do_slots(CELL obj, void (* iter)(CELL *)) +{ + CELL scan = obj; + CELL payload_start = binary_payload_start(obj); + CELL end = obj + payload_start; + + scan += CELLS; + + while(scan < end) + { + iter((CELL *)scan); + scan += CELLS; + } +} + diff --git a/vmpp/debug.cpp b/vmpp/debug.cpp new file mode 100755 index 0000000000..270ed9f0dd --- /dev/null +++ b/vmpp/debug.cpp @@ -0,0 +1,502 @@ +#include "master.hpp" + +static bool fep_disabled; +static bool full_output; + +void print_chars(F_STRING* str) +{ + CELL i; + for(i = 0; i < string_capacity(str); i++) + putchar(string_nth(str,i)); +} + +void print_word(F_WORD* word, CELL nesting) +{ + + if(type_of(word->vocabulary) == STRING_TYPE) + { + print_chars(untag_string(word->vocabulary)); + print_string(":"); + } + + if(type_of(word->name) == STRING_TYPE) + print_chars(untag_string(word->name)); + else + { + print_string("#name,nesting); + print_string(">"); + } +} + +void print_factor_string(F_STRING* str) +{ + putchar('"'); + print_chars(str); + putchar('"'); +} + +void print_array(F_ARRAY* array, CELL nesting) +{ + CELL length = array_capacity(array); + CELL i; + bool trimmed; + + if(length > 10 && !full_output) + { + trimmed = true; + length = 10; + } + else + trimmed = false; + + for(i = 0; i < length; i++) + { + print_string(" "); + print_nested_obj(array_nth(array,i),nesting); + } + + if(trimmed) + print_string("..."); +} + +void print_tuple(F_TUPLE* tuple, CELL nesting) +{ + F_TUPLE_LAYOUT *layout = untag_tuple_layout(tuple->layout); + CELL length = to_fixnum(layout->size); + + print_string(" "); + print_nested_obj(layout->klass,nesting); + + CELL i; + bool trimmed; + + if(length > 10 && !full_output) + { + trimmed = true; + length = 10; + } + else + trimmed = false; + + for(i = 0; i < length; i++) + { + print_string(" "); + print_nested_obj(tuple_nth(tuple,i),nesting); + } + + if(trimmed) + print_string("..."); +} + +void print_nested_obj(CELL obj, F_FIXNUM nesting) +{ + if(nesting <= 0 && !full_output) + { + print_string(" ... "); + return; + } + + F_QUOTATION *quot; + + switch(type_of(obj)) + { + case FIXNUM_TYPE: + print_fixnum(untag_fixnum_fast(obj)); + break; + case WORD_TYPE: + print_word(untag_word(obj),nesting - 1); + break; + case STRING_TYPE: + print_factor_string(untag_string(obj)); + break; + case F_TYPE: + print_string("f"); + break; + case TUPLE_TYPE: + print_string("T{"); + print_tuple(untag_tuple_fast(obj),nesting - 1); + print_string(" }"); + break; + case ARRAY_TYPE: + print_string("{"); + print_array(untag_array_fast(obj),nesting - 1); + print_string(" }"); + break; + case QUOTATION_TYPE: + print_string("["); + quot = untag_quotation_fast(obj); + print_array(untag_array_fast(quot->array),nesting - 1); + print_string(" ]"); + break; + default: + print_string("#"); + break; + } +} + +void print_obj(CELL obj) +{ + print_nested_obj(obj,10); +} + +void print_objects(CELL start, CELL end) +{ + for(; start <= end; start += CELLS) + { + print_obj(get(start)); + nl(); + } +} + +void print_datastack(void) +{ + print_string("==== DATA STACK:\n"); + print_objects(ds_bot,ds); +} + +void print_retainstack(void) +{ + print_string("==== RETAIN STACK:\n"); + print_objects(rs_bot,rs); +} + +void print_stack_frame(F_STACK_FRAME *frame) +{ + print_obj(frame_executing(frame)); + print_string("\n"); + print_obj(frame_scan(frame)); + print_string("\n"); + print_cell_hex((CELL)frame_executing(frame)); + print_string(" "); + print_cell_hex((CELL)frame->xt); + print_string("\n"); +} + +void print_callstack(void) +{ + print_string("==== CALL STACK:\n"); + CELL bottom = (CELL)stack_chain->callstack_bottom; + CELL top = (CELL)stack_chain->callstack_top; + iterate_callstack(top,bottom,print_stack_frame); +} + +void dump_cell(CELL cell) +{ + print_cell_hex_pad(cell); print_string(": "); + + cell = get(cell); + + print_cell_hex_pad(cell); print_string(" tag "); print_cell(TAG(cell)); + + switch(TAG(cell)) + { + case OBJECT_TYPE: + case BIGNUM_TYPE: + case FLOAT_TYPE: + if(cell == F) + print_string(" -- F"); + else if(cell < TYPE_COUNT<>TAG_BITS); + } + else if(cell >= data_heap->segment->start + && cell < data_heap->segment->end) + { + CELL header = get(UNTAG(cell)); + CELL type = header>>TAG_BITS; + print_string(" -- object; "); + if(TAG(header) == 0 && type < TYPE_COUNT) + { + print_string(" type "); print_cell(type); + } + else + print_string(" header corrupt"); + } + break; + } + + nl(); +} + +void dump_memory(CELL from, CELL to) +{ + from = UNTAG(from); + + for(; from <= to; from += CELLS) + dump_cell(from); +} + +void dump_zone(F_ZONE *z) +{ + print_string("Start="); print_cell(z->start); + print_string(", size="); print_cell(z->size); + print_string(", here="); print_cell(z->here - z->start); nl(); +} + +void dump_generations(void) +{ + CELL i; + + print_string("Nursery: "); + dump_zone(&nursery); + + for(i = 1; i < data_heap->gen_count; i++) + { + print_string("Generation "); print_cell(i); print_string(": "); + dump_zone(&data_heap->generations[i]); + } + + for(i = 0; i < data_heap->gen_count; i++) + { + print_string("Semispace "); print_cell(i); print_string(": "); + dump_zone(&data_heap->semispaces[i]); + } + + print_string("Cards: base="); + print_cell((CELL)data_heap->cards); + print_string(", size="); + print_cell((CELL)(data_heap->cards_end - data_heap->cards)); + nl(); +} + +void dump_objects(CELL type) +{ + gc(); + begin_scan(); + + CELL obj; + while((obj = next_object()) != F) + { + if(type == TYPE_COUNT || type_of(obj) == type) + { + print_cell_hex_pad(obj); + print_string(" "); + print_nested_obj(obj,2); + nl(); + } + } + + /* end scan */ + gc_off = false; +} + +CELL look_for; +CELL obj; + +void find_data_references_step(CELL *scan) +{ + if(look_for == *scan) + { + print_cell_hex_pad(obj); + print_string(" "); + print_nested_obj(obj,2); + nl(); + } +} + +void find_data_references(CELL look_for_) +{ + look_for = look_for_; + + begin_scan(); + + while((obj = next_object()) != F) + do_slots(UNTAG(obj),find_data_references_step); + + /* end scan */ + gc_off = false; +} + +/* Dump all code blocks for debugging */ +void dump_code_heap(void) +{ + CELL reloc_size = 0, literal_size = 0; + + F_BLOCK *scan = first_block(&code_heap); + + while(scan) + { + char *status; + switch(scan->status) + { + case B_FREE: + status = "free"; + break; + case B_ALLOCATED: + reloc_size += object_size(((F_CODE_BLOCK *)scan)->relocation); + literal_size += object_size(((F_CODE_BLOCK *)scan)->literals); + status = "allocated"; + break; + case B_MARKED: + reloc_size += object_size(((F_CODE_BLOCK *)scan)->relocation); + literal_size += object_size(((F_CODE_BLOCK *)scan)->literals); + status = "marked"; + break; + default: + status = "invalid"; + break; + } + + print_cell_hex((CELL)scan); print_string(" "); + print_cell_hex(scan->size); print_string(" "); + print_string(status); print_string("\n"); + + scan = next_block(&code_heap,scan); + } + + print_cell(reloc_size); print_string(" bytes of relocation data\n"); + print_cell(literal_size); print_string(" bytes of literal data\n"); +} + +void factorbug(void) +{ + if(fep_disabled) + { + print_string("Low level debugger disabled\n"); + exit(1); + } + + /* open_console(); */ + + print_string("Starting low level debugger...\n"); + print_string(" Basic commands:\n"); + print_string("q -- continue executing Factor - NOT SAFE\n"); + print_string("im -- save image to fep.image\n"); + print_string("x -- exit Factor\n"); + print_string(" Advanced commands:\n"); + print_string("d -- dump memory\n"); + print_string("u -- dump object at tagged \n"); + print_string(". -- print object at tagged \n"); + print_string("t -- toggle output trimming\n"); + print_string("s r -- dump data, retain stacks\n"); + print_string(".s .r .c -- print data, retain, call stacks\n"); + print_string("e -- dump environment\n"); + print_string("g -- dump generations\n"); + print_string("card -- print card containing address\n"); + print_string("addr -- print address containing card\n"); + print_string("data -- data heap dump\n"); + print_string("words -- words dump\n"); + print_string("tuples -- tuples dump\n"); + print_string("refs -- find data heap references to object\n"); + print_string("push -- push object on data stack - NOT SAFE\n"); + print_string("code -- code heap dump\n"); + + bool seen_command = false; + + for(;;) + { + char cmd[1024]; + + print_string("READY\n"); + fflush(stdout); + + if(scanf("%1000s",cmd) <= 0) + { + if(!seen_command) + { + /* If we exit with an EOF immediately, then + dump stacks. This is useful for builder and + other cases where Factor is run with stdin + redirected to /dev/null */ + fep_disabled = true; + + print_datastack(); + print_retainstack(); + print_callstack(); + } + + exit(1); + } + + seen_command = true; + + if(strcmp(cmd,"d") == 0) + { + CELL addr = read_cell_hex(); + if(scanf(" ") < 0) break; + CELL count = read_cell_hex(); + dump_memory(addr,addr+count); + } + else if(strcmp(cmd,"u") == 0) + { + CELL addr = read_cell_hex(); + CELL count = object_size(addr); + dump_memory(addr,addr+count); + } + else if(strcmp(cmd,".") == 0) + { + CELL addr = read_cell_hex(); + print_obj(addr); + print_string("\n"); + } + else if(strcmp(cmd,"t") == 0) + full_output = !full_output; + else if(strcmp(cmd,"s") == 0) + dump_memory(ds_bot,ds); + else if(strcmp(cmd,"r") == 0) + dump_memory(rs_bot,rs); + else if(strcmp(cmd,".s") == 0) + print_datastack(); + else if(strcmp(cmd,".r") == 0) + print_retainstack(); + else if(strcmp(cmd,".c") == 0) + print_callstack(); + else if(strcmp(cmd,"e") == 0) + { + int i; + for(i = 0; i < USER_ENV; i++) + dump_cell((CELL)&userenv[i]); + } + else if(strcmp(cmd,"g") == 0) + dump_generations(); + else if(strcmp(cmd,"card") == 0) + { + CELL addr = read_cell_hex(); + print_cell_hex((CELL)ADDR_TO_CARD(addr)); + nl(); + } + else if(strcmp(cmd,"addr") == 0) + { + CELL card = read_cell_hex(); + print_cell_hex((CELL)CARD_TO_ADDR(card)); + nl(); + } + else if(strcmp(cmd,"q") == 0) + return; + else if(strcmp(cmd,"x") == 0) + exit(1); + else if(strcmp(cmd,"im") == 0) + save_image(STRING_LITERAL("fep.image")); + else if(strcmp(cmd,"data") == 0) + dump_objects(TYPE_COUNT); + else if(strcmp(cmd,"refs") == 0) + { + CELL addr = read_cell_hex(); + print_string("Data heap references:\n"); + find_data_references(addr); + nl(); + } + else if(strcmp(cmd,"words") == 0) + dump_objects(WORD_TYPE); + else if(strcmp(cmd,"tuples") == 0) + dump_objects(TUPLE_TYPE); + else if(strcmp(cmd,"push") == 0) + { + CELL addr = read_cell_hex(); + dpush(addr); + } + else if(strcmp(cmd,"code") == 0) + dump_code_heap(); + else + print_string("unknown command\n"); + } +} + +void primitive_die(void) +{ + print_string("The die word was called by the library. Unless you called it yourself,\n"); + print_string("you have triggered a bug in Factor. Please report.\n"); + factorbug(); +} diff --git a/vmpp/debug.hpp b/vmpp/debug.hpp new file mode 100755 index 0000000000..002b251621 --- /dev/null +++ b/vmpp/debug.hpp @@ -0,0 +1,7 @@ +void print_obj(CELL obj); +void print_nested_obj(CELL obj, F_FIXNUM nesting); +void dump_generations(void); +void factorbug(void); +void dump_zone(F_ZONE *z); + +void primitive_die(void); diff --git a/vmpp/dispatch.cpp b/vmpp/dispatch.cpp new file mode 100644 index 0000000000..a759894b22 --- /dev/null +++ b/vmpp/dispatch.cpp @@ -0,0 +1,205 @@ +#include "master.hpp" + +CELL megamorphic_cache_hits; +CELL megamorphic_cache_misses; + +static CELL search_lookup_alist(CELL table, CELL klass) +{ + F_ARRAY *pairs = untag_array_fast(table); + F_FIXNUM index = array_capacity(pairs) - 1; + while(index >= 0) + { + F_ARRAY *pair = untag_array_fast(array_nth(pairs,index)); + if(array_nth(pair,0) == klass) + return array_nth(pair,1); + else + index--; + } + + return F; +} + +static CELL search_lookup_hash(CELL table, CELL klass, CELL hashcode) +{ + F_ARRAY *buckets = untag_array_fast(table); + CELL bucket = array_nth(buckets,hashcode & (array_capacity(buckets) - 1)); + if(type_of(bucket) == WORD_TYPE || bucket == F) + return bucket; + else + return search_lookup_alist(bucket,klass); +} + +static CELL nth_superclass(F_TUPLE_LAYOUT *layout, F_FIXNUM echelon) +{ + CELL *ptr = (CELL *)(layout + 1); + return ptr[echelon * 2]; +} + +static CELL nth_hashcode(F_TUPLE_LAYOUT *layout, F_FIXNUM echelon) +{ + CELL *ptr = (CELL *)(layout + 1); + return ptr[echelon * 2 + 1]; +} + +static CELL lookup_tuple_method(CELL object, CELL methods) +{ + F_TUPLE *tuple = untag_tuple_fast(object); + F_TUPLE_LAYOUT *layout = untag_tuple_layout(tuple->layout); + + F_ARRAY *echelons = untag_array_fast(methods); + + F_FIXNUM echelon = untag_fixnum_fast(layout->echelon); + F_FIXNUM max_echelon = array_capacity(echelons) - 1; + if(echelon > max_echelon) echelon = max_echelon; + + while(echelon >= 0) + { + CELL echelon_methods = array_nth(echelons,echelon); + + if(type_of(echelon_methods) == WORD_TYPE) + return echelon_methods; + else if(echelon_methods != F) + { + CELL klass = nth_superclass(layout,echelon); + CELL hashcode = untag_fixnum_fast(nth_hashcode(layout,echelon)); + CELL result = search_lookup_hash(echelon_methods,klass,hashcode); + if(result != F) + return result; + } + + echelon--; + } + + critical_error("Cannot find tuple method",methods); + return F; +} + +static CELL lookup_hi_tag_method(CELL object, CELL methods) +{ + F_ARRAY *hi_tag_methods = untag_array_fast(methods); + CELL tag = hi_tag(object) - HEADER_TYPE; +#ifdef FACTOR_DEBUG + assert(tag < TYPE_COUNT - HEADER_TYPE); +#endif + return array_nth(hi_tag_methods,tag); +} + +static CELL lookup_hairy_method(CELL object, CELL methods) +{ + CELL method = array_nth(untag_array_fast(methods),TAG(object)); + if(type_of(method) == WORD_TYPE) + return method; + else + { + switch(TAG(object)) + { + case TUPLE_TYPE: + return lookup_tuple_method(object,method); + break; + case OBJECT_TYPE: + return lookup_hi_tag_method(object,method); + break; + default: + critical_error("Bad methods array",methods); + return -1; + } + } +} + +CELL lookup_method(CELL object, CELL methods) +{ + if(!HI_TAG_OR_TUPLE_P(object)) + return array_nth(untag_array_fast(methods),TAG(object)); + else + return lookup_hairy_method(object,methods); +} + +void primitive_lookup_method(void) +{ + CELL methods = dpop(); + CELL object = dpop(); + dpush(lookup_method(object,methods)); +} + +CELL object_class(CELL object) +{ + if(!HI_TAG_OR_TUPLE_P(object)) + return tag_fixnum(TAG(object)); + else + return get(HI_TAG_HEADER(object)); +} + +static CELL method_cache_hashcode(CELL klass, F_ARRAY *array) +{ + CELL capacity = (array_capacity(array) >> 1) - 1; + return ((klass >> TAG_BITS) & capacity) << 1; +} + +static void update_method_cache(CELL cache, CELL klass, CELL method) +{ + F_ARRAY *array = untag_array_fast(cache); + CELL hashcode = method_cache_hashcode(klass,array); + set_array_nth(array,hashcode,klass); + set_array_nth(array,hashcode + 1,method); +} + +void primitive_mega_cache_miss(void) +{ + megamorphic_cache_misses++; + + CELL cache = dpop(); + F_FIXNUM index = untag_fixnum_fast(dpop()); + CELL methods = dpop(); + + CELL object = get(ds - index * CELLS); + CELL klass = object_class(object); + CELL method = lookup_method(object,methods); + + update_method_cache(cache,klass,method); + + dpush(method); +} + +void primitive_reset_dispatch_stats(void) +{ + megamorphic_cache_hits = megamorphic_cache_misses = 0; +} + +void primitive_dispatch_stats(void) +{ + GROWABLE_ARRAY(stats); + GROWABLE_ARRAY_ADD(stats,allot_cell(megamorphic_cache_hits)); + GROWABLE_ARRAY_ADD(stats,allot_cell(megamorphic_cache_misses)); + GROWABLE_ARRAY_TRIM(stats); + GROWABLE_ARRAY_DONE(stats); + dpush(stats); +} + +void jit_emit_class_lookup(F_JIT *jit, F_FIXNUM index, CELL type) +{ + jit_emit_with(jit,userenv[PIC_LOAD],tag_fixnum(-index * CELLS)); + jit_emit(jit,userenv[type]); +} + +void jit_emit_mega_cache_lookup(F_JIT *jit, CELL methods, F_FIXNUM index, CELL cache) +{ + /* Generate machine code to determine the object's class. */ + jit_emit_class_lookup(jit,index,PIC_HI_TAG_TUPLE); + + /* Do a cache lookup. */ + jit_emit_with(jit,userenv[MEGA_LOOKUP],cache); + + /* If we end up here, the cache missed. */ + jit_emit(jit,userenv[JIT_PROLOG]); + + /* Push index, method table and cache on the stack. */ + jit_push(jit,methods); + jit_push(jit,tag_fixnum(index)); + jit_push(jit,cache); + jit_word_call(jit,userenv[MEGA_MISS_WORD]); + + /* Now the new method has been stored into the cache, and its on + the stack. */ + jit_emit(jit,userenv[JIT_EPILOG]); + jit_emit(jit,userenv[JIT_EXECUTE_JUMP]); +} diff --git a/vmpp/dispatch.hpp b/vmpp/dispatch.hpp new file mode 100644 index 0000000000..10c9c6b320 --- /dev/null +++ b/vmpp/dispatch.hpp @@ -0,0 +1,13 @@ +CELL lookup_method(CELL object, CELL methods); +void primitive_lookup_method(void); + +CELL object_class(CELL object); + +void primitive_mega_cache_miss(void); + +void primitive_reset_dispatch_stats(void); +void primitive_dispatch_stats(void); + +void jit_emit_class_lookup(F_JIT *jit, F_FIXNUM index, CELL type); + +void jit_emit_mega_cache_lookup(F_JIT *jit, CELL methods, F_FIXNUM index, CELL cache); diff --git a/vmpp/errors.cpp b/vmpp/errors.cpp new file mode 100755 index 0000000000..9ffc22d454 --- /dev/null +++ b/vmpp/errors.cpp @@ -0,0 +1,157 @@ +#include "master.hpp" + +/* Global variables used to pass fault handler state from signal handler to +user-space */ +CELL signal_number; +CELL signal_fault_addr; +F_STACK_FRAME *signal_callstack_top; + +void out_of_memory(void) +{ + print_string("Out of memory\n\n"); + dump_generations(); + exit(1); +} + +void fatal_error(char* msg, CELL tagged) +{ + print_string("fatal_error: "); print_string(msg); + print_string(": "); print_cell_hex(tagged); nl(); + exit(1); +} + +void critical_error(char* msg, CELL tagged) +{ + print_string("You have triggered a bug in Factor. Please report.\n"); + print_string("critical_error: "); print_string(msg); + print_string(": "); print_cell_hex(tagged); nl(); + factorbug(); +} + +void throw_error(CELL error, F_STACK_FRAME *callstack_top) +{ + /* If the error handler is set, we rewind any C stack frames and + pass the error to user-space. */ + if(userenv[BREAK_ENV] != F) + { + /* If error was thrown during heap scan, we re-enable the GC */ + gc_off = false; + + /* Reset local roots */ + gc_locals = gc_locals_region->start - CELLS; + extra_roots = extra_roots_region->start - CELLS; + + /* If we had an underflow or overflow, stack pointers might be + out of bounds */ + fix_stacks(); + + dpush(error); + + /* Errors thrown from C code pass NULL for this parameter. + Errors thrown from Factor code, or signal handlers, pass the + actual stack pointer at the time, since the saved pointer is + not necessarily up to date at that point. */ + if(callstack_top) + { + callstack_top = fix_callstack_top(callstack_top, + stack_chain->callstack_bottom); + } + else + callstack_top = stack_chain->callstack_top; + + throw_impl(userenv[BREAK_ENV],callstack_top); + } + /* Error was thrown in early startup before error handler is set, just + crash. */ + else + { + print_string("You have triggered a bug in Factor. Please report.\n"); + print_string("early_error: "); + print_obj(error); + nl(); + factorbug(); + } +} + +void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2, + F_STACK_FRAME *callstack_top) +{ + throw_error(allot_array_4(userenv[ERROR_ENV], + tag_fixnum(error),arg1,arg2),callstack_top); +} + +void type_error(CELL type, CELL tagged) +{ + general_error(ERROR_TYPE,tag_fixnum(type),tagged,NULL); +} + +void not_implemented_error(void) +{ + general_error(ERROR_NOT_IMPLEMENTED,F,F,NULL); +} + +/* Test if 'fault' is in the guard page at the top or bottom (depending on +offset being 0 or -1) of area+area_size */ +bool in_page(CELL fault, CELL area, CELL area_size, int offset) +{ + int pagesize = getpagesize(); + area += area_size; + area += offset * pagesize; + + return fault >= area && fault <= area + pagesize; +} + +void memory_protection_error(CELL addr, F_STACK_FRAME *native_stack) +{ + if(in_page(addr, ds_bot, 0, -1)) + general_error(ERROR_DS_UNDERFLOW,F,F,native_stack); + else if(in_page(addr, ds_bot, ds_size, 0)) + general_error(ERROR_DS_OVERFLOW,F,F,native_stack); + else if(in_page(addr, rs_bot, 0, -1)) + general_error(ERROR_RS_UNDERFLOW,F,F,native_stack); + else if(in_page(addr, rs_bot, rs_size, 0)) + general_error(ERROR_RS_OVERFLOW,F,F,native_stack); + else if(in_page(addr, nursery.end, 0, 0)) + critical_error("allot_object() missed GC check",0); + else if(in_page(addr, gc_locals_region->start, 0, -1)) + critical_error("gc locals underflow",0); + else if(in_page(addr, gc_locals_region->end, 0, 0)) + critical_error("gc locals overflow",0); + else if(in_page(addr, extra_roots_region->start, 0, -1)) + critical_error("extra roots underflow",0); + else if(in_page(addr, extra_roots_region->end, 0, 0)) + critical_error("extra roots overflow",0); + else + general_error(ERROR_MEMORY,allot_cell(addr),F,native_stack); +} + +void signal_error(int signal, F_STACK_FRAME *native_stack) +{ + general_error(ERROR_SIGNAL,tag_fixnum(signal),F,native_stack); +} + +void divide_by_zero_error(void) +{ + general_error(ERROR_DIVIDE_BY_ZERO,F,F,NULL); +} + +void memory_signal_handler_impl(void) +{ + memory_protection_error(signal_fault_addr,signal_callstack_top); +} + +void misc_signal_handler_impl(void) +{ + signal_error(signal_number,signal_callstack_top); +} + +void primitive_call_clear(void) +{ + throw_impl(dpop(),stack_chain->callstack_bottom); +} + +/* For testing purposes */ +void primitive_unimplemented(void) +{ + not_implemented_error(); +} diff --git a/vmpp/errors.hpp b/vmpp/errors.hpp new file mode 100755 index 0000000000..8a202da48b --- /dev/null +++ b/vmpp/errors.hpp @@ -0,0 +1,62 @@ +/* Runtime errors */ +typedef enum +{ + ERROR_EXPIRED = 0, + ERROR_IO, + ERROR_NOT_IMPLEMENTED, + ERROR_TYPE, + ERROR_DIVIDE_BY_ZERO, + ERROR_SIGNAL, + ERROR_ARRAY_SIZE, + ERROR_C_STRING, + ERROR_FFI, + ERROR_HEAP_SCAN, + ERROR_UNDEFINED_SYMBOL, + ERROR_DS_UNDERFLOW, + ERROR_DS_OVERFLOW, + ERROR_RS_UNDERFLOW, + ERROR_RS_OVERFLOW, + ERROR_MEMORY, +} F_ERRORTYPE; + +void out_of_memory(void); +void fatal_error(char* msg, CELL tagged); +void critical_error(char* msg, CELL tagged); +void primitive_die(void); + +void throw_error(CELL error, F_STACK_FRAME *native_stack); +void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2, F_STACK_FRAME *native_stack); +void divide_by_zero_error(void); +void memory_protection_error(CELL addr, F_STACK_FRAME *native_stack); +void signal_error(int signal, F_STACK_FRAME *native_stack); +void type_error(CELL type, CELL tagged); +void not_implemented_error(void); + +void primitive_call_clear(void); + +INLINE void type_check(CELL type, CELL tagged) +{ + if(type_of(tagged) != type) type_error(type,tagged); +} + +#define DEFINE_UNTAG(type,check,name) \ + INLINE type *untag_##name##_fast(CELL obj) \ + { \ + return (type *)UNTAG(obj); \ + } \ + INLINE type *untag_##name(CELL obj) \ + { \ + type_check(check,obj); \ + return untag_##name##_fast(obj); \ + } \ + +/* Global variables used to pass fault handler state from signal handler to +user-space */ +extern CELL signal_number; +extern CELL signal_fault_addr; +extern F_STACK_FRAME *signal_callstack_top; + +void memory_signal_handler_impl(void); +void misc_signal_handler_impl(void); + +void primitive_unimplemented(void); diff --git a/vmpp/factor.cpp b/vmpp/factor.cpp new file mode 100755 index 0000000000..f2f928190a --- /dev/null +++ b/vmpp/factor.cpp @@ -0,0 +1,215 @@ +#include "master.hpp" + +void default_parameters(F_PARAMETERS *p) +{ + p->image_path = NULL; + + /* We make a wild guess here that if we're running on ARM, we don't + have a lot of memory. */ +#ifdef FACTOR_ARM + p->ds_size = 8 * CELLS; + p->rs_size = 8 * CELLS; + + p->gen_count = 2; + p->code_size = 4; + p->young_size = 1; + p->aging_size = 1; + p->tenured_size = 6; +#else + p->ds_size = 32 * CELLS; + p->rs_size = 32 * CELLS; + + p->gen_count = 3; + p->code_size = 8 * CELLS; + p->young_size = CELLS / 4; + p->aging_size = CELLS / 2; + p->tenured_size = 4 * CELLS; +#endif + + p->max_pic_size = 3; + + p->secure_gc = false; + p->fep = false; + +#ifdef WINDOWS + p->console = false; +#else + p->console = true; +#endif + + p->stack_traces = true; +} + +INLINE bool factor_arg(const F_CHAR* str, const F_CHAR* arg, CELL* value) +{ + int val; + if(SSCANF(str,arg,&val) > 0) + { + *value = val; + return true; + } + else + return false; +} + +void init_parameters_from_args(F_PARAMETERS *p, int argc, F_CHAR **argv) +{ + default_parameters(p); + p->executable_path = argv[0]; + + int i = 0; + + for(i = 1; i < argc; i++) + { + if(factor_arg(argv[i],STRING_LITERAL("-datastack=%d"),&p->ds_size)); + else if(factor_arg(argv[i],STRING_LITERAL("-retainstack=%d"),&p->rs_size)); + else if(factor_arg(argv[i],STRING_LITERAL("-generations=%d"),&p->gen_count)); + else if(factor_arg(argv[i],STRING_LITERAL("-young=%d"),&p->young_size)); + else if(factor_arg(argv[i],STRING_LITERAL("-aging=%d"),&p->aging_size)); + else if(factor_arg(argv[i],STRING_LITERAL("-tenured=%d"),&p->tenured_size)); + else if(factor_arg(argv[i],STRING_LITERAL("-codeheap=%d"),&p->code_size)); + else if(factor_arg(argv[i],STRING_LITERAL("-pic=%d"),&p->max_pic_size)); + else if(STRCMP(argv[i],STRING_LITERAL("-securegc")) == 0) p->secure_gc = true; + else if(STRCMP(argv[i],STRING_LITERAL("-fep")) == 0) p->fep = true; + else if(STRNCMP(argv[i],STRING_LITERAL("-i="),3) == 0) p->image_path = argv[i] + 3; + else if(STRCMP(argv[i],STRING_LITERAL("-console")) == 0) p->console = true; + else if(STRCMP(argv[i],STRING_LITERAL("-no-stack-traces")) == 0) p->stack_traces = false; + } +} + +/* Do some initialization that we do once only */ +void do_stage1_init(void) +{ + print_string("*** Stage 2 early init... "); + fflush(stdout); + + compile_all_words(); + userenv[STAGE2_ENV] = T; + + print_string("done\n"); + fflush(stdout); +} + +void init_factor(F_PARAMETERS *p) +{ + /* Kilobytes */ + p->ds_size = align_page(p->ds_size << 10); + p->rs_size = align_page(p->rs_size << 10); + + /* Megabytes */ + p->young_size <<= 20; + p->aging_size <<= 20; + p->tenured_size <<= 20; + p->code_size <<= 20; + + /* Disable GC during init as a sanity check */ + gc_off = true; + + /* OS-specific initialization */ + early_init(); + + const F_CHAR *executable_path = vm_executable_path(); + + if(executable_path) + p->executable_path = executable_path; + + if(p->image_path == NULL) + p->image_path = default_image_path(); + + srand(current_micros()); + init_ffi(); + init_stacks(p->ds_size,p->rs_size); + load_image(p); + init_c_io(); + init_inline_caching(p->max_pic_size); + +#ifndef FACTOR_DEBUG + init_signals(); +#endif + + if(p->console) + open_console(); + + init_profiler(); + + userenv[CPU_ENV] = tag_object(from_char_string(FACTOR_CPU_STRING)); + userenv[OS_ENV] = tag_object(from_char_string(FACTOR_OS_STRING)); + userenv[CELL_SIZE_ENV] = tag_fixnum(sizeof(CELL)); + userenv[EXECUTABLE_ENV] = (p->executable_path ? tag_object(from_native_string(p->executable_path)) : F); + userenv[ARGS_ENV] = F; + userenv[EMBEDDED_ENV] = F; + + /* We can GC now */ + gc_off = false; + + if(userenv[STAGE2_ENV] == F) + { + userenv[STACK_TRACES_ENV] = tag_boolean(p->stack_traces); + do_stage1_init(); + } +} + +/* May allocate memory */ +void pass_args_to_factor(int argc, F_CHAR **argv) +{ + F_ARRAY *args = allot_array(ARRAY_TYPE,argc,F); + int i; + + for(i = 1; i < argc; i++) + { + REGISTER_UNTAGGED(args); + CELL arg = tag_object(from_native_string(argv[i])); + UNREGISTER_UNTAGGED(F_ARRAY,args); + set_array_nth(args,i,arg); + } + + userenv[ARGS_ENV] = tag_array(args); +} + +void start_factor(F_PARAMETERS *p) +{ + if(p->fep) factorbug(); + + nest_stacks(); + c_to_factor_toplevel(userenv[BOOT_ENV]); + unnest_stacks(); +} + +void start_embedded_factor(F_PARAMETERS *p) +{ + userenv[EMBEDDED_ENV] = T; + start_factor(p); +} + +void start_standalone_factor(int argc, F_CHAR **argv) +{ + F_PARAMETERS p; + default_parameters(&p); + init_parameters_from_args(&p,argc,argv); + init_factor(&p); + pass_args_to_factor(argc,argv); + start_factor(&p); +} + +char *factor_eval_string(char *string) +{ + char *(*callback)(char *) = (char *(*)(char *))alien_offset(userenv[EVAL_CALLBACK_ENV]); + return callback(string); +} + +void factor_eval_free(char *result) +{ + free(result); +} + +void factor_yield(void) +{ + void (*callback)(void) = (void (*)(void))alien_offset(userenv[YIELD_CALLBACK_ENV]); + callback(); +} + +void factor_sleep(long us) +{ + void (*callback)(long) = (void (*)(long))alien_offset(userenv[SLEEP_CALLBACK_ENV]); + callback(us); +} diff --git a/vmpp/factor.hpp b/vmpp/factor.hpp new file mode 100644 index 0000000000..a3de31a502 --- /dev/null +++ b/vmpp/factor.hpp @@ -0,0 +1,11 @@ +DLLEXPORT void default_parameters(F_PARAMETERS *p); +DLLEXPORT void init_parameters_from_args(F_PARAMETERS *p, int argc, F_CHAR **argv); +DLLEXPORT void init_factor(F_PARAMETERS *p); +DLLEXPORT void pass_args_to_factor(int argc, F_CHAR **argv); +DLLEXPORT void start_embedded_factor(F_PARAMETERS *p); +DLLEXPORT void start_standalone_factor(int argc, F_CHAR **argv); + +DLLEXPORT char *factor_eval_string(char *string); +DLLEXPORT void factor_eval_free(char *result); +DLLEXPORT void factor_yield(void); +DLLEXPORT void factor_sleep(long ms); diff --git a/vmpp/factor.rs b/vmpp/factor.rs new file mode 100644 index 0000000000..47f899fef6 --- /dev/null +++ b/vmpp/factor.rs @@ -0,0 +1,2 @@ +fraptor ICON "misc/icons/Factor.ico" + diff --git a/vmpp/ffi_test.c b/vmpp/ffi_test.c new file mode 100755 index 0000000000..680b144140 --- /dev/null +++ b/vmpp/ffi_test.c @@ -0,0 +1,321 @@ +/* This file is linked into the runtime for the sole purpose + * of testing FFI code. */ +#include "ffi_test.h" + +#include +#include + +void ffi_test_0(void) +{ +} + +int ffi_test_1(void) +{ + return 3; +} + +int ffi_test_2(int x, int y) +{ + return x + y; +} + +int ffi_test_3(int x, int y, int z, int t) +{ + return x + y + z * t; +} + +float ffi_test_4(void) +{ + return 1.5; +} + +double ffi_test_5(void) +{ + return 1.5; +} + +double ffi_test_6(float x, float y) +{ + return x * y; +} + +double ffi_test_7(double x, double y) +{ + return x * y; +} + +double ffi_test_8(double x, float y, double z, float t, int w) +{ + return x * y + z * t + w; +} + +int ffi_test_9(int a, int b, int c, int d, int e, int f, int g) +{ + return a + b + c + d + e + f + g; +} + +int ffi_test_10(int a, int b, double c, int d, float e, int f, int g, int h) +{ + return a - b - c - d - e - f - g - h; +} + +int ffi_test_11(int a, struct foo b, int c) +{ + return a * b.x + c * b.y; +} + +int ffi_test_12(int a, int b, struct rect c, int d, int e, int f) +{ + return a + b + c.x + c.y + c.w + c.h + d + e + f; +} + +int ffi_test_13(int a, int b, int c, int d, int e, int f, int g, int h, int i, int j, int k) +{ + return a + b + c + d + e + f + g + h + i + j + k; +} + +struct foo ffi_test_14(int x, int y) +{ + struct foo r; + r.x = x; r.y = y; + return r; +} + +char *ffi_test_15(char *x, char *y) +{ + if(strcmp(x,y)) + return "foo"; + else + return "bar"; +} + +struct bar ffi_test_16(long x, long y, long z) +{ + struct bar r; + r.x = x; r.y = y; r.z = z; + return r; +} + +struct tiny ffi_test_17(int x) +{ + struct tiny r; + r.x = x; + return r; +} + +F_STDCALL int ffi_test_18(int x, int y, int z, int t) +{ + return x + y + z * t; +} + +F_STDCALL struct bar ffi_test_19(long x, long y, long z) +{ + struct bar r; + r.x = x; r.y = y; r.z = z; + return r; +} + +void ffi_test_20(double x1, double x2, double x3, + double y1, double y2, double y3, + double z1, double z2, double z3) +{ +} + +long long ffi_test_21(long x, long y) +{ + return (long long)x * (long long)y; +} + +long ffi_test_22(long x, long long y, long long z) +{ + return x + y / z; +} + +float ffi_test_23(float x[3], float y[3]) +{ + return x[0] * y[0] + x[1] * y[1] + x[2] * y[2]; +} + +struct test_struct_1 ffi_test_24(void) +{ + struct test_struct_1 s; + s.x = 1; + return s; +} + +struct test_struct_2 ffi_test_25(void) +{ + struct test_struct_2 s; + s.x = 1; + s.y = 2; + return s; +} + +struct test_struct_3 ffi_test_26(void) +{ + struct test_struct_3 s; + s.x = 1; + s.y = 2; + s.z = 3; + return s; +} + +struct test_struct_4 ffi_test_27(void) +{ + struct test_struct_4 s; + s.x = 1; + s.y = 2; + s.z = 3; + s.a = 4; + return s; +} + +struct test_struct_5 ffi_test_28(void) +{ + struct test_struct_5 s; + s.x = 1; + s.y = 2; + s.z = 3; + s.a = 4; + s.b = 5; + return s; +} + +struct test_struct_6 ffi_test_29(void) +{ + struct test_struct_6 s; + s.x = 1; + s.y = 2; + s.z = 3; + s.a = 4; + s.b = 5; + s.c = 6; + return s; +} + +struct test_struct_7 ffi_test_30(void) +{ + struct test_struct_7 s; + s.x = 1; + s.y = 2; + s.z = 3; + s.a = 4; + s.b = 5; + s.c = 6; + s.d = 7; + return s; +} + +int ffi_test_31(int x0, int x1, int x2, int x3, int x4, int x5, int x6, int x7, int x8, int x9, int x10, int x11, int x12, int x13, int x14, int x15, int x16, int x17, int x18, int x19, int x20, int x21, int x22, int x23, int x24, int x25, int x26, int x27, int x28, int x29, int x30, int x31, int x32, int x33, int x34, int x35, int x36, int x37, int x38, int x39, int x40, int x41) +{ + return x0 + x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 + x11 + x12 + x13 + x14 + x15 + x16 + x17 + x18 + x19 + x20 + x21 + x22 + x23 + x24 + x25 + x26 + x27 + x28 + x29 + x30 + x31 + x32 + x33 + x34 + x35 + x36 + x37 + x38 + x39 + x40 + x41; +} + +float ffi_test_31_point_5(float x0, float x1, float x2, float x3, float x4, float x5, float x6, float x7, float x8, float x9, float x10, float x11, float x12, float x13, float x14, float x15, float x16, float x17, float x18, float x19, float x20, float x21, float x22, float x23, float x24, float x25, float x26, float x27, float x28, float x29, float x30, float x31, float x32, float x33, float x34, float x35, float x36, float x37, float x38, float x39, float x40, float x41) +{ + return x0 + x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 + x11 + x12 + x13 + x14 + x15 + x16 + x17 + x18 + x19 + x20 + x21 + x22 + x23 + x24 + x25 + x26 + x27 + x28 + x29 + x30 + x31 + x32 + x33 + x34 + x35 + x36 + x37 + x38 + x39 + x40 + x41; +} + +double ffi_test_32(struct test_struct_8 x, int y) +{ + return (x.x + x.y) * y; +} + +double ffi_test_33(struct test_struct_9 x, int y) +{ + return (x.x + x.y) * y; +} + +double ffi_test_34(struct test_struct_10 x, int y) +{ + return (x.x + x.y) * y; +} + +double ffi_test_35(struct test_struct_11 x, int y) +{ + return (x.x + x.y) * y; +} + +double ffi_test_36(struct test_struct_12 x) +{ + return x.x; +} + +static int global_var; + +void ffi_test_36_point_5(void) +{ + global_var = 0; +} + +int ffi_test_37(int (*f)(int, int, int)) +{ + global_var = f(global_var,global_var * 2,global_var * 3); + return global_var; +} + +unsigned long long ffi_test_38(unsigned long long x, unsigned long long y) +{ + return x * y; +} + +int ffi_test_39(long a, long b, struct test_struct_13 s) +{ + assert(a == b); + return s.x1 + s.x2 + s.x3 + s.x4 + s.x5 + s.x6; +} + +struct test_struct_14 ffi_test_40(double x1, double x2) +{ + struct test_struct_14 retval; + retval.x1 = x1; + retval.x2 = x2; + return retval; +} + +struct test_struct_12 ffi_test_41(int a, double x) +{ + struct test_struct_12 retval; + retval.a = a; + retval.x = x; + return retval; +} + +struct test_struct_15 ffi_test_42(float x, float y) +{ + struct test_struct_15 retval; + retval.x = x; + retval.y = y; + return retval; +} + +struct test_struct_16 ffi_test_43(float x, int a) +{ + struct test_struct_16 retval; + retval.x = x; + retval.a = a; + return retval; +} + +struct test_struct_14 ffi_test_44(void) +{ + struct test_struct_14 retval; + retval.x1 = 1.0; + retval.x2 = 2.0; + return retval; +} + +_Complex float ffi_test_45(int x) +{ + return x; +} + +_Complex double ffi_test_46(int x) +{ + return x; +} + +_Complex float ffi_test_47(_Complex float x, _Complex double y) +{ + return x + 2 * y; +} diff --git a/vmpp/ffi_test.h b/vmpp/ffi_test.h new file mode 100755 index 0000000000..f16e52e091 --- /dev/null +++ b/vmpp/ffi_test.h @@ -0,0 +1,98 @@ +#if defined(FACTOR_X86) + #define F_STDCALL __attribute__((stdcall)) +#else + #define F_STDCALL +#endif + +#define DLLEXPORT + +DLLEXPORT void ffi_test_0(void); +DLLEXPORT int ffi_test_1(void); +DLLEXPORT int ffi_test_2(int x, int y); +DLLEXPORT int ffi_test_3(int x, int y, int z, int t); +DLLEXPORT float ffi_test_4(void); +DLLEXPORT double ffi_test_5(void); +DLLEXPORT double ffi_test_6(float x, float y); +DLLEXPORT double ffi_test_7(double x, double y); +DLLEXPORT double ffi_test_8(double x, float y, double z, float t, int w); +DLLEXPORT int ffi_test_9(int a, int b, int c, int d, int e, int f, int g); +DLLEXPORT int ffi_test_10(int a, int b, double c, int d, float e, int f, int g, int h); +struct foo { int x, y; }; +DLLEXPORT int ffi_test_11(int a, struct foo b, int c); +struct rect { float x, y, w, h; }; +DLLEXPORT int ffi_test_12(int a, int b, struct rect c, int d, int e, int f); +DLLEXPORT int ffi_test_13(int a, int b, int c, int d, int e, int f, int g, int h, int i, int j, int k); +DLLEXPORT struct foo ffi_test_14(int x, int y); +DLLEXPORT char *ffi_test_15(char *x, char *y); +struct bar { long x, y, z; }; +DLLEXPORT struct bar ffi_test_16(long x, long y, long z); +struct tiny { int x; }; +DLLEXPORT struct tiny ffi_test_17(int x); +DLLEXPORT F_STDCALL int ffi_test_18(int x, int y, int z, int t); +DLLEXPORT F_STDCALL struct bar ffi_test_19(long x, long y, long z); +DLLEXPORT void ffi_test_20(double x1, double x2, double x3, + double y1, double y2, double y3, + double z1, double z2, double z3); +DLLEXPORT long long ffi_test_21(long x, long y); +DLLEXPORT long ffi_test_22(long x, long long y, long long z); +DLLEXPORT float ffi_test_23(float x[3], float y[3]); +struct test_struct_1 { char x; }; +DLLEXPORT struct test_struct_1 ffi_test_24(void); +struct test_struct_2 { char x, y; }; +DLLEXPORT struct test_struct_2 ffi_test_25(void); +struct test_struct_3 { char x, y, z; }; +DLLEXPORT struct test_struct_3 ffi_test_26(void); +struct test_struct_4 { char x, y, z, a; }; +DLLEXPORT struct test_struct_4 ffi_test_27(void); +struct test_struct_5 { char x, y, z, a, b; }; +DLLEXPORT struct test_struct_5 ffi_test_28(void); +struct test_struct_6 { char x, y, z, a, b, c; }; +DLLEXPORT struct test_struct_6 ffi_test_29(void); +struct test_struct_7 { char x, y, z, a, b, c, d; }; +DLLEXPORT struct test_struct_7 ffi_test_30(void); +DLLEXPORT int ffi_test_31(int x0, int x1, int x2, int x3, int x4, int x5, int x6, int x7, int x8, int x9, int x10, int x11, int x12, int x13, int x14, int x15, int x16, int x17, int x18, int x19, int x20, int x21, int x22, int x23, int x24, int x25, int x26, int x27, int x28, int x29, int x30, int x31, int x32, int x33, int x34, int x35, int x36, int x37, int x38, int x39, int x40, int x41); +DLLEXPORT float ffi_test_31_point_5(float x0, float x1, float x2, float x3, float x4, float x5, float x6, float x7, float x8, float x9, float x10, float x11, float x12, float x13, float x14, float x15, float x16, float x17, float x18, float x19, float x20, float x21, float x22, float x23, float x24, float x25, float x26, float x27, float x28, float x29, float x30, float x31, float x32, float x33, float x34, float x35, float x36, float x37, float x38, float x39, float x40, float x41); +struct test_struct_8 { double x; double y; }; +DLLEXPORT double ffi_test_32(struct test_struct_8 x, int y); +struct test_struct_9 { float x; float y; }; +DLLEXPORT double ffi_test_33(struct test_struct_9 x, int y); +struct test_struct_10 { float x; int y; }; +DLLEXPORT double ffi_test_34(struct test_struct_10 x, int y); +struct test_struct_11 { int x; int y; }; +DLLEXPORT double ffi_test_35(struct test_struct_11 x, int y); + +struct test_struct_12 { int a; double x; }; + +DLLEXPORT double ffi_test_36(struct test_struct_12 x); + +DLLEXPORT void ffi_test_36_point_5(void); + +DLLEXPORT int ffi_test_37(int (*f)(int, int, int)); + +DLLEXPORT unsigned long long ffi_test_38(unsigned long long x, unsigned long long y); + +struct test_struct_13 { float x1, x2, x3, x4, x5, x6; }; + +DLLEXPORT int ffi_test_39(long a, long b, struct test_struct_13 s); + +struct test_struct_14 { double x1, x2; }; + +DLLEXPORT struct test_struct_14 ffi_test_40(double x1, double x2); + +DLLEXPORT struct test_struct_12 ffi_test_41(int a, double x); + +struct test_struct_15 { float x, y; }; + +DLLEXPORT struct test_struct_15 ffi_test_42(float x, float y); + +struct test_struct_16 { float x; int a; }; + +DLLEXPORT struct test_struct_16 ffi_test_43(float x, int a); + +DLLEXPORT struct test_struct_14 ffi_test_44(); + +DLLEXPORT _Complex float ffi_test_45(int x); + +DLLEXPORT _Complex double ffi_test_46(int x); + +DLLEXPORT _Complex float ffi_test_47(_Complex float x, _Complex double y); diff --git a/vmpp/float_bits.hpp b/vmpp/float_bits.hpp new file mode 100644 index 0000000000..a60d42f97c --- /dev/null +++ b/vmpp/float_bits.hpp @@ -0,0 +1,40 @@ +/* Some functions for converting floating point numbers to binary +representations and vice versa */ + +typedef union { + double x; + u64 y; +} F_DOUBLE_BITS; + +INLINE u64 double_bits(double x) +{ + F_DOUBLE_BITS b; + b.x = x; + return b.y; +} + +INLINE double bits_double(u64 y) +{ + F_DOUBLE_BITS b; + b.y = y; + return b.x; +} + +typedef union { + float x; + u32 y; +} F_FLOAT_BITS; + +INLINE u32 float_bits(float x) +{ + F_FLOAT_BITS b; + b.x = x; + return b.y; +} + +INLINE float bits_float(u32 y) +{ + F_FLOAT_BITS b; + b.y = y; + return b.x; +} diff --git a/vmpp/image.cpp b/vmpp/image.cpp new file mode 100755 index 0000000000..83a48c8f24 --- /dev/null +++ b/vmpp/image.cpp @@ -0,0 +1,339 @@ +#include "master.hpp" + +/* Certain special objects in the image are known to the runtime */ +static void init_objects(F_HEADER *h) +{ + memcpy(userenv,h->userenv,sizeof(userenv)); + + T = h->t; + bignum_zero = h->bignum_zero; + bignum_pos_one = h->bignum_pos_one; + bignum_neg_one = h->bignum_neg_one; +} + +CELL data_relocation_base; + +static void load_data_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p) +{ + CELL good_size = h->data_size + (1 << 20); + + if(good_size > p->tenured_size) + p->tenured_size = good_size; + + init_data_heap(p->gen_count, + p->young_size, + p->aging_size, + p->tenured_size, + p->secure_gc); + + clear_gc_stats(); + + F_ZONE *tenured = &data_heap->generations[TENURED]; + + F_FIXNUM bytes_read = fread((void*)tenured->start,1,h->data_size,file); + + if((CELL)bytes_read != h->data_size) + { + print_string("truncated image: "); + print_fixnum(bytes_read); + print_string(" bytes read, "); + print_cell(h->data_size); + print_string(" bytes expected\n"); + fatal_error("load_data_heap failed",0); + } + + tenured->here = tenured->start + h->data_size; + data_relocation_base = h->data_relocation_base; +} + +CELL code_relocation_base; + +static void load_code_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p) +{ + CELL good_size = h->code_size + (1 << 19); + + if(good_size > p->code_size) + p->code_size = good_size; + + init_code_heap(p->code_size); + + if(h->code_size != 0) + { + size_t bytes_read = fread(first_block(&code_heap),1,h->code_size,file); + if(bytes_read != h->code_size) + { + print_string("truncated image: "); + print_fixnum(bytes_read); + print_string(" bytes read, "); + print_cell(h->code_size); + print_string(" bytes expected\n"); + fatal_error("load_code_heap failed",0); + } + } + + code_relocation_base = h->code_relocation_base; + build_free_list(&code_heap,h->code_size); +} + +/* Save the current image to disk */ +bool save_image(const F_CHAR *filename) +{ + FILE* file; + F_HEADER h; + + file = OPEN_WRITE(filename); + if(file == NULL) + { + print_string("Cannot open image file: "); print_native_string(filename); nl(); + print_string(strerror(errno)); nl(); + return false; + } + + F_ZONE *tenured = &data_heap->generations[TENURED]; + + h.magic = IMAGE_MAGIC; + h.version = IMAGE_VERSION; + h.data_relocation_base = tenured->start; + h.data_size = tenured->here - tenured->start; + h.code_relocation_base = code_heap.segment->start; + h.code_size = heap_size(&code_heap); + + h.t = T; + h.bignum_zero = bignum_zero; + h.bignum_pos_one = bignum_pos_one; + h.bignum_neg_one = bignum_neg_one; + + CELL i; + for(i = 0; i < USER_ENV; i++) + { + if(i < FIRST_SAVE_ENV) + h.userenv[i] = F; + else + h.userenv[i] = userenv[i]; + } + + bool ok = true; + + if(fwrite(&h,sizeof(F_HEADER),1,file) != 1) ok = false; + if(fwrite((void*)tenured->start,h.data_size,1,file) != 1) ok = false; + if(fwrite(first_block(&code_heap),h.code_size,1,file) != 1) ok = false; + if(fclose(file)) ok = false; + + if(!ok) + { + print_string("save-image failed: "); print_string(strerror(errno)); nl(); + } + + return ok; +} + +void primitive_save_image(void) +{ + /* do a full GC to push everything into tenured space */ + gc(); + + save_image(unbox_native_string()); +} + +void primitive_save_image_and_exit(void) +{ + /* We unbox this before doing anything else. This is the only point + where we might throw an error, so we have to throw an error here since + later steps destroy the current image. */ + F_CHAR *path = unbox_native_string(); + + REGISTER_C_STRING(path); + + /* strip out userenv data which is set on startup anyway */ + CELL i; + for(i = 0; i < FIRST_SAVE_ENV; i++) + userenv[i] = F; + + for(i = LAST_SAVE_ENV + 1; i < STACK_TRACES_ENV; i++) + userenv[i] = F; + + /* do a full GC + code heap compaction */ + performing_compaction = true; + compact_code_heap(); + performing_compaction = false; + + UNREGISTER_C_STRING(F_CHAR,path); + + /* Save the image */ + if(save_image(path)) + exit(0); + else + exit(1); +} + +static void data_fixup(CELL *cell) +{ + if(immediate_p(*cell)) + return; + + F_ZONE *tenured = &data_heap->generations[TENURED]; + *cell += (tenured->start - data_relocation_base); +} + +static void code_fixup(CELL cell) +{ + CELL value = get(cell); + put(cell,value + (code_heap.segment->start - code_relocation_base)); +} + +static void fixup_word(F_WORD *word) +{ + if(word->code) + code_fixup((CELL)&word->code); + if(word->profiling) + code_fixup((CELL)&word->profiling); + code_fixup((CELL)&word->xt); +} + +static void fixup_quotation(F_QUOTATION *quot) +{ + if(quot->compiledp == F) + quot->xt = (void *)lazy_jit_compile; + else + { + code_fixup((CELL)"->xt); + code_fixup((CELL)"->code); + } +} + +static void fixup_alien(F_ALIEN *d) +{ + d->expired = T; +} + +static void fixup_stack_frame(F_STACK_FRAME *frame) +{ + code_fixup((CELL)&frame->xt); + code_fixup((CELL)&FRAME_RETURN_ADDRESS(frame)); +} + +static void fixup_callstack_object(F_CALLSTACK *stack) +{ + iterate_callstack_object(stack,fixup_stack_frame); +} + +/* Initialize an object in a newly-loaded image */ +static void relocate_object(CELL relocating) +{ + /* Tuple relocation is a bit trickier; we have to fix up the + fixup object before we can get the tuple size, so do_slots is + out of the question */ + if(untag_header(get(relocating)) == TUPLE_TYPE) + { + data_fixup((CELL *)relocating + 1); + + CELL scan = relocating + 2 * CELLS; + CELL size = untagged_object_size(relocating); + CELL end = relocating + size; + + while(scan < end) + { + data_fixup((CELL *)scan); + scan += CELLS; + } + } + else + { + do_slots(relocating,data_fixup); + + switch(untag_header(get(relocating))) + { + case WORD_TYPE: + fixup_word((F_WORD *)relocating); + break; + case QUOTATION_TYPE: + fixup_quotation((F_QUOTATION *)relocating); + break; + case DLL_TYPE: + ffi_dlopen((F_DLL *)relocating); + break; + case ALIEN_TYPE: + fixup_alien((F_ALIEN *)relocating); + break; + case CALLSTACK_TYPE: + fixup_callstack_object((F_CALLSTACK *)relocating); + break; + } + } +} + +/* Since the image might have been saved with a different base address than +where it is loaded, we need to fix up pointers in the image. */ +void relocate_data() +{ + CELL relocating; + + CELL i; + for(i = 0; i < USER_ENV; i++) + data_fixup(&userenv[i]); + + data_fixup(&T); + data_fixup(&bignum_zero); + data_fixup(&bignum_pos_one); + data_fixup(&bignum_neg_one); + + F_ZONE *tenured = &data_heap->generations[TENURED]; + + for(relocating = tenured->start; + relocating < tenured->here; + relocating += untagged_object_size(relocating)) + { + allot_barrier(relocating); + relocate_object(relocating); + } +} + +static void fixup_code_block(F_CODE_BLOCK *compiled) +{ + /* relocate literal table data */ + data_fixup(&compiled->relocation); + data_fixup(&compiled->literals); + + relocate_code_block(compiled); +} + +void relocate_code() +{ + iterate_code_heap(fixup_code_block); +} + +/* Read an image file from disk, only done once during startup */ +/* This function also initializes the data and code heaps */ +void load_image(F_PARAMETERS *p) +{ + FILE *file = OPEN_READ(p->image_path); + if(file == NULL) + { + print_string("Cannot open image file: "); print_native_string(p->image_path); nl(); + print_string(strerror(errno)); nl(); + exit(1); + } + + F_HEADER h; + if(fread(&h,sizeof(F_HEADER),1,file) != 1) + fatal_error("Cannot read image header",0); + + if(h.magic != IMAGE_MAGIC) + fatal_error("Bad image: magic number check failed",h.magic); + + if(h.version != IMAGE_VERSION) + fatal_error("Bad image: version number check failed",h.version); + + load_data_heap(file,&h,p); + load_code_heap(file,&h,p); + + fclose(file); + + init_objects(&h); + + relocate_data(); + relocate_code(); + + /* Store image path name */ + userenv[IMAGE_ENV] = tag_object(from_native_string(p->image_path)); +} diff --git a/vmpp/image.hpp b/vmpp/image.hpp new file mode 100755 index 0000000000..ac2123c602 --- /dev/null +++ b/vmpp/image.hpp @@ -0,0 +1,45 @@ +#define IMAGE_MAGIC 0x0f0e0d0c +#define IMAGE_VERSION 4 + +typedef struct { + CELL magic; + CELL version; + /* all pointers in the image file are relocated from + relocation_base to here when the image is loaded */ + CELL data_relocation_base; + /* size of heap */ + CELL data_size; + /* code relocation base */ + CELL code_relocation_base; + /* size of code heap */ + CELL code_size; + /* tagged pointer to t singleton */ + CELL t; + /* tagged pointer to bignum 0 */ + CELL bignum_zero; + /* tagged pointer to bignum 1 */ + CELL bignum_pos_one; + /* tagged pointer to bignum -1 */ + CELL bignum_neg_one; + /* Initial user environment */ + CELL userenv[USER_ENV]; +} F_HEADER; + +typedef struct { + const F_CHAR *image_path; + const F_CHAR *executable_path; + CELL ds_size, rs_size; + CELL gen_count, young_size, aging_size, tenured_size; + CELL code_size; + bool secure_gc; + bool fep; + bool console; + bool stack_traces; + CELL max_pic_size; +} F_PARAMETERS; + +void load_image(F_PARAMETERS *p); +bool save_image(const F_CHAR *file); + +void primitive_save_image(void); +void primitive_save_image_and_exit(void); diff --git a/vmpp/inline_cache.cpp b/vmpp/inline_cache.cpp new file mode 100644 index 0000000000..d1835231ad --- /dev/null +++ b/vmpp/inline_cache.cpp @@ -0,0 +1,257 @@ +#include "master.hpp" + +CELL max_pic_size; + +CELL cold_call_to_ic_transitions; +CELL ic_to_pic_transitions; +CELL pic_to_mega_transitions; + +/* PIC_TAG, PIC_HI_TAG, PIC_TUPLE, PIC_HI_TAG_TUPLE */ +CELL pic_counts[4]; + +void init_inline_caching(int max_size) +{ + max_pic_size = max_size; +} + +void deallocate_inline_cache(CELL return_address) +{ + /* Find the call target. */ + XT old_xt = (XT)get_call_target(return_address); + F_CODE_BLOCK *old_block = (F_CODE_BLOCK *)old_xt - 1; + CELL old_type = old_block->block.type; + +#ifdef FACTOR_DEBUG + /* The call target was either another PIC, + or a compiled quotation (megamorphic stub) */ + assert(old_type == PIC_TYPE || old_type == QUOTATION_TYPE); +#endif + + if(old_type == PIC_TYPE) + heap_free(&code_heap,&old_block->block); +} + +/* Figure out what kind of type check the PIC needs based on the methods +it contains */ +static CELL determine_inline_cache_type(CELL cache_entries) +{ + F_ARRAY *array = untag_array_fast(cache_entries); + + bool seen_hi_tag = false, seen_tuple = false; + + CELL i; + for(i = 0; i < array_capacity(array); i += 2) + { + CELL klass = array_nth(array,i); + F_FIXNUM type; + + /* Is it a tuple layout? */ + switch(type_of(klass)) + { + case FIXNUM_TYPE: + type = untag_fixnum_fast(klass); + if(type >= HEADER_TYPE) + seen_hi_tag = true; + break; + case ARRAY_TYPE: + seen_tuple = true; + break; + default: + critical_error("Expected a fixnum or array",klass); + break; + } + } + + if(seen_hi_tag && seen_tuple) return PIC_HI_TAG_TUPLE; + if(seen_hi_tag && !seen_tuple) return PIC_HI_TAG; + if(!seen_hi_tag && seen_tuple) return PIC_TUPLE; + if(!seen_hi_tag && !seen_tuple) return PIC_TAG; + + critical_error("Oops",0); + return -1; +} + +static void update_pic_count(CELL type) +{ + pic_counts[type - PIC_TAG]++; +} + +static void jit_emit_check(F_JIT *jit, CELL klass) +{ + CELL code_template; + if(TAG(klass) == FIXNUM_TYPE && untag_fixnum_fast(klass) < HEADER_TYPE) + code_template = userenv[PIC_CHECK_TAG]; + else + code_template = userenv[PIC_CHECK]; + + jit_emit_with(jit,code_template,klass); +} + +/* index: 0 = top of stack, 1 = item underneath, etc + cache_entries: array of class/method pairs */ +static F_CODE_BLOCK *compile_inline_cache(F_FIXNUM index, CELL generic_word, CELL methods, CELL cache_entries) +{ +#ifdef FACTOR_DEBUG + type_check(WORD_TYPE,generic_word); + type_check(ARRAY_TYPE,cache_entries); +#endif + + REGISTER_ROOT(generic_word); + REGISTER_ROOT(methods); + REGISTER_ROOT(cache_entries); + + CELL inline_cache_type = determine_inline_cache_type(cache_entries); + + update_pic_count(inline_cache_type); + + F_JIT jit; + jit_init(&jit,PIC_TYPE,generic_word); + + /* Generate machine code to determine the object's class. */ + jit_emit_class_lookup(&jit,index,inline_cache_type); + + /* Generate machine code to check, in turn, if the class is one of the cached entries. */ + CELL i; + for(i = 0; i < array_capacity(untag_array_fast(cache_entries)); i += 2) + { + /* Class equal? */ + CELL klass = array_nth(untag_array_fast(cache_entries),i); + jit_emit_check(&jit,klass); + + /* Yes? Jump to method */ + CELL method = array_nth(untag_array_fast(cache_entries),i + 1); + jit_emit_with(&jit,userenv[PIC_HIT],method); + } + + /* Generate machine code to handle a cache miss, which ultimately results in + this function being called again. + + The inline-cache-miss primitive call receives enough information to + reconstruct the PIC. */ + jit_push(&jit,generic_word); + jit_push(&jit,methods); + jit_push(&jit,tag_fixnum(index)); + jit_push(&jit,cache_entries); + jit_word_jump(&jit,userenv[PIC_MISS_WORD]); + + F_CODE_BLOCK *code = jit_make_code_block(&jit); + relocate_code_block(code); + + jit_dispose(&jit); + + UNREGISTER_ROOT(cache_entries); + UNREGISTER_ROOT(methods); + UNREGISTER_ROOT(generic_word); + + return code; +} + +/* A generic word's definition performs general method lookup. Allocates memory */ +static XT megamorphic_call_stub(CELL generic_word) +{ + return untag_word(generic_word)->xt; +} + +static CELL inline_cache_size(CELL cache_entries) +{ + return (cache_entries == F ? 0 : array_capacity(untag_array(cache_entries)) / 2); +} + +/* Allocates memory */ +static CELL add_inline_cache_entry(CELL cache_entries, CELL klass, CELL method) +{ + if(cache_entries == F) + return allot_array_2(klass,method); + else + { + F_ARRAY *cache_entries_array = untag_array_fast(cache_entries); + CELL pic_size = array_capacity(cache_entries_array); + cache_entries_array = reallot_array(cache_entries_array,pic_size + 2); + set_array_nth(cache_entries_array,pic_size,klass); + set_array_nth(cache_entries_array,pic_size + 1,method); + return tag_array(cache_entries_array); + } +} + +static void update_pic_transitions(CELL pic_size) +{ + if(pic_size == max_pic_size) + pic_to_mega_transitions++; + else if(pic_size == 0) + cold_call_to_ic_transitions++; + else if(pic_size == 1) + ic_to_pic_transitions++; +} + +/* The cache_entries parameter is either f (on cold call site) or an array (on cache miss). +Called from assembly with the actual return address */ +XT inline_cache_miss(CELL return_address) +{ + check_code_pointer(return_address); + + /* Since each PIC is only referenced from a single call site, + if the old call target was a PIC, we can deallocate it immediately, + instead of leaving dead PICs around until the next GC. */ + deallocate_inline_cache(return_address); + + CELL cache_entries = dpop(); + F_FIXNUM index = untag_fixnum_fast(dpop()); + CELL methods = dpop(); + CELL generic_word = dpop(); + CELL object = get(ds - index * CELLS); + + XT xt; + + CELL pic_size = inline_cache_size(cache_entries); + + update_pic_transitions(pic_size); + + if(pic_size >= max_pic_size) + xt = megamorphic_call_stub(generic_word); + else + { + REGISTER_ROOT(generic_word); + REGISTER_ROOT(cache_entries); + REGISTER_ROOT(methods); + + CELL klass = object_class(object); + CELL method = lookup_method(object,methods); + + cache_entries = add_inline_cache_entry(cache_entries,klass,method); + xt = compile_inline_cache(index,generic_word,methods,cache_entries) + 1; + + UNREGISTER_ROOT(methods); + UNREGISTER_ROOT(cache_entries); + UNREGISTER_ROOT(generic_word); + } + + /* Install the new stub. */ + set_call_target(return_address,(CELL)xt); + +#ifdef PIC_DEBUG + printf("Updated call site 0x%lx with 0x%lx\n",return_address,(CELL)xt); +#endif + + return xt; +} + +void primitive_reset_inline_cache_stats(void) +{ + cold_call_to_ic_transitions = ic_to_pic_transitions = pic_to_mega_transitions = 0; + CELL i; + for(i = 0; i < 4; i++) pic_counts[i] = 0; +} + +void primitive_inline_cache_stats(void) +{ + GROWABLE_ARRAY(stats); + GROWABLE_ARRAY_ADD(stats,allot_cell(cold_call_to_ic_transitions)); + GROWABLE_ARRAY_ADD(stats,allot_cell(ic_to_pic_transitions)); + GROWABLE_ARRAY_ADD(stats,allot_cell(pic_to_mega_transitions)); + CELL i; + for(i = 0; i < 4; i++) + GROWABLE_ARRAY_ADD(stats,allot_cell(pic_counts[i])); + GROWABLE_ARRAY_TRIM(stats); + GROWABLE_ARRAY_DONE(stats); + dpush(stats); +} diff --git a/vmpp/inline_cache.hpp b/vmpp/inline_cache.hpp new file mode 100644 index 0000000000..46f8d5c909 --- /dev/null +++ b/vmpp/inline_cache.hpp @@ -0,0 +1,8 @@ +extern CELL max_pic_size; + +void init_inline_caching(int max_size); + +void primitive_reset_inline_cache_stats(void); +void primitive_inline_cache_stats(void); + +extern "C" XT inline_cache_miss(CELL return_address); diff --git a/vmpp/io.cpp b/vmpp/io.cpp new file mode 100755 index 0000000000..a48b252e2a --- /dev/null +++ b/vmpp/io.cpp @@ -0,0 +1,226 @@ +#include "master.hpp" + +/* Simple wrappers for ANSI C I/O functions, used for bootstrapping. + +Note the ugly loop logic in almost every function; we have to handle EINTR +and restart the operation if the system call was interrupted. Naive +applications don't do this, but then they quickly fail if one enables +itimer()s or other signals. + +The Factor library provides platform-specific code for Unix and Windows +with many more capabilities so these words are not usually used in +normal operation. */ + +void init_c_io(void) +{ + userenv[STDIN_ENV] = allot_alien(F,(CELL)stdin); + userenv[STDOUT_ENV] = allot_alien(F,(CELL)stdout); + userenv[STDERR_ENV] = allot_alien(F,(CELL)stderr); +} + +void io_error(void) +{ +#ifndef WINCE + if(errno == EINTR) + return; +#endif + + CELL error = tag_object(from_char_string(strerror(errno))); + general_error(ERROR_IO,error,F,NULL); +} + +void primitive_fopen(void) +{ + char *mode = unbox_char_string(); + REGISTER_C_STRING(mode); + char *path = unbox_char_string(); + UNREGISTER_C_STRING(char,mode); + + for(;;) + { + FILE *file = fopen(path,mode); + if(file == NULL) + io_error(); + else + { + box_alien(file); + break; + } + } +} + +void primitive_fgetc(void) +{ + FILE *file = (FILE *)unbox_alien(); + + for(;;) + { + int c = fgetc(file); + if(c == EOF) + { + if(feof(file)) + { + dpush(F); + break; + } + else + io_error(); + } + else + { + dpush(tag_fixnum(c)); + break; + } + } +} + +void primitive_fread(void) +{ + FILE *file = (FILE *)unbox_alien(); + F_FIXNUM size = unbox_array_size(); + + if(size == 0) + { + dpush(tag_object(allot_string(0,0))); + return; + } + + F_BYTE_ARRAY *buf = allot_byte_array(size); + + for(;;) + { + int c = fread(buf + 1,1,size,file); + if(c <= 0) + { + if(feof(file)) + { + dpush(F); + break; + } + else + io_error(); + } + else + { + if(c != size) + { + REGISTER_UNTAGGED(buf); + F_BYTE_ARRAY *new_buf = allot_byte_array(c); + UNREGISTER_UNTAGGED(F_BYTE_ARRAY,buf); + memcpy(new_buf + 1, buf + 1,c); + buf = new_buf; + } + dpush(tag_object(buf)); + break; + } + } +} + +void primitive_fputc(void) +{ + FILE *file = (FILE *)unbox_alien(); + F_FIXNUM ch = to_fixnum(dpop()); + + for(;;) + { + if(fputc(ch,file) == EOF) + { + io_error(); + + /* Still here? EINTR */ + } + else + break; + } +} + +void primitive_fwrite(void) +{ + FILE *file = (FILE *)unbox_alien(); + F_BYTE_ARRAY *text = untag_byte_array(dpop()); + CELL length = array_capacity(text); + char *string = (char *)(text + 1); + + if(length == 0) + return; + + for(;;) + { + size_t written = fwrite(string,1,length,file); + if(written == length) + break; + else + { + if(feof(file)) + break; + else + io_error(); + + /* Still here? EINTR */ + length -= written; + string += written; + } + } +} + +void primitive_fseek(void) +{ + int whence = to_fixnum(dpop()); + FILE *file = (FILE *)unbox_alien(); + off_t offset = to_signed_8(dpop()); + + switch(whence) + { + case 0: whence = SEEK_SET; break; + case 1: whence = SEEK_CUR; break; + case 2: whence = SEEK_END; break; + default: + critical_error("Bad value for whence",whence); + break; + } + + if(FSEEK(file,offset,whence) == -1) + { + io_error(); + + /* Still here? EINTR */ + critical_error("Don't know what to do; EINTR from fseek()?",0); + } +} + +void primitive_fflush(void) +{ + FILE *file = (FILE *)unbox_alien(); + for(;;) + { + if(fflush(file) == EOF) + io_error(); + else + break; + } +} + +void primitive_fclose(void) +{ + FILE *file = (FILE *)unbox_alien(); + for(;;) + { + if(fclose(file) == EOF) + io_error(); + else + break; + } +} + +/* This function is used by FFI I/O. Accessing the errno global directly is +not portable, since on some libc's errno is not a global but a funky macro that +reads thread-local storage. */ +int err_no(void) +{ + return errno; +} + +void clear_err_no(void) +{ + errno = 0; +} diff --git a/vmpp/io.hpp b/vmpp/io.hpp new file mode 100755 index 0000000000..63a9c35490 --- /dev/null +++ b/vmpp/io.hpp @@ -0,0 +1,18 @@ +void init_c_io(void); +void io_error(void); +DLLEXPORT int err_no(void); +DLLEXPORT void clear_err_no(void); + +void primitive_fopen(void); +void primitive_fgetc(void); +void primitive_fread(void); +void primitive_fputc(void); +void primitive_fwrite(void); +void primitive_fflush(void); +void primitive_fseek(void); +void primitive_fclose(void); + +/* Platform specific primitives */ +void primitive_open_file(void); +void primitive_existsp(void); +void primitive_read_dir(void); diff --git a/vmpp/jit.cpp b/vmpp/jit.cpp new file mode 100644 index 0000000000..d5196ed663 --- /dev/null +++ b/vmpp/jit.cpp @@ -0,0 +1,123 @@ +#include "master.hpp" + +/* Simple code generator used by: +- profiler (profiler.c), +- quotation compiler (quotations.c), +- megamorphic caches (dispatch.c), +- polymorphic inline caches (inline_cache.c) */ + +/* Allocates memory */ +void jit_init(F_JIT *jit, CELL jit_type, CELL owner) +{ + jit->owner = owner; + REGISTER_ROOT(jit->owner); + + jit->type = jit_type; + + jit->code = make_growable_byte_array(); + REGISTER_ROOT(jit->code.array); + jit->relocation = make_growable_byte_array(); + REGISTER_ROOT(jit->relocation.array); + jit->literals = make_growable_array(); + REGISTER_ROOT(jit->literals.array); + + if(stack_traces_p()) + growable_array_add(&jit->literals,jit->owner); + + jit->computing_offset_p = false; +} + +/* Facility to convert compiled code offsets to quotation offsets. +Call jit_compute_offset() with the compiled code offset, then emit +code, and at the end jit->position is the quotation position. */ +void jit_compute_position(F_JIT *jit, CELL offset) +{ + jit->computing_offset_p = true; + jit->position = 0; + jit->offset = offset; +} + +/* Allocates memory */ +F_CODE_BLOCK *jit_make_code_block(F_JIT *jit) +{ + growable_byte_array_trim(&jit->code); + growable_byte_array_trim(&jit->relocation); + growable_array_trim(&jit->literals); + + F_CODE_BLOCK *code = add_code_block( + jit->type, + untag_byte_array_fast(jit->code.array), + NULL, /* no labels */ + jit->relocation.array, + jit->literals.array); + + return code; +} + +void jit_dispose(F_JIT *jit) +{ + UNREGISTER_ROOT(jit->literals.array); + UNREGISTER_ROOT(jit->relocation.array); + UNREGISTER_ROOT(jit->code.array); + UNREGISTER_ROOT(jit->owner); +} + +static F_REL rel_to_emit(F_JIT *jit, CELL code_template, bool *rel_p) +{ + F_ARRAY *quadruple = untag_array_fast(code_template); + CELL rel_class = array_nth(quadruple,1); + CELL rel_type = array_nth(quadruple,2); + CELL offset = array_nth(quadruple,3); + + if(rel_class == F) + { + *rel_p = false; + return 0; + } + else + { + *rel_p = true; + return (untag_fixnum_fast(rel_type) << 28) + | (untag_fixnum_fast(rel_class) << 24) + | ((jit->code.count + untag_fixnum_fast(offset))); + } +} + +/* Allocates memory */ +void jit_emit(F_JIT *jit, CELL code_template) +{ +#ifdef FACTOR_DEBUG + type_check(ARRAY_TYPE,code_template); +#endif + + REGISTER_ROOT(code_template); + + bool rel_p; + F_REL rel = rel_to_emit(jit,code_template,&rel_p); + if(rel_p) growable_byte_array_append(&jit->relocation,&rel,sizeof(F_REL)); + + F_BYTE_ARRAY *code = code_to_emit(code_template); + + if(jit->computing_offset_p) + { + CELL size = array_capacity(code); + + if(jit->offset == 0) + { + jit->position--; + jit->computing_offset_p = false; + } + else if(jit->offset < size) + { + jit->position++; + jit->computing_offset_p = false; + } + else + jit->offset -= size; + } + + growable_byte_array_append(&jit->code,code + 1,array_capacity(code)); + + UNREGISTER_ROOT(code_template); +} + diff --git a/vmpp/jit.hpp b/vmpp/jit.hpp new file mode 100644 index 0000000000..e6219ed8c7 --- /dev/null +++ b/vmpp/jit.hpp @@ -0,0 +1,92 @@ +typedef struct { + CELL type; + CELL owner; + F_GROWABLE_BYTE_ARRAY code; + F_GROWABLE_BYTE_ARRAY relocation; + F_GROWABLE_ARRAY literals; + bool computing_offset_p; + F_FIXNUM position; + CELL offset; +} F_JIT; + +void jit_init(F_JIT *jit, CELL jit_type, CELL owner); + +void jit_compute_position(F_JIT *jit, CELL offset); + +F_CODE_BLOCK *jit_make_code_block(F_JIT *jit); + +void jit_dispose(F_JIT *jit); + +INLINE F_BYTE_ARRAY *code_to_emit(CELL code_template) +{ + return untag_byte_array_fast(array_nth(untag_array_fast(code_template),0)); +} + +void jit_emit(F_JIT *jit, CELL code_template); + +/* Allocates memory */ +INLINE void jit_add_literal(F_JIT *jit, CELL literal) +{ +#ifdef FACTOR_DEBUG + type_of(literal); +#endif + growable_array_add(&jit->literals,literal); +} + +/* Allocates memory */ +INLINE void jit_emit_with(F_JIT *jit, CELL code_template, CELL argument) +{ + REGISTER_ROOT(code_template); + jit_add_literal(jit,argument); + UNREGISTER_ROOT(code_template); + jit_emit(jit,code_template); +} + +/* Allocates memory */ +INLINE void jit_push(F_JIT *jit, CELL literal) +{ + jit_emit_with(jit,userenv[JIT_PUSH_IMMEDIATE],literal); +} + +/* Allocates memory */ +INLINE void jit_word_jump(F_JIT *jit, CELL word) +{ + jit_emit_with(jit,userenv[JIT_WORD_JUMP],word); +} + +/* Allocates memory */ +INLINE void jit_word_call(F_JIT *jit, CELL word) +{ + jit_emit_with(jit,userenv[JIT_WORD_CALL],word); +} + +/* Allocates memory */ +INLINE void jit_emit_subprimitive(F_JIT *jit, CELL word) +{ + CELL code_template = untag_word_fast(word)->subprimitive; + REGISTER_ROOT(code_template); + + if(array_nth(untag_array_fast(code_template),1) != F) + jit_add_literal(jit,T); + + jit_emit(jit,code_template); + UNREGISTER_ROOT(code_template); +} + +INLINE F_FIXNUM jit_get_position(F_JIT *jit) +{ + if(jit->computing_offset_p) + { + /* If this is still on, jit_emit() didn't clear it, + so the offset was out of bounds */ + return -1; + } + else + return jit->position; +} + +INLINE void jit_set_position(F_JIT *jit, F_FIXNUM position) +{ + if(jit->computing_offset_p) + jit->position = position; +} diff --git a/vmpp/layouts.hpp b/vmpp/layouts.hpp new file mode 100755 index 0000000000..f00cb12622 --- /dev/null +++ b/vmpp/layouts.hpp @@ -0,0 +1,263 @@ +#define INLINE inline static + +typedef unsigned char u8; +typedef unsigned short u16; +typedef unsigned int u32; +typedef unsigned long long u64; +typedef signed char s8; +typedef signed short s16; +typedef signed int s32; +typedef signed long long s64; + +#ifdef _WIN64 + typedef long long F_FIXNUM; + typedef unsigned long long CELL; +#else + typedef long F_FIXNUM; + typedef unsigned long CELL; +#endif + +#define CELLS ((signed)sizeof(CELL)) + +#define WORD_SIZE (CELLS*8) +#define HALF_WORD_SIZE (CELLS*4) +#define HALF_WORD_MASK (((unsigned long)1<> TAG_BITS; +} + +INLINE CELL tag_fixnum(F_FIXNUM untagged) +{ + return RETAG(untagged << TAG_BITS,FIXNUM_TYPE); +} + +typedef void *XT; + +struct F_OBJECT { + CELL header; +}; + +/* Assembly code makes assumptions about the layout of this struct */ +struct F_ARRAY : public F_OBJECT { + static const CELL type_number = ARRAY_TYPE; + /* tagged */ + CELL capacity; +}; + +/* These are really just arrays, but certain elements have special +significance */ +struct F_TUPLE_LAYOUT : public F_ARRAY { + /* tagged */ + CELL klass; + /* tagged fixnum */ + CELL size; + /* tagged fixnum */ + CELL echelon; +}; + +struct F_BIGNUM : public F_OBJECT { + static const CELL type_number = BIGNUM_TYPE; + /* tagged */ + CELL capacity; +}; + +struct F_BYTE_ARRAY : public F_OBJECT { + static const CELL type_number = BYTE_ARRAY_TYPE; + /* tagged */ + CELL capacity; +}; + +/* Assembly code makes assumptions about the layout of this struct */ +struct F_STRING : public F_OBJECT { + static const CELL type_number = STRING_TYPE; + /* tagged num of chars */ + CELL length; + /* tagged */ + CELL aux; + /* tagged */ + CELL hashcode; +}; + +/* The compiled code heap is structured into blocks. */ +typedef enum +{ + B_FREE, + B_ALLOCATED, + B_MARKED +} F_BLOCK_STATUS; + +struct F_BLOCK +{ + unsigned char status; /* free or allocated? */ + unsigned char type; /* this is WORD_TYPE or QUOTATION_TYPE */ + unsigned char last_scan; /* the youngest generation in which this block's literals may live */ + char needs_fixup; /* is this a new block that needs full fixup? */ + + /* In bytes, includes this header */ + CELL size; + + /* Used during compaction */ + F_BLOCK *forwarding; +}; + +struct F_FREE_BLOCK +{ + F_BLOCK block; + + /* Filled in on image load */ + F_FREE_BLOCK *next_free; +}; + +struct F_CODE_BLOCK +{ + F_BLOCK block; + CELL literals; /* # bytes */ + CELL relocation; /* tagged pointer to byte-array or f */ +}; + +/* Assembly code makes assumptions about the layout of this struct */ +struct F_WORD : public F_OBJECT { + static const CELL type_number = WORD_TYPE; + /* TAGGED hashcode */ + CELL hashcode; + /* TAGGED word name */ + CELL name; + /* TAGGED word vocabulary */ + CELL vocabulary; + /* TAGGED definition */ + CELL def; + /* TAGGED property assoc for library code */ + CELL props; + /* TAGGED alternative entry point for direct non-tail calls. Used for inline caching */ + CELL direct_entry_def; + /* TAGGED call count for profiling */ + CELL counter; + /* TAGGED machine code for sub-primitive */ + CELL subprimitive; + /* UNTAGGED execution token: jump here to execute word */ + XT xt; + /* UNTAGGED compiled code block */ + F_CODE_BLOCK *code; + /* UNTAGGED profiler stub */ + F_CODE_BLOCK *profiling; +}; + +/* Assembly code makes assumptions about the layout of this struct */ +struct F_WRAPPER : public F_OBJECT { + static const CELL type_number = WRAPPER_TYPE; + CELL object; +}; + +/* Assembly code makes assumptions about the layout of this struct */ +struct F_FLOAT { +/* We use a union here to force the float value to be aligned on an +8-byte boundary. */ + static const CELL type_number = FLOAT_TYPE; + union { + CELL header; + long long padding; + }; + double n; +}; + +/* Assembly code makes assumptions about the layout of this struct */ +struct F_QUOTATION : public F_OBJECT { + static const CELL type_number = QUOTATION_TYPE; + /* tagged */ + CELL array; + /* tagged */ + CELL compiledp; + /* tagged */ + CELL cached_effect; + /* tagged */ + CELL cache_counter; + /* UNTAGGED */ + XT xt; + /* UNTAGGED compiled code block */ + F_CODE_BLOCK *code; +}; + +/* Assembly code makes assumptions about the layout of this struct */ +struct F_ALIEN : public F_OBJECT { + static const CELL type_number = ALIEN_TYPE; + /* tagged */ + CELL alien; + /* tagged */ + CELL expired; + /* untagged */ + CELL displacement; +}; + +struct F_DLL : public F_OBJECT { + static const CELL type_number = DLL_TYPE; + /* tagged byte array holding a C string */ + CELL path; + /* OS-specific handle */ + void *dll; +}; + +struct F_CALLSTACK : public F_OBJECT { + static const CELL type_number = CALLSTACK_TYPE; + /* tagged */ + CELL length; +}; + +struct F_STACK_FRAME +{ + XT xt; + /* Frame size in bytes */ + CELL size; +}; + +struct F_TUPLE : public F_OBJECT { + static const CELL type_number = TUPLE_TYPE; + /* tagged layout */ + CELL layout; +}; diff --git a/vmpp/local_roots.cpp b/vmpp/local_roots.cpp new file mode 100644 index 0000000000..14822f82ee --- /dev/null +++ b/vmpp/local_roots.cpp @@ -0,0 +1,7 @@ +#include "master.hpp" + +F_SEGMENT *gc_locals_region; +CELL gc_locals; + +F_SEGMENT *extra_roots_region; +CELL extra_roots; diff --git a/vmpp/local_roots.hpp b/vmpp/local_roots.hpp new file mode 100644 index 0000000000..2a5d3559e5 --- /dev/null +++ b/vmpp/local_roots.hpp @@ -0,0 +1,66 @@ +/* If a runtime function needs to call another function which potentially +allocates memory, it must store any local variable references to Factor +objects on the root stack */ +extern F_SEGMENT *gc_locals_region; +extern CELL gc_locals; + +DEFPUSHPOP(gc_local_,gc_locals) + +template +class gc_root : public tagged +{ + void push() { gc_local_push((CELL)this); } +public: + explicit gc_root(CELL value_) : tagged(value_) { push(); } + explicit gc_root(T *value_) : tagged(value_) { push(); } + gc_root(const gc_root& copy) : tagged(copy.untag()) {} + ~gc_root() { CELL old = gc_local_pop(); assert(old == (CELL)this); } +}; + +#define REGISTER_ROOT(obj) \ + { \ + if(!immediate_p(obj)) \ + check_data_pointer(obj); \ + gc_local_push((CELL)&(obj)); \ + } +#define UNREGISTER_ROOT(obj) \ + { \ + if(gc_local_pop() != (CELL)&(obj)) \ + critical_error("Mismatched REGISTER_ROOT/UNREGISTER_ROOT",0); \ + } + +/* Extra roots: stores pointers to objects in the heap. Requires extra work +(you have to unregister before accessing the object) but more flexible. */ +extern F_SEGMENT *extra_roots_region; +extern CELL extra_roots; + +DEFPUSHPOP(root_,extra_roots) + +#define REGISTER_UNTAGGED(obj) root_push(obj ? RETAG(obj,OBJECT_TYPE) : 0) +#define UNREGISTER_UNTAGGED(type,obj) obj = (type *)UNTAG(root_pop()) + +/* We ignore strings which point outside the data heap, but we might be given +a char* which points inside the data heap, in which case it is a root, for +example if we call unbox_char_string() the result is placed in a byte array */ +INLINE bool root_push_alien(const void *ptr) +{ + if(in_data_heap_p((CELL)ptr)) + { + F_BYTE_ARRAY *objptr = ((F_BYTE_ARRAY *)ptr) - 1; + if(objptr->header == tag_header(BYTE_ARRAY_TYPE)) + { + root_push(tag_object(objptr)); + return true; + } + } + + return false; +} + +#define REGISTER_C_STRING(obj) \ + bool obj##_root = root_push_alien((const char *)obj) +#define UNREGISTER_C_STRING(type,obj) \ + if(obj##_root) obj = (type *)alien_offset(root_pop()) + +#define REGISTER_BIGNUM(obj) if(obj) root_push(tag_bignum(obj)) +#define UNREGISTER_BIGNUM(obj) if(obj) obj = (untag_bignum_fast(root_pop())) diff --git a/vmpp/mach_signal.cpp b/vmpp/mach_signal.cpp new file mode 100644 index 0000000000..3230c944d1 --- /dev/null +++ b/vmpp/mach_signal.cpp @@ -0,0 +1,202 @@ +/* Fault handler information. MacOSX version. +Copyright (C) 1993-1999, 2002-2003 Bruno Haible +Copyright (C) 2003 Paolo Bonzini + +Used under BSD license with permission from Paolo Bonzini and Bruno Haible, +2005-03-10: + +http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org + +Modified for Factor by Slava Pestov */ + +#include "master.hpp" + +/* The exception port on which our thread listens. */ +mach_port_t our_exception_port; + +/* The following sources were used as a *reference* for this exception handling +code: +1. Apple's mach/xnu documentation +2. Timothy J. Wood's "Mach Exception Handlers 101" post to the +omnigroup's macosx-dev list. +http://www.wodeveloper.com/omniLists/macosx-dev/2000/June/msg00137.html */ + +/* Modify a suspended thread's thread_state so that when the thread resumes +executing, the call frame of the current C primitive (if any) is rewound, and +the appropriate Factor error is thrown from the top-most Factor frame. */ +static void call_fault_handler(exception_type_t exception, + MACH_EXC_STATE_TYPE *exc_state, + MACH_THREAD_STATE_TYPE *thread_state) +{ + /* There is a race condition here, but in practice an exception + delivered during stack frame setup/teardown or while transitioning + from Factor to C is a sign of things seriously gone wrong, not just + a divide by zero or stack underflow in the listener */ + + /* Are we in compiled Factor code? Then use the current stack pointer */ + if(in_code_heap_p(MACH_PROGRAM_COUNTER(thread_state))) + signal_callstack_top = (F_STACK_FRAME *)MACH_STACK_POINTER(thread_state); + /* Are we in C? Then use the saved callstack top */ + else + signal_callstack_top = NULL; + + MACH_STACK_POINTER(thread_state) = fix_stack_pointer(MACH_STACK_POINTER(thread_state)); + + /* Now we point the program counter at the right handler function. */ + if(exception == EXC_BAD_ACCESS) + { + signal_fault_addr = MACH_EXC_STATE_FAULT(exc_state); + MACH_PROGRAM_COUNTER(thread_state) = (CELL)memory_signal_handler_impl; + } + else + { + if(exception == EXC_ARITHMETIC) + signal_number = SIGFPE; + else + signal_number = SIGABRT; + MACH_PROGRAM_COUNTER(thread_state) = (CELL)misc_signal_handler_impl; + } +} + +/* Handle an exception by invoking the user's fault handler and/or forwarding +the duty to the previously installed handlers. */ +kern_return_t +catch_exception_raise (mach_port_t exception_port, + mach_port_t thread, + mach_port_t task, + exception_type_t exception, + exception_data_t code, + mach_msg_type_number_t code_count) +{ + MACH_EXC_STATE_TYPE exc_state; + MACH_THREAD_STATE_TYPE thread_state; + mach_msg_type_number_t state_count; + + /* Get fault information and the faulting thread's register contents.. + + See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/thread_get_state.html. */ + state_count = MACH_EXC_STATE_COUNT; + if (thread_get_state (thread, MACH_EXC_STATE_FLAVOR, + (natural_t *)&exc_state, &state_count) + != KERN_SUCCESS) + { + /* The thread is supposed to be suspended while the exception + handler is called. This shouldn't fail. */ + return KERN_FAILURE; + } + + state_count = MACH_THREAD_STATE_COUNT; + if (thread_get_state (thread, MACH_THREAD_STATE_FLAVOR, + (natural_t *)&thread_state, &state_count) + != KERN_SUCCESS) + { + /* The thread is supposed to be suspended while the exception + handler is called. This shouldn't fail. */ + return KERN_FAILURE; + } + + /* Modify registers so to have the thread resume executing the + fault handler */ + call_fault_handler(exception,&exc_state,&thread_state); + + /* Set the faulting thread's register contents.. + + See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/thread_set_state.html. */ + if (thread_set_state (thread, MACH_THREAD_STATE_FLAVOR, + (natural_t *)&thread_state, state_count) + != KERN_SUCCESS) + { + return KERN_FAILURE; + } + + return KERN_SUCCESS; +} + + +/* The main function of the thread listening for exceptions. */ +static void * +mach_exception_thread (void *arg) +{ + for (;;) + { + /* These two structures contain some private kernel data. We don't need + to access any of it so we don't bother defining a proper struct. The + correct definitions are in the xnu source code. */ + /* Buffer for a message to be received. */ + struct + { + mach_msg_header_t head; + mach_msg_body_t msgh_body; + char data[1024]; + } + msg; + /* Buffer for a reply message. */ + struct + { + mach_msg_header_t head; + char data[1024]; + } + reply; + + mach_msg_return_t retval; + + /* Wait for a message on the exception port. */ + retval = mach_msg (&msg.head, MACH_RCV_MSG | MACH_RCV_LARGE, 0, + sizeof (msg), our_exception_port, + MACH_MSG_TIMEOUT_NONE, MACH_PORT_NULL); + if (retval != MACH_MSG_SUCCESS) + { + abort (); + } + + /* Handle the message: Call exc_server, which will call + catch_exception_raise and produce a reply message. */ + exc_server (&msg.head, &reply.head); + + /* Send the reply. */ + if (mach_msg (&reply.head, MACH_SEND_MSG, reply.head.msgh_size, + 0, MACH_PORT_NULL, MACH_MSG_TIMEOUT_NONE, MACH_PORT_NULL) + != MACH_MSG_SUCCESS) + { + abort (); + } + } +} + + +/* Initialize the Mach exception handler thread. */ +void mach_initialize (void) +{ + mach_port_t self; + exception_mask_t mask; + + self = mach_task_self (); + + /* Allocate a port on which the thread shall listen for exceptions. */ + if (mach_port_allocate (self, MACH_PORT_RIGHT_RECEIVE, &our_exception_port) + != KERN_SUCCESS) + fatal_error("mach_port_allocate() failed",0); + + /* See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/mach_port_insert_right.html. */ + if (mach_port_insert_right (self, our_exception_port, our_exception_port, + MACH_MSG_TYPE_MAKE_SEND) + != KERN_SUCCESS) + fatal_error("mach_port_insert_right() failed",0); + + /* The exceptions we want to catch. */ + mask = EXC_MASK_BAD_ACCESS | EXC_MASK_ARITHMETIC; + + /* Create the thread listening on the exception port. */ + start_thread(mach_exception_thread); + + /* Replace the exception port info for these exceptions with our own. + Note that we replace the exception port for the entire task, not only + for a particular thread. This has the effect that when our exception + port gets the message, the thread specific exception port has already + been asked, and we don't need to bother about it. + See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/task_set_exception_ports.html. */ + if (task_set_exception_ports (self, mask, our_exception_port, + EXCEPTION_DEFAULT, MACHINE_THREAD_STATE) + != KERN_SUCCESS) + fatal_error("task_set_exception_ports() failed",0); +} diff --git a/vmpp/mach_signal.hpp b/vmpp/mach_signal.hpp new file mode 100644 index 0000000000..ee58a3acee --- /dev/null +++ b/vmpp/mach_signal.hpp @@ -0,0 +1,75 @@ +/* Fault handler information. MacOSX version. +Copyright (C) 1993-1999, 2002-2003 Bruno Haible +Copyright (C) 2003 Paolo Bonzini + +Used under BSD license with permission from Paolo Bonzini and Bruno Haible, +2005-03-10: + +http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org + +Modified for Factor by Slava Pestov */ +#include +#include +#include +#include + +#include +#include +#include +#include +#include +#include + +/* This is not defined in any header, although documented. */ + +/* http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/exc_server.html says: + The exc_server function is the MIG generated server handling function + to handle messages from the kernel relating to the occurrence of an + exception in a thread. Such messages are delivered to the exception port + set via thread_set_exception_ports or task_set_exception_ports. When an + exception occurs in a thread, the thread sends an exception message to its + exception port, blocking in the kernel waiting for the receipt of a reply. + The exc_server function performs all necessary argument handling for this + kernel message and calls catch_exception_raise, catch_exception_raise_state + or catch_exception_raise_state_identity, which should handle the exception. + If the called routine returns KERN_SUCCESS, a reply message will be sent, + allowing the thread to continue from the point of the exception; otherwise, + no reply message is sent and the called routine must have dealt with the + exception thread directly. */ +extern "C" boolean_t exc_server (mach_msg_header_t *request_msg, mach_msg_header_t *reply_msg); + + +/* http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/catch_exception_raise.html + These functions are defined in this file, and called by exc_server. + FIXME: What needs to be done when this code is put into a shared library? */ +kern_return_t +catch_exception_raise (mach_port_t exception_port, + mach_port_t thread, + mach_port_t task, + exception_type_t exception, + exception_data_t code, + mach_msg_type_number_t code_count); +kern_return_t +catch_exception_raise_state (mach_port_t exception_port, + exception_type_t exception, + exception_data_t code, + mach_msg_type_number_t code_count, + thread_state_flavor_t *flavor, + thread_state_t in_state, + mach_msg_type_number_t in_state_count, + thread_state_t out_state, + mach_msg_type_number_t *out_state_count); +kern_return_t +catch_exception_raise_state_identity (mach_port_t exception_port, + mach_port_t thread, + mach_port_t task, + exception_type_t exception, + exception_data_t code, + mach_msg_type_number_t codeCnt, + thread_state_flavor_t *flavor, + thread_state_t in_state, + mach_msg_type_number_t in_state_count, + thread_state_t out_state, + mach_msg_type_number_t *out_state_count); + +void mach_initialize (void); diff --git a/vmpp/main-unix.cpp b/vmpp/main-unix.cpp new file mode 100644 index 0000000000..33fd471d42 --- /dev/null +++ b/vmpp/main-unix.cpp @@ -0,0 +1,7 @@ +#include "master.hpp" + +int main(int argc, char **argv) +{ + start_standalone_factor(argc,argv); + return 0; +} diff --git a/vmpp/main-windows-ce.cpp b/vmpp/main-windows-ce.cpp new file mode 100644 index 0000000000..61aeb12729 --- /dev/null +++ b/vmpp/main-windows-ce.cpp @@ -0,0 +1,134 @@ +#include "master.hpp" + +/* + Windows CE argument parsing ported to work on + int main(int argc, wchar_t **argv). + + This would not be necessary if Windows CE had CommandLineToArgvW. + + Based on MinGW's public domain char** version. + +*/ + +int __argc; +wchar_t **__argv; + +static int +parse_tokens(wchar_t* string, wchar_t*** tokens, int length) +{ + /* Extract whitespace- and quotes- delimited tokens from the given string + and put them into the tokens array. Returns number of tokens + extracted. Length specifies the current size of tokens[]. + THIS METHOD MODIFIES string. */ + + const wchar_t* whitespace = L" \t\r\n"; + wchar_t* tokenEnd = 0; + const wchar_t* quoteCharacters = L"\"\'"; + wchar_t *end = string + wcslen(string); + + if (string == NULL) + return length; + + while (1) + { + const wchar_t* q; + /* Skip over initial whitespace. */ + string += wcsspn(string, whitespace); + if (*string == '\0') + break; + + for (q = quoteCharacters; *q; ++q) + { + if (*string == *q) + break; + } + if (*q) + { + /* Token is quoted. */ + wchar_t quote = *string++; + tokenEnd = wcschr(string, quote); + /* If there is no endquote, the token is the rest of the string. */ + if (!tokenEnd) + tokenEnd = end; + } + else + { + tokenEnd = string + wcscspn(string, whitespace); + } + + *tokenEnd = '\0'; + + { + wchar_t** new_tokens; + int newlen = length + 1; + new_tokens = realloc (*tokens, sizeof (wchar_t**) * newlen); + if (!new_tokens) + { + /* Out of memory. */ + return -1; + } + + *tokens = new_tokens; + (*tokens)[length] = string; + length = newlen; + } + if (tokenEnd == end) + break; + string = tokenEnd + 1; + } + return length; +} + +static void +parse_args(int *argc, wchar_t ***argv, wchar_t *cmdlinePtrW) +{ + wchar_t cmdnameBufW[MAX_UNICODE_PATH]; + int cmdlineLen = 0; + int modlen; + + /* argv[0] is the path of invoked program - get this from CE. */ + cmdnameBufW[0] = 0; + modlen = GetModuleFileNameW(NULL, cmdnameBufW, sizeof (cmdnameBufW)/sizeof (cmdnameBufW[0])); + + if (!cmdlinePtrW) + cmdlineLen = 0; + else + cmdlineLen = wcslen(cmdlinePtrW); + + /* gets realloc()'d later */ + *argv = malloc (sizeof (wchar_t**) * 1); + if (!*argv) + ExitProcess(-1); + + (*argv)[0] = wcsdup(cmdnameBufW); + if(!(*argv[0])) + ExitProcess(-1); + /* Add one to account for argv[0] */ + (*argc)++; + + if (cmdlineLen > 0) + { + wchar_t* argv1 = (*argv)[0] + wcslen((*argv)[0]) + 1; + argv1 = wcsdup(cmdlinePtrW); + if(!argv1) + ExitProcess(-1); + *argc = parse_tokens(argv1, argv, 1); + if (*argc < 0) + ExitProcess(-1); + } + (*argv)[*argc] = 0; + return; +} + +int WINAPI +WinMain( + HINSTANCE hInstance, + HINSTANCE hPrevInstance, + LPWSTR lpCmdLine, + int nCmdShow) +{ + parse_args(&__argc, &__argv, lpCmdLine); + start_standalone_factor(__argc,(LPWSTR*)__argv); + // memory leak from malloc, wcsdup + return 0; +} diff --git a/vmpp/main-windows-nt.cpp b/vmpp/main-windows-nt.cpp new file mode 100755 index 0000000000..026947c4f0 --- /dev/null +++ b/vmpp/main-windows-nt.cpp @@ -0,0 +1,27 @@ +#include +#include +#include +#include "master.hpp" + +int WINAPI WinMain( + HINSTANCE hInstance, + HINSTANCE hPrevInstance, + LPSTR lpCmdLine, + int nCmdShow) +{ + LPWSTR *szArglist; + int nArgs; + + szArglist = CommandLineToArgvW(GetCommandLineW(), &nArgs); + if(NULL == szArglist) + { + puts("CommandLineToArgvW failed"); + return 1; + } + + start_standalone_factor(nArgs,szArglist); + + LocalFree(szArglist); + + return 0; +} diff --git a/vmpp/master.hpp b/vmpp/master.hpp new file mode 100644 index 0000000000..22f3be27b7 --- /dev/null +++ b/vmpp/master.hpp @@ -0,0 +1,60 @@ +#ifndef __FACTOR_MASTER_H__ +#define __FACTOR_MASTER_H__ + +#ifndef WINCE +#include +#endif + +#ifdef FACTOR_DEBUG +#include +#endif + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#include "layouts.hpp" +#include "tagged.hpp" +#include "platform.hpp" +#include "primitives.hpp" +#include "run.hpp" +#include "profiler.hpp" +#include "errors.hpp" +#include "bignumint.hpp" +#include "bignum.hpp" +#include "write_barrier.hpp" +#include "generic_arrays.hpp" +#include "data_heap.hpp" +#include "data_gc.hpp" +#include "local_roots.hpp" +#include "debug.hpp" +#include "arrays.hpp" +#include "strings.hpp" +#include "booleans.hpp" +#include "byte_arrays.hpp" +#include "tuples.hpp" +#include "words.hpp" +#include "math.hpp" +#include "float_bits.hpp" +#include "io.hpp" +#include "code_gc.hpp" +#include "code_block.hpp" +#include "code_heap.hpp" +#include "image.hpp" +#include "callstack.hpp" +#include "alien.hpp" +#include "quotations.hpp" +#include "jit.hpp" +#include "dispatch.hpp" +#include "inline_cache.hpp" +#include "factor.hpp" +#include "utilities.hpp" + +#endif /* __FACTOR_MASTER_H__ */ diff --git a/vmpp/math.cpp b/vmpp/math.cpp new file mode 100644 index 0000000000..7bc27b35c1 --- /dev/null +++ b/vmpp/math.cpp @@ -0,0 +1,519 @@ +#include "master.hpp" + +CELL bignum_zero; +CELL bignum_pos_one; +CELL bignum_neg_one; + +/* Fixnums */ +F_FIXNUM to_fixnum(CELL tagged) +{ + switch(TAG(tagged)) + { + case FIXNUM_TYPE: + return untag_fixnum_fast(tagged); + case BIGNUM_TYPE: + return bignum_to_fixnum(untag_bignum_fast(tagged)); + default: + type_error(FIXNUM_TYPE,tagged); + return -1; /* can't happen */ + } +} + +CELL to_cell(CELL tagged) +{ + return (CELL)to_fixnum(tagged); +} + +void primitive_bignum_to_fixnum(void) +{ + drepl(tag_fixnum(bignum_to_fixnum(untag_bignum_fast(dpeek())))); +} + +void primitive_float_to_fixnum(void) +{ + drepl(tag_fixnum(float_to_fixnum(dpeek()))); +} + +/* The fixnum+, fixnum- and fixnum* primitives are defined in cpu_*.S. On +overflow, they call these functions. */ +F_FASTCALL void overflow_fixnum_add(F_FIXNUM x, F_FIXNUM y) +{ + drepl(tag_bignum(fixnum_to_bignum( + untag_fixnum_fast(x) + untag_fixnum_fast(y)))); +} + +F_FASTCALL void overflow_fixnum_subtract(F_FIXNUM x, F_FIXNUM y) +{ + drepl(tag_bignum(fixnum_to_bignum( + untag_fixnum_fast(x) - untag_fixnum_fast(y)))); +} + +F_FASTCALL void overflow_fixnum_multiply(F_FIXNUM x, F_FIXNUM y) +{ + F_ARRAY *bx = fixnum_to_bignum(x); + REGISTER_BIGNUM(bx); + F_ARRAY *by = fixnum_to_bignum(y); + UNREGISTER_BIGNUM(bx); + drepl(tag_bignum(bignum_multiply(bx,by))); +} + +/* Division can only overflow when we are dividing the most negative fixnum +by -1. */ +void primitive_fixnum_divint(void) +{ + F_FIXNUM y = untag_fixnum_fast(dpop()); \ + F_FIXNUM x = untag_fixnum_fast(dpeek()); + F_FIXNUM result = x / y; + if(result == -FIXNUM_MIN) + drepl(allot_integer(-FIXNUM_MIN)); + else + drepl(tag_fixnum(result)); +} + +void primitive_fixnum_divmod(void) +{ + CELL y = get(ds); + CELL x = get(ds - CELLS); + if(y == tag_fixnum(-1) && x == tag_fixnum(FIXNUM_MIN)) + { + put(ds - CELLS,allot_integer(-FIXNUM_MIN)); + put(ds,tag_fixnum(0)); + } + else + { + put(ds - CELLS,tag_fixnum(untag_fixnum_fast(x) / untag_fixnum_fast(y))); + put(ds,x % y); + } +} + +/* + * If we're shifting right by n bits, we won't overflow as long as none of the + * high WORD_SIZE-TAG_BITS-n bits are set. + */ +#define SIGN_MASK(x) ((x) >> (WORD_SIZE - 1)) +#define BRANCHLESS_MAX(x,y) ((x) - (((x) - (y)) & SIGN_MASK((x) - (y)))) +#define BRANCHLESS_ABS(x) ((x ^ SIGN_MASK(x)) - SIGN_MASK(x)) + +void primitive_fixnum_shift(void) +{ + F_FIXNUM y = untag_fixnum_fast(dpop()); \ + F_FIXNUM x = untag_fixnum_fast(dpeek()); + + if(x == 0) + return; + else if(y < 0) + { + y = BRANCHLESS_MAX(y,-WORD_SIZE + 1); + drepl(tag_fixnum(x >> -y)); + return; + } + else if(y < WORD_SIZE - TAG_BITS) + { + F_FIXNUM mask = -((F_FIXNUM)1 << (WORD_SIZE - 1 - TAG_BITS - y)); + if(!(BRANCHLESS_ABS(x) & mask)) + { + drepl(tag_fixnum(x << y)); + return; + } + } + + drepl(tag_bignum(bignum_arithmetic_shift( + fixnum_to_bignum(x),y))); +} + +/* Bignums */ +void primitive_fixnum_to_bignum(void) +{ + drepl(tag_bignum(fixnum_to_bignum(untag_fixnum_fast(dpeek())))); +} + +void primitive_float_to_bignum(void) +{ + drepl(tag_bignum(float_to_bignum(dpeek()))); +} + +#define POP_BIGNUMS(x,y) \ + bignum_type y = untag_bignum_fast(dpop()); \ + bignum_type x = untag_bignum_fast(dpop()); + +void primitive_bignum_eq(void) +{ + POP_BIGNUMS(x,y); + box_boolean(bignum_equal_p(x,y)); +} + +void primitive_bignum_add(void) +{ + POP_BIGNUMS(x,y); + dpush(tag_bignum(bignum_add(x,y))); +} + +void primitive_bignum_subtract(void) +{ + POP_BIGNUMS(x,y); + dpush(tag_bignum(bignum_subtract(x,y))); +} + +void primitive_bignum_multiply(void) +{ + POP_BIGNUMS(x,y); + dpush(tag_bignum(bignum_multiply(x,y))); +} + +void primitive_bignum_divint(void) +{ + POP_BIGNUMS(x,y); + dpush(tag_bignum(bignum_quotient(x,y))); +} + +void primitive_bignum_divmod(void) +{ + F_ARRAY *q, *r; + POP_BIGNUMS(x,y); + bignum_divide(x,y,&q,&r); + dpush(tag_bignum(q)); + dpush(tag_bignum(r)); +} + +void primitive_bignum_mod(void) +{ + POP_BIGNUMS(x,y); + dpush(tag_bignum(bignum_remainder(x,y))); +} + +void primitive_bignum_and(void) +{ + POP_BIGNUMS(x,y); + dpush(tag_bignum(bignum_bitwise_and(x,y))); +} + +void primitive_bignum_or(void) +{ + POP_BIGNUMS(x,y); + dpush(tag_bignum(bignum_bitwise_ior(x,y))); +} + +void primitive_bignum_xor(void) +{ + POP_BIGNUMS(x,y); + dpush(tag_bignum(bignum_bitwise_xor(x,y))); +} + +void primitive_bignum_shift(void) +{ + F_FIXNUM y = untag_fixnum_fast(dpop()); + F_ARRAY* x = untag_bignum_fast(dpop()); + dpush(tag_bignum(bignum_arithmetic_shift(x,y))); +} + +void primitive_bignum_less(void) +{ + POP_BIGNUMS(x,y); + box_boolean(bignum_compare(x,y) == bignum_comparison_less); +} + +void primitive_bignum_lesseq(void) +{ + POP_BIGNUMS(x,y); + box_boolean(bignum_compare(x,y) != bignum_comparison_greater); +} + +void primitive_bignum_greater(void) +{ + POP_BIGNUMS(x,y); + box_boolean(bignum_compare(x,y) == bignum_comparison_greater); +} + +void primitive_bignum_greatereq(void) +{ + POP_BIGNUMS(x,y); + box_boolean(bignum_compare(x,y) != bignum_comparison_less); +} + +void primitive_bignum_not(void) +{ + drepl(tag_bignum(bignum_bitwise_not(untag_bignum_fast(dpeek())))); +} + +void primitive_bignum_bitp(void) +{ + F_FIXNUM bit = to_fixnum(dpop()); + F_ARRAY *x = untag_bignum_fast(dpop()); + box_boolean(bignum_logbitp(bit,x)); +} + +void primitive_bignum_log2(void) +{ + drepl(tag_bignum(bignum_integer_length(untag_bignum_fast(dpeek())))); +} + +unsigned int bignum_producer(unsigned int digit) +{ + unsigned char *ptr = (unsigned char *)alien_offset(dpeek()); + return *(ptr + digit); +} + +void primitive_byte_array_to_bignum(void) +{ + type_check(BYTE_ARRAY_TYPE,dpeek()); + CELL n_digits = array_capacity(untag_bignum_fast(dpeek())); + bignum_type bignum = digit_stream_to_bignum( + n_digits,bignum_producer,0x100,0); + drepl(tag_bignum(bignum)); +} + +void box_signed_1(s8 n) +{ + dpush(tag_fixnum(n)); +} + +void box_unsigned_1(u8 n) +{ + dpush(tag_fixnum(n)); +} + +void box_signed_2(s16 n) +{ + dpush(tag_fixnum(n)); +} + +void box_unsigned_2(u16 n) +{ + dpush(tag_fixnum(n)); +} + +void box_signed_4(s32 n) +{ + dpush(allot_integer(n)); +} + +void box_unsigned_4(u32 n) +{ + dpush(allot_cell(n)); +} + +void box_signed_cell(F_FIXNUM integer) +{ + dpush(allot_integer(integer)); +} + +void box_unsigned_cell(CELL cell) +{ + dpush(allot_cell(cell)); +} + +void box_signed_8(s64 n) +{ + if(n < FIXNUM_MIN || n > FIXNUM_MAX) + dpush(tag_bignum(long_long_to_bignum(n))); + else + dpush(tag_fixnum(n)); +} + +s64 to_signed_8(CELL obj) +{ + switch(type_of(obj)) + { + case FIXNUM_TYPE: + return untag_fixnum_fast(obj); + case BIGNUM_TYPE: + return bignum_to_long_long(untag_bignum_fast(obj)); + default: + type_error(BIGNUM_TYPE,obj); + return -1; + } +} + +void box_unsigned_8(u64 n) +{ + if(n > FIXNUM_MAX) + dpush(tag_bignum(ulong_long_to_bignum(n))); + else + dpush(tag_fixnum(n)); +} + +u64 to_unsigned_8(CELL obj) +{ + switch(type_of(obj)) + { + case FIXNUM_TYPE: + return untag_fixnum_fast(obj); + case BIGNUM_TYPE: + return bignum_to_ulong_long(untag_bignum_fast(obj)); + default: + type_error(BIGNUM_TYPE,obj); + return -1; + } +} + +CELL unbox_array_size(void) +{ + switch(type_of(dpeek())) + { + case FIXNUM_TYPE: + { + F_FIXNUM n = untag_fixnum_fast(dpeek()); + if(n >= 0 && n < (F_FIXNUM)ARRAY_SIZE_MAX) + { + dpop(); + return n; + } + break; + } + case BIGNUM_TYPE: + { + bignum_type zero = untag_bignum_fast(bignum_zero); + bignum_type max = cell_to_bignum(ARRAY_SIZE_MAX); + bignum_type n = untag_bignum_fast(dpeek()); + if(bignum_compare(n,zero) != bignum_comparison_less + && bignum_compare(n,max) == bignum_comparison_less) + { + dpop(); + return bignum_to_cell(n); + } + break; + } + } + + general_error(ERROR_ARRAY_SIZE,dpop(),tag_fixnum(ARRAY_SIZE_MAX),NULL); + return 0; /* can't happen */ +} + +/* Floats */ +void primitive_fixnum_to_float(void) +{ + drepl(allot_float(fixnum_to_float(dpeek()))); +} + +void primitive_bignum_to_float(void) +{ + drepl(allot_float(bignum_to_float(dpeek()))); +} + +void primitive_str_to_float(void) +{ + char *c_str, *end; + double f; + F_STRING *str = untag_string(dpeek()); + CELL capacity = string_capacity(str); + + c_str = to_char_string(str,false); + end = c_str; + f = strtod(c_str,&end); + if(end != c_str + capacity) + drepl(F); + else + drepl(allot_float(f)); +} + +void primitive_float_to_str(void) +{ + char tmp[33]; + snprintf(tmp,32,"%.16g",untag_float(dpop())); + tmp[32] = '\0'; + box_char_string(tmp); +} + +#define POP_FLOATS(x,y) \ + double y = untag_float_fast(dpop()); \ + double x = untag_float_fast(dpop()); + +void primitive_float_eq(void) +{ + POP_FLOATS(x,y); + box_boolean(x == y); +} + +void primitive_float_add(void) +{ + POP_FLOATS(x,y); + box_double(x + y); +} + +void primitive_float_subtract(void) +{ + POP_FLOATS(x,y); + box_double(x - y); +} + +void primitive_float_multiply(void) +{ + POP_FLOATS(x,y); + box_double(x * y); +} + +void primitive_float_divfloat(void) +{ + POP_FLOATS(x,y); + box_double(x / y); +} + +void primitive_float_mod(void) +{ + POP_FLOATS(x,y); + box_double(fmod(x,y)); +} + +void primitive_float_less(void) +{ + POP_FLOATS(x,y); + box_boolean(x < y); +} + +void primitive_float_lesseq(void) +{ + POP_FLOATS(x,y); + box_boolean(x <= y); +} + +void primitive_float_greater(void) +{ + POP_FLOATS(x,y); + box_boolean(x > y); +} + +void primitive_float_greatereq(void) +{ + POP_FLOATS(x,y); + box_boolean(x >= y); +} + +void primitive_float_bits(void) +{ + box_unsigned_4(float_bits(untag_float(dpop()))); +} + +void primitive_bits_float(void) +{ + box_float(bits_float(to_cell(dpop()))); +} + +void primitive_double_bits(void) +{ + box_unsigned_8(double_bits(untag_float(dpop()))); +} + +void primitive_bits_double(void) +{ + box_double(bits_double(to_unsigned_8(dpop()))); +} + +float to_float(CELL value) +{ + return untag_float(value); +} + +double to_double(CELL value) +{ + return untag_float(value); +} + +void box_float(float flo) +{ + dpush(allot_float(flo)); +} + +void box_double(double flo) +{ + dpush(allot_float(flo)); +} diff --git a/vmpp/math.hpp b/vmpp/math.hpp new file mode 100644 index 0000000000..dc8218c0c1 --- /dev/null +++ b/vmpp/math.hpp @@ -0,0 +1,149 @@ +#define CELL_MAX (CELL)(-1) +#define FIXNUM_MAX (((F_FIXNUM)1 << (WORD_SIZE - TAG_BITS - 1)) - 1) +#define FIXNUM_MIN (-((F_FIXNUM)1 << (WORD_SIZE - TAG_BITS - 1))) +#define ARRAY_SIZE_MAX ((CELL)1 << (WORD_SIZE - TAG_BITS - 2)) + +DLLEXPORT F_FIXNUM to_fixnum(CELL tagged); +DLLEXPORT CELL to_cell(CELL tagged); + +void primitive_bignum_to_fixnum(void); +void primitive_float_to_fixnum(void); + +F_FASTCALL void overflow_fixnum_add(F_FIXNUM x, F_FIXNUM y); +F_FASTCALL void overflow_fixnum_subtract(F_FIXNUM x, F_FIXNUM y); +F_FASTCALL void overflow_fixnum_multiply(F_FIXNUM x, F_FIXNUM y); + +void primitive_fixnum_divint(void); +void primitive_fixnum_divmod(void); +void primitive_fixnum_shift(void); + +extern CELL bignum_zero; +extern CELL bignum_pos_one; +extern CELL bignum_neg_one; + +DEFINE_UNTAG(F_ARRAY,BIGNUM_TYPE,bignum); + +INLINE CELL tag_bignum(F_ARRAY* bignum) +{ + return RETAG(bignum,BIGNUM_TYPE); +} + +void primitive_fixnum_to_bignum(void); +void primitive_float_to_bignum(void); +void primitive_bignum_eq(void); +void primitive_bignum_add(void); +void primitive_bignum_subtract(void); +void primitive_bignum_multiply(void); +void primitive_bignum_divint(void); +void primitive_bignum_divmod(void); +void primitive_bignum_mod(void); +void primitive_bignum_and(void); +void primitive_bignum_or(void); +void primitive_bignum_xor(void); +void primitive_bignum_shift(void); +void primitive_bignum_less(void); +void primitive_bignum_lesseq(void); +void primitive_bignum_greater(void); +void primitive_bignum_greatereq(void); +void primitive_bignum_not(void); +void primitive_bignum_bitp(void); +void primitive_bignum_log2(void); +void primitive_byte_array_to_bignum(void); + +INLINE CELL allot_integer(F_FIXNUM x) +{ + if(x < FIXNUM_MIN || x > FIXNUM_MAX) + return tag_bignum(fixnum_to_bignum(x)); + else + return tag_fixnum(x); +} + +INLINE CELL allot_cell(CELL x) +{ + if(x > (CELL)FIXNUM_MAX) + return tag_bignum(cell_to_bignum(x)); + else + return tag_fixnum(x); +} + +/* FFI calls this */ +DLLEXPORT void box_signed_1(s8 n); +DLLEXPORT void box_unsigned_1(u8 n); +DLLEXPORT void box_signed_2(s16 n); +DLLEXPORT void box_unsigned_2(u16 n); +DLLEXPORT void box_signed_4(s32 n); +DLLEXPORT void box_unsigned_4(u32 n); +DLLEXPORT void box_signed_cell(F_FIXNUM integer); +DLLEXPORT void box_unsigned_cell(CELL cell); +DLLEXPORT void box_signed_8(s64 n); +DLLEXPORT s64 to_signed_8(CELL obj); + +DLLEXPORT void box_unsigned_8(u64 n); +DLLEXPORT u64 to_unsigned_8(CELL obj); + +CELL unbox_array_size(void); + +INLINE double untag_float_fast(CELL tagged) +{ + return ((F_FLOAT *)UNTAG(tagged))->n; +} + +INLINE double untag_float(CELL tagged) +{ + type_check(FLOAT_TYPE,tagged); + return untag_float_fast(tagged); +} + +INLINE CELL allot_float(double n) +{ + F_FLOAT* flo = (F_FLOAT *)allot_object(FLOAT_TYPE,sizeof(F_FLOAT)); + flo->n = n; + return RETAG(flo,FLOAT_TYPE); +} + +INLINE F_FIXNUM float_to_fixnum(CELL tagged) +{ + return (F_FIXNUM)untag_float_fast(tagged); +} + +INLINE F_ARRAY *float_to_bignum(CELL tagged) +{ + return double_to_bignum(untag_float_fast(tagged)); +} + +INLINE double fixnum_to_float(CELL tagged) +{ + return (double)untag_fixnum_fast(tagged); +} + +INLINE double bignum_to_float(CELL tagged) +{ + return bignum_to_double(untag_bignum_fast(tagged)); +} + +DLLEXPORT void box_float(float flo); +DLLEXPORT float to_float(CELL value); +DLLEXPORT void box_double(double flo); +DLLEXPORT double to_double(CELL value); + +void primitive_fixnum_to_float(void); +void primitive_bignum_to_float(void); +void primitive_str_to_float(void); +void primitive_float_to_str(void); +void primitive_float_to_bits(void); + +void primitive_float_eq(void); +void primitive_float_add(void); +void primitive_float_subtract(void); +void primitive_float_multiply(void); +void primitive_float_divfloat(void); +void primitive_float_mod(void); +void primitive_float_less(void); +void primitive_float_lesseq(void); +void primitive_float_greater(void); +void primitive_float_greatereq(void); + +void primitive_float_bits(void); +void primitive_bits_float(void); +void primitive_double_bits(void); +void primitive_bits_double(void); diff --git a/vmpp/os-freebsd-x86.32.hpp b/vmpp/os-freebsd-x86.32.hpp new file mode 100644 index 0000000000..a04755e9dd --- /dev/null +++ b/vmpp/os-freebsd-x86.32.hpp @@ -0,0 +1,9 @@ +#include + +INLINE void *ucontext_stack_pointer(void *uap) +{ + ucontext_t *ucontext = (ucontext_t *)uap; + return (void *)ucontext->uc_mcontext.mc_esp; +} + +#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)(ucontext))->uc_mcontext.mc_eip) diff --git a/vmpp/os-freebsd-x86.64.hpp b/vmpp/os-freebsd-x86.64.hpp new file mode 100644 index 0000000000..23e1ff5733 --- /dev/null +++ b/vmpp/os-freebsd-x86.64.hpp @@ -0,0 +1,9 @@ +#include + +INLINE void *ucontext_stack_pointer(void *uap) +{ + ucontext_t *ucontext = (ucontext_t *)uap; + return (void *)ucontext->uc_mcontext.mc_rsp; +} + +#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)(ucontext))->uc_mcontext.mc_rip) diff --git a/vmpp/os-freebsd.cpp b/vmpp/os-freebsd.cpp new file mode 100644 index 0000000000..c5bb0a7837 --- /dev/null +++ b/vmpp/os-freebsd.cpp @@ -0,0 +1,34 @@ +#include "master.hpp" + +/* From SBCL */ +const char *vm_executable_path(void) +{ + char path[PATH_MAX + 1]; + + if (getosreldate() >= 600024) + { + /* KERN_PROC_PATHNAME is available */ + size_t len = PATH_MAX + 1; + int mib[4]; + + mib[0] = CTL_KERN; + mib[1] = KERN_PROC; + mib[2] = KERN_PROC_PATHNAME; + mib[3] = -1; + if (sysctl(mib, 4, &path, &len, NULL, 0) != 0) + return NULL; + } + else + { + int size; + size = readlink("/proc/curproc/file", path, sizeof(path) - 1); + if (size < 0) + return NULL; + path[size] = '\0'; + } + + if(strcmp(path, "unknown") == 0) + return NULL; + + return safe_strdup(path); +} diff --git a/vmpp/os-freebsd.hpp b/vmpp/os-freebsd.hpp new file mode 100644 index 0000000000..617a6686c2 --- /dev/null +++ b/vmpp/os-freebsd.hpp @@ -0,0 +1,9 @@ +#include + +extern int getosreldate(void); + +#include + +#ifndef KERN_PROC_PATHNAME +#define KERN_PROC_PATHNAME 12 +#endif diff --git a/vmpp/os-genunix.cpp b/vmpp/os-genunix.cpp new file mode 100755 index 0000000000..6f5087bc6e --- /dev/null +++ b/vmpp/os-genunix.cpp @@ -0,0 +1,35 @@ +#include "master.hpp" + +void c_to_factor_toplevel(CELL quot) +{ + c_to_factor(quot); +} + +void init_signals(void) +{ + unix_init_signals(); +} + +void early_init(void) { } + +#define SUFFIX ".image" +#define SUFFIX_LEN 6 + +const char *default_image_path(void) +{ + const char *path = vm_executable_path(); + + if(!path) + return "factor.image"; + + /* We can't call strlen() here because with gcc 4.1.2 this + causes an internal compiler error. */ + int len = 0; + const char *iter = path; + while(*iter) { len++; iter++; } + + char *new_path = safe_malloc(PATH_MAX + SUFFIX_LEN + 1); + memcpy(new_path,path,len + 1); + memcpy(new_path + len,SUFFIX,SUFFIX_LEN + 1); + return new_path; +} diff --git a/vmpp/os-genunix.hpp b/vmpp/os-genunix.hpp new file mode 100644 index 0000000000..8075e21c5e --- /dev/null +++ b/vmpp/os-genunix.hpp @@ -0,0 +1,8 @@ +#define DLLEXPORT extern "C" +#define NULL_DLL NULL + +void c_to_factor_toplevel(CELL quot); +void init_signals(void); +void early_init(void); +const char *vm_executable_path(void); +const char *default_image_path(void); diff --git a/vmpp/os-linux-arm.cpp b/vmpp/os-linux-arm.cpp new file mode 100644 index 0000000000..d8131f1ffb --- /dev/null +++ b/vmpp/os-linux-arm.cpp @@ -0,0 +1,26 @@ +#include "master.hpp" + +void flush_icache(CELL start, CELL len) +{ + int result; + + /* XXX: why doesn't this work on Nokia n800? It should behave + identically to the below assembly. */ + /* result = syscall(__ARM_NR_cacheflush,start,start + len,0); */ + + /* Assembly swiped from + http://lists.arm.linux.org.uk/pipermail/linux-arm/2002-July/003931.html + */ + __asm__ __volatile__ ( + "mov r0, %1\n" + "sub r1, %2, #1\n" + "mov r2, #0\n" + "swi " __sys1(__ARM_NR_cacheflush) "\n" + "mov %0, r0\n" + : "=r" (result) + : "r" (start), "r" (start + len) + : "r0","r1","r2"); + + if(result < 0) + critical_error("flush_icache() failed",result); +} diff --git a/vmpp/os-linux-arm.hpp b/vmpp/os-linux-arm.hpp new file mode 100644 index 0000000000..6e078b014d --- /dev/null +++ b/vmpp/os-linux-arm.hpp @@ -0,0 +1,14 @@ +#include +#include +#include + +INLINE void *ucontext_stack_pointer(void *uap) +{ + ucontext_t *ucontext = (ucontext_t *)uap; + return (void *)ucontext->uc_mcontext.arm_sp; +} + +#define UAP_PROGRAM_COUNTER(ucontext) \ + (((ucontext_t *)(ucontext))->uc_mcontext.arm_pc) + +void flush_icache(CELL start, CELL len); diff --git a/vmpp/os-linux-ppc.hpp b/vmpp/os-linux-ppc.hpp new file mode 100644 index 0000000000..eb28af53e4 --- /dev/null +++ b/vmpp/os-linux-ppc.hpp @@ -0,0 +1,12 @@ +#include + +#define FRAME_RETURN_ADDRESS(frame) *((XT *)(frame_successor(frame) + 1) + 1) + +INLINE void *ucontext_stack_pointer(void *uap) +{ + ucontext_t *ucontext = (ucontext_t *)uap; + return (void *)ucontext->uc_mcontext.uc_regs->gregs[PT_R1]; +} + +#define UAP_PROGRAM_COUNTER(ucontext) \ + (((ucontext_t *)(ucontext))->uc_mcontext.uc_regs->gregs[PT_NIP]) diff --git a/vmpp/os-linux-x86.32.hpp b/vmpp/os-linux-x86.32.hpp new file mode 100644 index 0000000000..b458fcbe21 --- /dev/null +++ b/vmpp/os-linux-x86.32.hpp @@ -0,0 +1,10 @@ +#include + +INLINE void *ucontext_stack_pointer(void *uap) +{ + ucontext_t *ucontext = (ucontext_t *)uap; + return (void *)ucontext->uc_mcontext.gregs[7]; +} + +#define UAP_PROGRAM_COUNTER(ucontext) \ + (((ucontext_t *)(ucontext))->uc_mcontext.gregs[14]) diff --git a/vmpp/os-linux-x86.64.hpp b/vmpp/os-linux-x86.64.hpp new file mode 100644 index 0000000000..911c2f1749 --- /dev/null +++ b/vmpp/os-linux-x86.64.hpp @@ -0,0 +1,10 @@ +#include + +INLINE void *ucontext_stack_pointer(void *uap) +{ + ucontext_t *ucontext = (ucontext_t *)uap; + return (void *)ucontext->uc_mcontext.gregs[15]; +} + +#define UAP_PROGRAM_COUNTER(ucontext) \ + (((ucontext_t *)(ucontext))->uc_mcontext.gregs[16]) diff --git a/vmpp/os-linux.cpp b/vmpp/os-linux.cpp new file mode 100644 index 0000000000..fcffd75a8e --- /dev/null +++ b/vmpp/os-linux.cpp @@ -0,0 +1,58 @@ +#include "master.hpp" + +/* Snarfed from SBCL linux-so.c. You must free() this yourself. */ +const char *vm_executable_path(void) +{ + char *path = safe_malloc(PATH_MAX + 1); + + int size = readlink("/proc/self/exe", path, PATH_MAX); + if (size < 0) + { + fatal_error("Cannot read /proc/self/exe",0); + return NULL; + } + else + { + path[size] = '\0'; + return safe_strdup(path); + } +} + +#ifdef SYS_inotify_init + +int inotify_init(void) +{ + return syscall(SYS_inotify_init); +} + +int inotify_add_watch(int fd, const char *name, u32 mask) +{ + return syscall(SYS_inotify_add_watch, fd, name, mask); +} + +int inotify_rm_watch(int fd, u32 wd) +{ + return syscall(SYS_inotify_rm_watch, fd, wd); +} + +#else + +int inotify_init(void) +{ + not_implemented_error(); + return -1; +} + +int inotify_add_watch(int fd, const char *name, u32 mask) +{ + not_implemented_error(); + return -1; +} + +int inotify_rm_watch(int fd, u32 wd) +{ + not_implemented_error(); + return -1; +} + +#endif diff --git a/vmpp/os-linux.hpp b/vmpp/os-linux.hpp new file mode 100644 index 0000000000..8e78595687 --- /dev/null +++ b/vmpp/os-linux.hpp @@ -0,0 +1,5 @@ +#include + +int inotify_init(void); +int inotify_add_watch(int fd, const char *name, u32 mask); +int inotify_rm_watch(int fd, u32 wd); diff --git a/vmpp/os-macosx-ppc.hpp b/vmpp/os-macosx-ppc.hpp new file mode 100644 index 0000000000..13213acbbc --- /dev/null +++ b/vmpp/os-macosx-ppc.hpp @@ -0,0 +1,39 @@ +/* Fault handler information. MacOSX version. +Copyright (C) 1993-1999, 2002-2003 Bruno Haible +Copyright (C) 2003 Paolo Bonzini + +Used under BSD license with permission from Paolo Bonzini and Bruno Haible, +2005-03-10: + +http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org + +Modified for Factor by Slava Pestov */ +#include + +#define FRAME_RETURN_ADDRESS(frame) *((XT *)(frame_successor(frame) + 1) + 2) + +#define MACH_EXC_STATE_TYPE ppc_exception_state_t +#define MACH_EXC_STATE_FLAVOR PPC_EXCEPTION_STATE +#define MACH_EXC_STATE_COUNT PPC_EXCEPTION_STATE_COUNT +#define MACH_THREAD_STATE_TYPE ppc_thread_state_t +#define MACH_THREAD_STATE_FLAVOR PPC_THREAD_STATE +#define MACH_THREAD_STATE_COUNT PPC_THREAD_STATE_COUNT + +#if __DARWIN_UNIX03 + #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__dar + #define MACH_STACK_POINTER(thr_state) (thr_state)->__r1 + #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__srr0 + #define UAP_PROGRAM_COUNTER(ucontext) \ + MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->__ss)) +#else + #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->dar + #define MACH_STACK_POINTER(thr_state) (thr_state)->r1 + #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->srr0 + #define UAP_PROGRAM_COUNTER(ucontext) \ + MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss)) +#endif + +INLINE CELL fix_stack_pointer(CELL sp) +{ + return sp; +} diff --git a/vmpp/os-macosx-x86.32.hpp b/vmpp/os-macosx-x86.32.hpp new file mode 100644 index 0000000000..7c830c775d --- /dev/null +++ b/vmpp/os-macosx-x86.32.hpp @@ -0,0 +1,37 @@ +/* Fault handler information. MacOSX version. +Copyright (C) 1993-1999, 2002-2003 Bruno Haible +Copyright (C) 2003 Paolo Bonzini + +Used under BSD license with permission from Paolo Bonzini and Bruno Haible, +2005-03-10: + +http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org + +Modified for Factor by Slava Pestov */ +#include + +#define MACH_EXC_STATE_TYPE i386_exception_state_t +#define MACH_EXC_STATE_FLAVOR i386_EXCEPTION_STATE +#define MACH_EXC_STATE_COUNT i386_EXCEPTION_STATE_COUNT +#define MACH_THREAD_STATE_TYPE i386_thread_state_t +#define MACH_THREAD_STATE_FLAVOR i386_THREAD_STATE +#define MACH_THREAD_STATE_COUNT i386_THREAD_STATE_COUNT + +#if __DARWIN_UNIX03 + #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__faultvaddr + #define MACH_STACK_POINTER(thr_state) (thr_state)->__esp + #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__eip + #define UAP_PROGRAM_COUNTER(ucontext) \ + MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->__ss)) +#else + #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->faultvaddr + #define MACH_STACK_POINTER(thr_state) (thr_state)->esp + #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->eip + #define UAP_PROGRAM_COUNTER(ucontext) \ + MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss)) +#endif + +INLINE CELL fix_stack_pointer(CELL sp) +{ + return ((sp + 4) & ~15) - 4; +} diff --git a/vmpp/os-macosx-x86.64.hpp b/vmpp/os-macosx-x86.64.hpp new file mode 100644 index 0000000000..b11aa80ce8 --- /dev/null +++ b/vmpp/os-macosx-x86.64.hpp @@ -0,0 +1,37 @@ +/* Fault handler information. MacOSX version. +Copyright (C) 1993-1999, 2002-2003 Bruno Haible +Copyright (C) 2003 Paolo Bonzini + +Used under BSD license with permission from Paolo Bonzini and Bruno Haible, +2005-03-10: + +http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org + +Modified for Factor by Slava Pestov and Daniel Ehrenberg */ +#include + +#define MACH_EXC_STATE_TYPE x86_exception_state64_t +#define MACH_EXC_STATE_FLAVOR x86_EXCEPTION_STATE64 +#define MACH_EXC_STATE_COUNT x86_EXCEPTION_STATE64_COUNT +#define MACH_THREAD_STATE_TYPE x86_thread_state64_t +#define MACH_THREAD_STATE_FLAVOR x86_THREAD_STATE64 +#define MACH_THREAD_STATE_COUNT MACHINE_THREAD_STATE_COUNT + +#if __DARWIN_UNIX03 + #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__faultvaddr + #define MACH_STACK_POINTER(thr_state) (thr_state)->__rsp + #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__rip + #define UAP_PROGRAM_COUNTER(ucontext) \ + MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->__ss)) +#else + #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->faultvaddr + #define MACH_STACK_POINTER(thr_state) (thr_state)->rsp + #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->rip + #define UAP_PROGRAM_COUNTER(ucontext) \ + MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss)) +#endif + +INLINE CELL fix_stack_pointer(CELL sp) +{ + return ((sp + 8) & ~15) - 8; +} diff --git a/vmpp/os-macosx.hpp b/vmpp/os-macosx.hpp new file mode 100644 index 0000000000..c77d88adfb --- /dev/null +++ b/vmpp/os-macosx.hpp @@ -0,0 +1,17 @@ +#define DLLEXPORT extern "C" __attribute__((visibility("default"))) +#define FACTOR_OS_STRING "macosx" +#define NULL_DLL "libfactor.dylib" + +void init_signals(void); +void early_init(void); + +const char *vm_executable_path(void); +const char *default_image_path(void); + +DLLEXPORT void c_to_factor_toplevel(CELL quot); + +INLINE void *ucontext_stack_pointer(void *uap) +{ + ucontext_t *ucontext = (ucontext_t *)uap; + return ucontext->uc_stack.ss_sp; +} diff --git a/vmpp/os-macosx.mm b/vmpp/os-macosx.mm new file mode 100644 index 0000000000..e09655ed7c --- /dev/null +++ b/vmpp/os-macosx.mm @@ -0,0 +1,82 @@ +#import + +#include "master.hpp" + +void c_to_factor_toplevel(CELL quot) +{ + for(;;) + { +NS_DURING + c_to_factor(quot); + NS_VOIDRETURN; +NS_HANDLER + dpush(allot_alien(F,(CELL)localException)); + quot = userenv[COCOA_EXCEPTION_ENV]; + if(type_of(quot) != QUOTATION_TYPE) + { + /* No Cocoa exception handler was registered, so + extra/cocoa/ is not loaded. So we pass the exception + along. */ + [localException raise]; + } +NS_ENDHANDLER + } +} + +void early_init(void) +{ + SInt32 version; + Gestalt(gestaltSystemVersion,&version); + if(version <= 0x1050) + { + printf("Factor requires Mac OS X 10.5 or later.\n"); + exit(1); + } + + [[NSAutoreleasePool alloc] init]; +} + +const char *vm_executable_path(void) +{ + return [[[NSBundle mainBundle] executablePath] UTF8String]; +} + +const char *default_image_path(void) +{ + NSBundle *bundle = [NSBundle mainBundle]; + NSString *path = [bundle bundlePath]; + NSString *executable = [[bundle executablePath] lastPathComponent]; + NSString *image = [executable stringByAppendingString:@".image"]; + + NSString *returnVal; + + if([path hasSuffix:@".app"] || [path hasSuffix:@".app/"]) + { + NSFileManager *mgr = [NSFileManager defaultManager]; + + NSString *imageInBundle = [[path stringByAppendingPathComponent:@"Contents/Resources"] stringByAppendingPathComponent:image]; + NSString *imageAlongBundle = [[path stringByDeletingLastPathComponent] stringByAppendingPathComponent:image]; + + returnVal = ([mgr fileExistsAtPath:imageInBundle] + ? imageInBundle : imageAlongBundle); + } + else + returnVal = [path stringByAppendingPathComponent:image]; + + return [returnVal UTF8String]; +} + +void init_signals(void) +{ + unix_init_signals(); + mach_initialize(); +} + +/* Amateurs at Apple: implement this function, properly! */ +Protocol *objc_getProtocol(char *name) +{ + if(strcmp(name,"NSTextInput") == 0) + return @protocol(NSTextInput); + else + return nil; +} diff --git a/vmpp/os-netbsd-x86.32.hpp b/vmpp/os-netbsd-x86.32.hpp new file mode 100644 index 0000000000..ca4a9f88f5 --- /dev/null +++ b/vmpp/os-netbsd-x86.32.hpp @@ -0,0 +1,3 @@ +#include + +#define ucontext_stack_pointer(uap) ((void *)_UC_MACHINE_SP((ucontext_t *)uap)) diff --git a/vmpp/os-netbsd-x86.64.hpp b/vmpp/os-netbsd-x86.64.hpp new file mode 100644 index 0000000000..587dc85ec7 --- /dev/null +++ b/vmpp/os-netbsd-x86.64.hpp @@ -0,0 +1,4 @@ +#include + +#define ucontext_stack_pointer(uap) \ + ((void *)(((ucontext_t *)(uap))->uc_mcontext.__gregs[_REG_URSP])) diff --git a/vmpp/os-netbsd.cpp b/vmpp/os-netbsd.cpp new file mode 100755 index 0000000000..088f6eb9cf --- /dev/null +++ b/vmpp/os-netbsd.cpp @@ -0,0 +1,11 @@ +#include "master.hpp" + +extern int main(); + +const char *vm_executable_path(void) +{ + static Dl_info info = {0}; + if (!info.dli_fname) + dladdr(main, &info); + return info.dli_fname; +} diff --git a/vmpp/os-netbsd.hpp b/vmpp/os-netbsd.hpp new file mode 100644 index 0000000000..6486acda4a --- /dev/null +++ b/vmpp/os-netbsd.hpp @@ -0,0 +1,5 @@ +#include + +#define UAP_PROGRAM_COUNTER(uap) _UC_MACHINE_PC((ucontext_t *)uap) + +#define DIRECTORY_P(file) ((file)->d_type == DT_DIR) diff --git a/vmpp/os-openbsd-x86.32.hpp b/vmpp/os-openbsd-x86.32.hpp new file mode 100644 index 0000000000..0617e62c0d --- /dev/null +++ b/vmpp/os-openbsd-x86.32.hpp @@ -0,0 +1,10 @@ +#include + +INLINE void *openbsd_stack_pointer(void *uap) +{ + struct sigcontext *sc = (struct sigcontext*) uap; + return (void *)sc->sc_esp; +} + +#define ucontext_stack_pointer openbsd_stack_pointer +#define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_eip) diff --git a/vmpp/os-openbsd-x86.64.hpp b/vmpp/os-openbsd-x86.64.hpp new file mode 100644 index 0000000000..3386e80a4b --- /dev/null +++ b/vmpp/os-openbsd-x86.64.hpp @@ -0,0 +1,10 @@ +#include + +INLINE void *openbsd_stack_pointer(void *uap) +{ + struct sigcontext *sc = (struct sigcontext*) uap; + return (void *)sc->sc_rsp; +} + +#define ucontext_stack_pointer openbsd_stack_pointer +#define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_rip) diff --git a/vmpp/os-openbsd.cpp b/vmpp/os-openbsd.cpp new file mode 100644 index 0000000000..855298a810 --- /dev/null +++ b/vmpp/os-openbsd.cpp @@ -0,0 +1,6 @@ +#include "master.hpp" + +const char *vm_executable_path(void) +{ + return NULL; +} diff --git a/vmpp/os-solaris-x86.32.hpp b/vmpp/os-solaris-x86.32.hpp new file mode 100644 index 0000000000..1f4ec74e17 --- /dev/null +++ b/vmpp/os-solaris-x86.32.hpp @@ -0,0 +1,10 @@ +#include + +INLINE void *ucontext_stack_pointer(void *uap) +{ + ucontext_t *ucontext = (ucontext_t *)uap; + return (void *)ucontext->uc_mcontext.gregs[ESP]; +} + +#define UAP_PROGRAM_COUNTER(ucontext) \ + (((ucontext_t *)(ucontext))->uc_mcontext.gregs[EIP]) diff --git a/vmpp/os-solaris-x86.64.hpp b/vmpp/os-solaris-x86.64.hpp new file mode 100644 index 0000000000..54d1866d50 --- /dev/null +++ b/vmpp/os-solaris-x86.64.hpp @@ -0,0 +1,10 @@ +#include + +INLINE void *ucontext_stack_pointer(void *uap) +{ + ucontext_t *ucontext = (ucontext_t *)uap; + return (void *)ucontext->uc_mcontext.gregs[RSP]; +} + +#define UAP_PROGRAM_COUNTER(ucontext) \ + (((ucontext_t *)(ucontext))->uc_mcontext.gregs[RIP]) diff --git a/vmpp/os-solaris.cpp b/vmpp/os-solaris.cpp new file mode 100644 index 0000000000..855298a810 --- /dev/null +++ b/vmpp/os-solaris.cpp @@ -0,0 +1,6 @@ +#include "master.hpp" + +const char *vm_executable_path(void) +{ + return NULL; +} diff --git a/vmpp/os-unix.cpp b/vmpp/os-unix.cpp new file mode 100755 index 0000000000..19fc5cc4a4 --- /dev/null +++ b/vmpp/os-unix.cpp @@ -0,0 +1,315 @@ +#include "master.hpp" + +void start_thread(void *(*start_routine)(void *)) +{ + pthread_attr_t attr; + pthread_t thread; + + if (pthread_attr_init (&attr) != 0) + fatal_error("pthread_attr_init() failed",0); + if (pthread_attr_setdetachstate (&attr, PTHREAD_CREATE_DETACHED) != 0) + fatal_error("pthread_attr_setdetachstate() failed",0); + if (pthread_create (&thread, &attr, start_routine, NULL) != 0) + fatal_error("pthread_create() failed",0); + pthread_attr_destroy (&attr); +} + +static void *null_dll; + +s64 current_micros(void) +{ + struct timeval t; + gettimeofday(&t,NULL); + return (s64)t.tv_sec * 1000000 + t.tv_usec; +} + +void sleep_micros(CELL usec) +{ + usleep(usec); +} + +void init_ffi(void) +{ + /* NULL_DLL is "libfactor.dylib" for OS X and NULL for generic unix */ + null_dll = dlopen(NULL_DLL,RTLD_LAZY); +} + +void ffi_dlopen(F_DLL *dll) +{ + dll->dll = dlopen(alien_offset(dll->path), RTLD_LAZY); +} + +void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol) +{ + void *handle = (dll == NULL ? null_dll : dll->dll); + return dlsym(handle,symbol); +} + +void ffi_dlclose(F_DLL *dll) +{ + if(dlclose(dll->dll)) + { + general_error(ERROR_FFI,tag_object( + from_char_string(dlerror())),F,NULL); + } + dll->dll = NULL; +} + +void primitive_existsp(void) +{ + struct stat sb; + box_boolean(stat(unbox_char_string(),&sb) >= 0); +} + +F_SEGMENT *alloc_segment(CELL size) +{ + int pagesize = getpagesize(); + + char *array = (char *)mmap(NULL,pagesize + size + pagesize, + PROT_READ | PROT_WRITE | PROT_EXEC, + MAP_ANON | MAP_PRIVATE,-1,0); + + if(array == (char*)-1) + out_of_memory(); + + if(mprotect(array,pagesize,PROT_NONE) == -1) + fatal_error("Cannot protect low guard page",(CELL)array); + + if(mprotect(array + pagesize + size,pagesize,PROT_NONE) == -1) + fatal_error("Cannot protect high guard page",(CELL)array); + + F_SEGMENT *retval = (F_SEGMENT *)safe_malloc(sizeof(F_SEGMENT)); + + retval->start = (CELL)(array + pagesize); + retval->size = size; + retval->end = retval->start + size; + + return retval; +} + +void dealloc_segment(F_SEGMENT *block) +{ + int pagesize = getpagesize(); + + int retval = munmap((void*)(block->start - pagesize), + pagesize + block->size + pagesize); + + if(retval) + fatal_error("dealloc_segment failed",0); + + free(block); +} + +INLINE F_STACK_FRAME *uap_stack_pointer(void *uap) +{ + /* There is a race condition here, but in practice a signal + delivered during stack frame setup/teardown or while transitioning + from Factor to C is a sign of things seriously gone wrong, not just + a divide by zero or stack underflow in the listener */ + if(in_code_heap_p(UAP_PROGRAM_COUNTER(uap))) + { + F_STACK_FRAME *ptr = (F_STACK_FRAME *)ucontext_stack_pointer(uap); + if(!ptr) + critical_error("Invalid uap",(CELL)uap); + return ptr; + } + else + return NULL; +} + +void memory_signal_handler(int signal, siginfo_t *siginfo, void *uap) +{ + signal_fault_addr = (CELL)siginfo->si_addr; + signal_callstack_top = uap_stack_pointer(uap); + UAP_PROGRAM_COUNTER(uap) = (CELL)memory_signal_handler_impl; +} + +void misc_signal_handler(int signal, siginfo_t *siginfo, void *uap) +{ + signal_number = signal; + signal_callstack_top = uap_stack_pointer(uap); + UAP_PROGRAM_COUNTER(uap) = (CELL)misc_signal_handler_impl; +} + +static void sigaction_safe(int signum, const struct sigaction *act, struct sigaction *oldact) +{ + int ret; + do + { + ret = sigaction(signum, act, oldact); + } + while(ret == -1 && errno == EINTR); + + if(ret == -1) + fatal_error("sigaction failed", 0); +} + +void unix_init_signals(void) +{ + struct sigaction memory_sigaction; + struct sigaction misc_sigaction; + struct sigaction ignore_sigaction; + + memset(&memory_sigaction,0,sizeof(struct sigaction)); + sigemptyset(&memory_sigaction.sa_mask); + memory_sigaction.sa_sigaction = memory_signal_handler; + memory_sigaction.sa_flags = SA_SIGINFO; + + sigaction_safe(SIGBUS,&memory_sigaction,NULL); + sigaction_safe(SIGSEGV,&memory_sigaction,NULL); + + memset(&misc_sigaction,0,sizeof(struct sigaction)); + sigemptyset(&misc_sigaction.sa_mask); + misc_sigaction.sa_sigaction = misc_signal_handler; + misc_sigaction.sa_flags = SA_SIGINFO; + + sigaction_safe(SIGABRT,&misc_sigaction,NULL); + sigaction_safe(SIGFPE,&misc_sigaction,NULL); + sigaction_safe(SIGQUIT,&misc_sigaction,NULL); + sigaction_safe(SIGILL,&misc_sigaction,NULL); + + memset(&ignore_sigaction,0,sizeof(struct sigaction)); + sigemptyset(&ignore_sigaction.sa_mask); + ignore_sigaction.sa_handler = SIG_IGN; + sigaction_safe(SIGPIPE,&ignore_sigaction,NULL); +} + +/* On Unix, shared fds such as stdin cannot be set to non-blocking mode +(http://homepages.tesco.net/J.deBoynePollard/FGA/dont-set-shared-file-descriptors-to-non-blocking-mode.html) +so we kludge around this by spawning a thread, which waits on a control pipe +for a signal, upon receiving this signal it reads one block of data from stdin +and writes it to a data pipe. Upon completion, it writes a 4-byte integer to +the size pipe, indicating how much data was written to the data pipe. + +The read end of the size pipe can be set to non-blocking. */ +extern "C" { + int stdin_read; + int stdin_write; + + int control_read; + int control_write; + + int size_read; + int size_write; +} + +void safe_close(int fd) +{ + if(close(fd) < 0) + fatal_error("error closing fd",errno); +} + +bool check_write(int fd, void *data, ssize_t size) +{ + if(write(fd,data,size) == size) + return true; + else + { + if(errno == EINTR) + return check_write(fd,data,size); + else + return false; + } +} + +void safe_write(int fd, void *data, ssize_t size) +{ + if(!check_write(fd,data,size)) + fatal_error("error writing fd",errno); +} + +bool safe_read(int fd, void *data, ssize_t size) +{ + ssize_t bytes = read(fd,data,size); + if(bytes < 0) + { + if(errno == EINTR) + return safe_read(fd,data,size); + else + { + fatal_error("error reading fd",errno); + return false; + } + } + else + return (bytes == size); +} + +void *stdin_loop(void *arg) +{ + unsigned char buf[4096]; + bool loop_running = true; + + while(loop_running) + { + if(!safe_read(control_read,buf,1)) + break; + + if(buf[0] != 'X') + fatal_error("stdin_loop: bad data on control fd",buf[0]); + + for(;;) + { + ssize_t bytes = read(0,buf,sizeof(buf)); + if(bytes < 0) + { + if(errno == EINTR) + continue; + else + { + loop_running = false; + break; + } + } + else if(bytes >= 0) + { + safe_write(size_write,&bytes,sizeof(bytes)); + + if(!check_write(stdin_write,buf,bytes)) + loop_running = false; + break; + } + } + } + + safe_close(stdin_write); + safe_close(control_read); + + return NULL; +} + +void open_console(void) +{ + int filedes[2]; + + if(pipe(filedes) < 0) + fatal_error("Error opening control pipe",errno); + + control_read = filedes[0]; + control_write = filedes[1]; + + if(pipe(filedes) < 0) + fatal_error("Error opening size pipe",errno); + + size_read = filedes[0]; + size_write = filedes[1]; + + if(pipe(filedes) < 0) + fatal_error("Error opening stdin pipe",errno); + + stdin_read = filedes[0]; + stdin_write = filedes[1]; + + start_thread(stdin_loop); +} + +DLLEXPORT void wait_for_stdin(void) +{ + if(write(control_write,"X",1) != 1) + { + if(errno == EINTR) + wait_for_stdin(); + else + fatal_error("Error writing control fd",errno); + } +} diff --git a/vmpp/os-unix.hpp b/vmpp/os-unix.hpp new file mode 100755 index 0000000000..35abfee41c --- /dev/null +++ b/vmpp/os-unix.hpp @@ -0,0 +1,59 @@ +#include +#include +#include +#include +#include +#include +#include +#include +#include + +typedef char F_CHAR; +typedef char F_SYMBOL; + +#define from_native_string from_char_string +#define unbox_native_string unbox_char_string +#define string_to_native_alien(string) string_to_char_alien(string,true) +#define unbox_symbol_string unbox_char_string + +#define STRING_LITERAL(string) string + +#define SSCANF sscanf +#define STRCMP strcmp +#define STRNCMP strncmp +#define STRDUP strdup + +#define FSEEK fseeko + +#define FIXNUM_FORMAT "%ld" +#define CELL_FORMAT "%lu" +#define CELL_HEX_FORMAT "%lx" + +#ifdef FACTOR_64 + #define CELL_HEX_PAD_FORMAT "%016lx" +#else + #define CELL_HEX_PAD_FORMAT "%08lx" +#endif + +#define FIXNUM_FORMAT "%ld" + +#define OPEN_READ(path) fopen(path,"rb") +#define OPEN_WRITE(path) fopen(path,"wb") + +#define print_native_string(string) print_string(string) + +void start_thread(void *(*start_routine)(void *)); + +void init_ffi(void); +void ffi_dlopen(F_DLL *dll); +void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol); +void ffi_dlclose(F_DLL *dll); + +void unix_init_signals(void); +void signal_handler(int signal, siginfo_t* siginfo, void* uap); +void dump_stack_signal(int signal, siginfo_t* siginfo, void* uap); + +s64 current_micros(void); +void sleep_micros(CELL usec); + +void open_console(void); diff --git a/vmpp/os-windows-ce.cpp b/vmpp/os-windows-ce.cpp new file mode 100755 index 0000000000..85b24a5732 --- /dev/null +++ b/vmpp/os-windows-ce.cpp @@ -0,0 +1,40 @@ +#include "master.hpp" + +s64 current_micros(void) +{ + SYSTEMTIME st; + FILETIME ft; + GetSystemTime(&st); + SystemTimeToFileTime(&st, &ft); + return (((s64)ft.dwLowDateTime + | (s64)ft.dwHighDateTime<<32) - EPOCH_OFFSET) / 10; +} + +char *strerror(int err) +{ + /* strerror() is not defined on WinCE */ + return "strerror() is not defined on WinCE. Use native I/O."; +} + +void flush_icache(CELL start, CELL end) +{ + FlushInstructionCache(GetCurrentProcess(), 0, 0); +} + +char *getenv(char *name) +{ + not_implemented_error(); + return 0; /* unreachable */ +} + +void primitive_os_envs(void) +{ + not_implemented_error(); +} + +void c_to_factor_toplevel(CELL quot) +{ + c_to_factor(quot); +} + +void open_console(void) { } diff --git a/vmpp/os-windows-ce.hpp b/vmpp/os-windows-ce.hpp new file mode 100755 index 0000000000..a2be5fe475 --- /dev/null +++ b/vmpp/os-windows-ce.hpp @@ -0,0 +1,27 @@ +#ifndef UNICODE +#define UNICODE +#endif + +#include +#include + +typedef wchar_t F_SYMBOL; + +#define unbox_symbol_string unbox_u16_string +#define from_symbol_string from_u16_string + +#define FACTOR_OS_STRING "wince" +#define FACTOR_DLL L"factor-ce.dll" +#define FACTOR_DLL_NAME "factor-ce.dll" + +int errno; +char *strerror(int err); +void flush_icache(CELL start, CELL end); +char *getenv(char *name); + +#define snprintf _snprintf +#define snwprintf _snwprintf + +s64 current_micros(void); +void c_to_factor_toplevel(CELL quot); +void open_console(void); diff --git a/vmpp/os-windows-nt.32.hpp b/vmpp/os-windows-nt.32.hpp new file mode 100644 index 0000000000..9b10671ba0 --- /dev/null +++ b/vmpp/os-windows-nt.32.hpp @@ -0,0 +1,2 @@ +#define ESP Esp +#define EIP Eip diff --git a/vmpp/os-windows-nt.64.hpp b/vmpp/os-windows-nt.64.hpp new file mode 100644 index 0000000000..1f61c2335f --- /dev/null +++ b/vmpp/os-windows-nt.64.hpp @@ -0,0 +1,2 @@ +#define ESP Rsp +#define EIP Rip diff --git a/vmpp/os-windows-nt.cpp b/vmpp/os-windows-nt.cpp new file mode 100755 index 0000000000..2f449e15cf --- /dev/null +++ b/vmpp/os-windows-nt.cpp @@ -0,0 +1,51 @@ +#include "master.hpp" + +s64 current_micros(void) +{ + FILETIME t; + GetSystemTimeAsFileTime(&t); + return (((s64)t.dwLowDateTime | (s64)t.dwHighDateTime<<32) + - EPOCH_OFFSET) / 10; +} + +long exception_handler(PEXCEPTION_POINTERS pe) +{ + PEXCEPTION_RECORD e = (PEXCEPTION_RECORD)pe->ExceptionRecord; + CONTEXT *c = (CONTEXT*)pe->ContextRecord; + + if(in_code_heap_p(c->EIP)) + signal_callstack_top = (void *)c->ESP; + else + signal_callstack_top = NULL; + + if(e->ExceptionCode == EXCEPTION_ACCESS_VIOLATION) + { + signal_fault_addr = e->ExceptionInformation[1]; + c->EIP = (CELL)memory_signal_handler_impl; + } + /* If the Widcomm bluetooth stack is installed, the BTTray.exe process + injects code into running programs. For some reason this results in + random SEH exceptions with this (undocumented) exception code being + raised. The workaround seems to be ignoring this altogether, since that + is what happens if SEH is not enabled. Don't really have any idea what + this exception means. */ + else if(e->ExceptionCode != 0x40010006) + { + signal_number = e->ExceptionCode; + c->EIP = (CELL)misc_signal_handler_impl; + } + + return EXCEPTION_CONTINUE_EXECUTION; +} + +void c_to_factor_toplevel(CELL quot) +{ + if(!AddVectoredExceptionHandler(0, (void*)exception_handler)) + fatal_error("AddVectoredExceptionHandler failed", 0); + c_to_factor(quot); + RemoveVectoredExceptionHandler((void*)exception_handler); +} + +void open_console(void) +{ +} diff --git a/vmpp/os-windows-nt.hpp b/vmpp/os-windows-nt.hpp new file mode 100755 index 0000000000..4e047b497c --- /dev/null +++ b/vmpp/os-windows-nt.hpp @@ -0,0 +1,21 @@ +#undef _WIN32_WINNT +#define _WIN32_WINNT 0x0501 // For AddVectoredExceptionHandler + +#ifndef UNICODE +#define UNICODE +#endif + +#include + +typedef char F_SYMBOL; + +#define unbox_symbol_string unbox_char_string +#define from_symbol_string from_char_string + +#define FACTOR_OS_STRING "winnt" +#define FACTOR_DLL L"factor.dll" +#define FACTOR_DLL_NAME "factor.dll" + +void c_to_factor_toplevel(CELL quot); +long exception_handler(PEXCEPTION_POINTERS pe); +void open_console(void); diff --git a/vmpp/os-windows.cpp b/vmpp/os-windows.cpp new file mode 100755 index 0000000000..e1f5c16647 --- /dev/null +++ b/vmpp/os-windows.cpp @@ -0,0 +1,147 @@ +#include "master.hpp" + +HMODULE hFactorDll; + +void init_ffi(void) +{ + hFactorDll = GetModuleHandle(FACTOR_DLL); + if(!hFactorDll) + fatal_error("GetModuleHandle(\"" FACTOR_DLL_NAME "\") failed", 0); +} + +void ffi_dlopen(F_DLL *dll) +{ + dll->dll = LoadLibraryEx(alien_offset(dll->path), NULL, 0); +} + +void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol) +{ + return GetProcAddress(dll ? (HMODULE)dll->dll : hFactorDll, symbol); +} + +void ffi_dlclose(F_DLL *dll) +{ + FreeLibrary((HMODULE)dll->dll); + dll->dll = NULL; +} + +bool windows_stat(F_CHAR *path) +{ + BY_HANDLE_FILE_INFORMATION bhfi; + HANDLE h = CreateFileW(path, + GENERIC_READ, + FILE_SHARE_READ, + NULL, + OPEN_EXISTING, + FILE_FLAG_BACKUP_SEMANTICS, + NULL); + + if(h == INVALID_HANDLE_VALUE) + { + // FindFirstFile is the only call that can stat c:\pagefile.sys + WIN32_FIND_DATA st; + HANDLE h; + + if(INVALID_HANDLE_VALUE == (h = FindFirstFile(path, &st))) + return false; + FindClose(h); + return true; + } + bool ret; + ret = GetFileInformationByHandle(h, &bhfi); + CloseHandle(h); + return ret; +} + +void windows_image_path(F_CHAR *full_path, F_CHAR *temp_path, unsigned int length) +{ + snwprintf(temp_path, length-1, L"%s.image", full_path); + temp_path[sizeof(temp_path) - 1] = 0; +} + +/* You must free() this yourself. */ +const F_CHAR *default_image_path(void) +{ + F_CHAR full_path[MAX_UNICODE_PATH]; + F_CHAR *ptr; + F_CHAR temp_path[MAX_UNICODE_PATH]; + + if(!GetModuleFileName(NULL, full_path, MAX_UNICODE_PATH)) + fatal_error("GetModuleFileName() failed", 0); + + if((ptr = wcsrchr(full_path, '.'))) + *ptr = 0; + + snwprintf(temp_path, sizeof(temp_path)-1, L"%s.image", full_path); + temp_path[sizeof(temp_path) - 1] = 0; + + return safe_strdup(temp_path); +} + +/* You must free() this yourself. */ +const F_CHAR *vm_executable_path(void) +{ + F_CHAR full_path[MAX_UNICODE_PATH]; + if(!GetModuleFileName(NULL, full_path, MAX_UNICODE_PATH)) + fatal_error("GetModuleFileName() failed", 0); + return safe_strdup(full_path); +} + + +void primitive_existsp(void) +{ + + F_CHAR *path = unbox_u16_string(); + box_boolean(windows_stat(path)); +} + +F_SEGMENT *alloc_segment(CELL size) +{ + char *mem; + DWORD ignore; + + if((mem = (char *)VirtualAlloc(NULL, getpagesize() * 2 + size, + MEM_COMMIT, PAGE_EXECUTE_READWRITE)) == 0) + out_of_memory(); + + if (!VirtualProtect(mem, getpagesize(), PAGE_NOACCESS, &ignore)) + fatal_error("Cannot allocate low guard page", (CELL)mem); + + if (!VirtualProtect(mem + size + getpagesize(), + getpagesize(), PAGE_NOACCESS, &ignore)) + fatal_error("Cannot allocate high guard page", (CELL)mem); + + F_SEGMENT *block = safe_malloc(sizeof(F_SEGMENT)); + + block->start = (CELL)mem + getpagesize(); + block->size = size; + block->end = block->start + size; + + return block; +} + +void dealloc_segment(F_SEGMENT *block) +{ + SYSTEM_INFO si; + GetSystemInfo(&si); + if(!VirtualFree((void*)(block->start - si.dwPageSize), 0, MEM_RELEASE)) + fatal_error("dealloc_segment failed",0); + free(block); +} + +long getpagesize(void) +{ + static long g_pagesize = 0; + if (! g_pagesize) + { + SYSTEM_INFO system_info; + GetSystemInfo (&system_info); + g_pagesize = system_info.dwPageSize; + } + return g_pagesize; +} + +void sleep_micros(u64 usec) +{ + Sleep((DWORD)(usec / 1000)); +} diff --git a/vmpp/os-windows.hpp b/vmpp/os-windows.hpp new file mode 100755 index 0000000000..9e00a6afa7 --- /dev/null +++ b/vmpp/os-windows.hpp @@ -0,0 +1,59 @@ +#include + +#ifndef wcslen + /* for cygwin */ + #include +#endif + +typedef wchar_t F_CHAR; + +#define from_native_string from_u16_string +#define unbox_native_string unbox_u16_string +#define string_to_native_alien(string) string_to_u16_alien(string,true) + +#define STRING_LITERAL(string) L##string + +#define MAX_UNICODE_PATH 32768 +#define DLLEXPORT extern "C" __declspec(dllexport) +#define SSCANF swscanf +#define STRCMP wcscmp +#define STRNCMP wcsncmp +#define STRDUP _wcsdup +#define MIN(a,b) ((a)>(b)?(b):(a)) +#define FSEEK fseek + +#ifdef WIN64 + #define CELL_FORMAT "%Iu" + #define CELL_HEX_FORMAT "%Ix" + #define CELL_HEX_PAD_FORMAT "%016Ix" + #define FIXNUM_FORMAT "%Id" +#else + #define CELL_FORMAT "%lu" + #define CELL_HEX_FORMAT "%lx" + #define CELL_HEX_PAD_FORMAT "%08lx" + #define FIXNUM_FORMAT "%ld" +#endif + +#define OPEN_READ(path) _wfopen(path,L"rb") +#define OPEN_WRITE(path) _wfopen(path,L"wb") + +#define print_native_string(string) wprintf(L"%s",string) + +/* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */ +#define EPOCH_OFFSET 0x019db1ded53e8000LL + +void init_ffi(void); +void ffi_dlopen(F_DLL *dll); +void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol); +void ffi_dlclose(F_DLL *dll); + +void sleep_micros(u64 msec); + +INLINE void init_signals(void) {} +INLINE void early_init(void) {} +const F_CHAR *vm_executable_path(void); +const F_CHAR *default_image_path(void); +long getpagesize (void); + +s64 current_micros(void); + diff --git a/vmpp/platform.hpp b/vmpp/platform.hpp new file mode 100644 index 0000000000..7b4356af56 --- /dev/null +++ b/vmpp/platform.hpp @@ -0,0 +1,122 @@ +#if defined(__arm__) + #define FACTOR_ARM +#elif defined(__amd64__) || defined(__x86_64__) + #define FACTOR_AMD64 +#elif defined(i386) || defined(__i386) || defined(__i386__) || defined(WIN32) + #define FACTOR_X86 +#elif defined(__POWERPC__) || defined(__ppc__) || defined(_ARCH_PPC) + #define FACTOR_PPC +#else + #error "Unsupported architecture" +#endif + +#if defined(WINDOWS) + #if defined(WINCE) + #include "os-windows-ce.hpp" + #else + #include "os-windows-nt.hpp" + #endif + + #include "os-windows.hpp" + #if defined(FACTOR_AMD64) + #include "os-windows-nt.64.hpp" + #elif defined(FACTOR_X86) + #include "os-windows-nt.32.hpp" + #endif +#else + #include "os-unix.hpp" + + #ifdef __APPLE__ + #include "os-macosx.hpp" + #include "mach_signal.hpp" + + #ifdef FACTOR_X86 + #include "os-macosx-x86.32.hpp" + #elif defined(FACTOR_PPC) + #include "os-macosx-ppc.hpp" + #elif defined(FACTOR_AMD64) + #include "os-macosx-x86.64.hpp" + #else + #error "Unsupported Mac OS X flavor" + #endif + #else + #include "os-genunix.hpp" + + #ifdef __FreeBSD__ + #define FACTOR_OS_STRING "freebsd" + #include "os-freebsd.hpp" + + #if defined(FACTOR_X86) + #include "os-freebsd-x86.32.hpp" + #elif defined(FACTOR_AMD64) + #include "os-freebsd-x86.64.hpp" + #else + #error "Unsupported FreeBSD flavor" + #endif + #elif defined(__OpenBSD__) + #define FACTOR_OS_STRING "openbsd" + + #if defined(FACTOR_X86) + #include "os-openbsd-x86.32.hpp" + #elif defined(FACTOR_AMD64) + #include "os-openbsd-x86.64.hpp" + #else + #error "Unsupported OpenBSD flavor" + #endif + #elif defined(__NetBSD__) + #define FACTOR_OS_STRING "netbsd" + + #if defined(FACTOR_X86) + #include "os-netbsd-x86.32.hpp" + #elif defined(FACTOR_AMD64) + #include "os-netbsd-x86.64.hpp" + #else + #error "Unsupported NetBSD flavor" + #endif + + #include "os-netbsd.hpp" + #elif defined(linux) + #define FACTOR_OS_STRING "linux" + #include "os-linux.hpp" + + #if defined(FACTOR_X86) + #include "os-linux-x86.32.hpp" + #elif defined(FACTOR_PPC) + #include "os-linux-ppc.hpp" + #elif defined(FACTOR_ARM) + #include "os-linux-arm.hpp" + #elif defined(FACTOR_AMD64) + #include "os-linux-x86.64.hpp" + #else + #error "Unsupported Linux flavor" + #endif + #elif defined(__SVR4) && defined(sun) + #define FACTOR_OS_STRING "solaris" + + #if defined(FACTOR_X86) + #include "os-solaris-x86.32.hpp" + #elif defined(FACTOR_AMD64) + #include "os-solaris-x86.64.hpp" + #else + #error "Unsupported Solaris flavor" + #endif + + #else + #error "Unsupported OS" + #endif + #endif +#endif + +#if defined(FACTOR_X86) + #include "cpu-x86.32.hpp" + #include "cpu-x86.hpp" +#elif defined(FACTOR_AMD64) + #include "cpu-x86.64.hpp" + #include "cpu-x86.hpp" +#elif defined(FACTOR_PPC) + #include "cpu-ppc.hpp" +#elif defined(FACTOR_ARM) + #include "cpu-arm.hpp" +#else + #error "Unsupported CPU" +#endif diff --git a/vmpp/primitives.cpp b/vmpp/primitives.cpp new file mode 100755 index 0000000000..43c09e719c --- /dev/null +++ b/vmpp/primitives.cpp @@ -0,0 +1,154 @@ +#include "master.hpp" + +F_PRIMITIVE primitives[] = { + primitive_bignum_to_fixnum, + primitive_float_to_fixnum, + primitive_fixnum_to_bignum, + primitive_float_to_bignum, + primitive_fixnum_to_float, + primitive_bignum_to_float, + primitive_str_to_float, + primitive_float_to_str, + primitive_float_bits, + primitive_double_bits, + primitive_bits_float, + primitive_bits_double, + primitive_fixnum_add, + primitive_fixnum_subtract, + primitive_fixnum_multiply, + primitive_fixnum_divint, + primitive_fixnum_divmod, + primitive_fixnum_shift, + primitive_bignum_eq, + primitive_bignum_add, + primitive_bignum_subtract, + primitive_bignum_multiply, + primitive_bignum_divint, + primitive_bignum_mod, + primitive_bignum_divmod, + primitive_bignum_and, + primitive_bignum_or, + primitive_bignum_xor, + primitive_bignum_not, + primitive_bignum_shift, + primitive_bignum_less, + primitive_bignum_lesseq, + primitive_bignum_greater, + primitive_bignum_greatereq, + primitive_bignum_bitp, + primitive_bignum_log2, + primitive_byte_array_to_bignum, + primitive_float_eq, + primitive_float_add, + primitive_float_subtract, + primitive_float_multiply, + primitive_float_divfloat, + primitive_float_mod, + primitive_float_less, + primitive_float_lesseq, + primitive_float_greater, + primitive_float_greatereq, + primitive_word, + primitive_word_xt, + primitive_getenv, + primitive_setenv, + primitive_existsp, + primitive_gc, + primitive_gc_stats, + primitive_save_image, + primitive_save_image_and_exit, + primitive_datastack, + primitive_retainstack, + primitive_callstack, + primitive_set_datastack, + primitive_set_retainstack, + primitive_set_callstack, + primitive_exit, + primitive_data_room, + primitive_code_room, + primitive_micros, + primitive_modify_code_heap, + primitive_dlopen, + primitive_dlsym, + primitive_dlclose, + primitive_byte_array, + primitive_uninitialized_byte_array, + primitive_displaced_alien, + primitive_alien_signed_cell, + primitive_set_alien_signed_cell, + primitive_alien_unsigned_cell, + primitive_set_alien_unsigned_cell, + primitive_alien_signed_8, + primitive_set_alien_signed_8, + primitive_alien_unsigned_8, + primitive_set_alien_unsigned_8, + primitive_alien_signed_4, + primitive_set_alien_signed_4, + primitive_alien_unsigned_4, + primitive_set_alien_unsigned_4, + primitive_alien_signed_2, + primitive_set_alien_signed_2, + primitive_alien_unsigned_2, + primitive_set_alien_unsigned_2, + primitive_alien_signed_1, + primitive_set_alien_signed_1, + primitive_alien_unsigned_1, + primitive_set_alien_unsigned_1, + primitive_alien_float, + primitive_set_alien_float, + primitive_alien_double, + primitive_set_alien_double, + primitive_alien_cell, + primitive_set_alien_cell, + primitive_alien_address, + primitive_set_slot, + primitive_string_nth, + primitive_set_string_nth_fast, + primitive_set_string_nth_slow, + primitive_resize_array, + primitive_resize_string, + primitive_array, + primitive_begin_scan, + primitive_next_object, + primitive_end_scan, + primitive_size, + primitive_die, + primitive_fopen, + primitive_fgetc, + primitive_fread, + primitive_fputc, + primitive_fwrite, + primitive_fflush, + primitive_fseek, + primitive_fclose, + primitive_wrapper, + primitive_clone, + primitive_string, + primitive_array_to_quotation, + primitive_quotation_xt, + primitive_tuple, + primitive_profiling, + primitive_become, + primitive_sleep, + primitive_tuple_boa, + primitive_callstack_to_array, + primitive_innermost_stack_frame_quot, + primitive_innermost_stack_frame_scan, + primitive_set_innermost_stack_frame_quot, + primitive_call_clear, + primitive_resize_byte_array, + primitive_dll_validp, + primitive_unimplemented, + primitive_clear_gc_stats, + primitive_jit_compile, + primitive_load_locals, + primitive_check_datastack, + primitive_inline_cache_miss, + primitive_mega_cache_miss, + primitive_lookup_method, + primitive_reset_dispatch_stats, + primitive_dispatch_stats, + primitive_reset_inline_cache_stats, + primitive_inline_cache_stats, + primitive_optimized_p, +}; diff --git a/vmpp/primitives.hpp b/vmpp/primitives.hpp new file mode 100644 index 0000000000..69157f02c4 --- /dev/null +++ b/vmpp/primitives.hpp @@ -0,0 +1,3 @@ +typedef void (*F_PRIMITIVE)(void); + +extern F_PRIMITIVE primitives[]; diff --git a/vmpp/profiler.cpp b/vmpp/profiler.cpp new file mode 100755 index 0000000000..9a78ae57e7 --- /dev/null +++ b/vmpp/profiler.cpp @@ -0,0 +1,58 @@ +#include "master.hpp" + +bool profiling_p; + +void init_profiler(void) +{ + profiling_p = false; +} + +/* Allocates memory */ +F_CODE_BLOCK *compile_profiling_stub(CELL word) +{ + REGISTER_ROOT(word); + F_JIT jit; + jit_init(&jit,WORD_TYPE,word); + jit_emit_with(&jit,userenv[JIT_PROFILING],word); + F_CODE_BLOCK *block = jit_make_code_block(&jit); + jit_dispose(&jit); + UNREGISTER_ROOT(word); + return block; +} + +/* Allocates memory */ +static void set_profiling(bool profiling) +{ + if(profiling == profiling_p) + return; + + profiling_p = profiling; + + /* Push everything to tenured space so that we can heap scan + and allocate profiling blocks if necessary */ + gc(); + + CELL words = find_all_words(); + + REGISTER_ROOT(words); + + CELL i; + CELL length = array_capacity(untag_array_fast(words)); + for(i = 0; i < length; i++) + { + F_WORD *word = untag_word(array_nth(untag_array(words),i)); + if(profiling) + word->counter = tag_fixnum(0); + update_word_xt(word); + } + + UNREGISTER_ROOT(words); + + /* Update XTs in code heap */ + iterate_code_heap(relocate_code_block); +} + +void primitive_profiling(void) +{ + set_profiling(to_boolean(dpop())); +} diff --git a/vmpp/profiler.hpp b/vmpp/profiler.hpp new file mode 100755 index 0000000000..01ecc83bd2 --- /dev/null +++ b/vmpp/profiler.hpp @@ -0,0 +1,4 @@ +extern bool profiling_p; +void init_profiler(void); +F_CODE_BLOCK *compile_profiling_stub(CELL word); +void primitive_profiling(void); diff --git a/vmpp/quotations.cpp b/vmpp/quotations.cpp new file mode 100755 index 0000000000..8747e4ea3f --- /dev/null +++ b/vmpp/quotations.cpp @@ -0,0 +1,374 @@ +#include "master.hpp" + +/* Simple non-optimizing compiler. + +This is one of the two compilers implementing Factor; the second one is written +in Factor and performs advanced optimizations. See core/compiler/compiler.factor. + +The non-optimizing compiler compiles a quotation at a time by concatenating +machine code chunks; prolog, epilog, call word, jump to word, etc. These machine +code chunks are generated from Factor code in core/cpu/.../bootstrap.factor. + +Calls to words and constant quotations (referenced by conditionals and dips) +are direct jumps to machine code blocks. Literals are also referenced directly +without going through the literal table. + +It actually does do a little bit of very simple optimization: + +1) Tail call optimization. + +2) If a quotation is determined to not call any other words (except for a few +special words which are open-coded, see below), then no prolog/epilog is +generated. + +3) When in tail position and immediately preceded by literal arguments, the +'if' is generated inline, instead of as a call to the 'if' word. + +4) When preceded by a quotation, calls to 'dip', '2dip' and '3dip' are +open-coded as retain stack manipulation surrounding a subroutine call. + +5) Sub-primitives are primitive words which are implemented in assembly and not +in the VM. They are open-coded and no subroutine call is generated. This +includes stack shufflers, some fixnum arithmetic words, and words such as tag, +slot and eq?. A primitive call is relatively expensive (two subroutine calls) +so this results in a big speedup for relatively little effort. */ + +static bool jit_primitive_call_p(F_ARRAY *array, CELL i) +{ + return (i + 2) == array_capacity(array) + && type_of(array_nth(array,i)) == FIXNUM_TYPE + && array_nth(array,i + 1) == userenv[JIT_PRIMITIVE_WORD]; +} + +static bool jit_fast_if_p(F_ARRAY *array, CELL i) +{ + return (i + 3) == array_capacity(array) + && type_of(array_nth(array,i)) == QUOTATION_TYPE + && type_of(array_nth(array,i + 1)) == QUOTATION_TYPE + && array_nth(array,i + 2) == userenv[JIT_IF_WORD]; +} + +static bool jit_fast_dip_p(F_ARRAY *array, CELL i) +{ + return (i + 2) <= array_capacity(array) + && type_of(array_nth(array,i)) == QUOTATION_TYPE + && array_nth(array,i + 1) == userenv[JIT_DIP_WORD]; +} + +static bool jit_fast_2dip_p(F_ARRAY *array, CELL i) +{ + return (i + 2) <= array_capacity(array) + && type_of(array_nth(array,i)) == QUOTATION_TYPE + && array_nth(array,i + 1) == userenv[JIT_2DIP_WORD]; +} + +static bool jit_fast_3dip_p(F_ARRAY *array, CELL i) +{ + return (i + 2) <= array_capacity(array) + && type_of(array_nth(array,i)) == QUOTATION_TYPE + && array_nth(array,i + 1) == userenv[JIT_3DIP_WORD]; +} + +static bool jit_mega_lookup_p(F_ARRAY *array, CELL i) +{ + return (i + 3) < array_capacity(array) + && type_of(array_nth(array,i)) == ARRAY_TYPE + && type_of(array_nth(array,i + 1)) == FIXNUM_TYPE + && type_of(array_nth(array,i + 2)) == ARRAY_TYPE + && array_nth(array,i + 3) == userenv[MEGA_LOOKUP_WORD]; +} + +static bool jit_stack_frame_p(F_ARRAY *array) +{ + F_FIXNUM length = array_capacity(array); + F_FIXNUM i; + + for(i = 0; i < length - 1; i++) + { + CELL obj = array_nth(array,i); + if(type_of(obj) == WORD_TYPE) + { + F_WORD *word = untag_word_fast(obj); + if(word->subprimitive == F) + return true; + } + else if(type_of(obj) == QUOTATION_TYPE) + { + if(jit_fast_dip_p(array,i) + || jit_fast_2dip_p(array,i) + || jit_fast_3dip_p(array,i)) + return true; + } + } + + return false; +} + +#define TAIL_CALL { \ + if(stack_frame) jit_emit(jit,userenv[JIT_EPILOG]); \ + tail_call = true; \ + } + +/* Allocates memory */ +static void jit_iterate_quotation(F_JIT *jit, CELL array, CELL compiling, CELL relocate) +{ + REGISTER_ROOT(array); + + bool stack_frame = jit_stack_frame_p(untag_array_fast(array)); + + jit_set_position(jit,0); + + if(stack_frame) + jit_emit(jit,userenv[JIT_PROLOG]); + + CELL i; + CELL length = array_capacity(untag_array_fast(array)); + bool tail_call = false; + + for(i = 0; i < length; i++) + { + jit_set_position(jit,i); + + CELL obj = array_nth(untag_array_fast(array),i); + REGISTER_ROOT(obj); + + F_WORD *word; + F_WRAPPER *wrapper; + + switch(type_of(obj)) + { + case WORD_TYPE: + word = untag_word_fast(obj); + + /* Intrinsics */ + if(word->subprimitive != F) + jit_emit_subprimitive(jit,obj); + /* The (execute) primitive is special-cased */ + else if(obj == userenv[JIT_EXECUTE_WORD]) + { + if(i == length - 1) + { + TAIL_CALL; + jit_emit(jit,userenv[JIT_EXECUTE_JUMP]); + } + else + jit_emit(jit,userenv[JIT_EXECUTE_CALL]); + } + /* Everything else */ + else + { + if(i == length - 1) + { + TAIL_CALL; + jit_word_jump(jit,obj); + } + else + jit_word_call(jit,obj); + } + break; + case WRAPPER_TYPE: + wrapper = untag_wrapper_fast(obj); + jit_push(jit,wrapper->object); + break; + case FIXNUM_TYPE: + /* Primitive calls */ + if(jit_primitive_call_p(untag_array_fast(array),i)) + { + jit_emit(jit,userenv[JIT_SAVE_STACK]); + jit_emit_with(jit,userenv[JIT_PRIMITIVE],obj); + + i++; + + tail_call = true; + break; + } + case QUOTATION_TYPE: + /* 'if' preceeded by two literal quotations (this is why if and ? are + mutually recursive in the library, but both still work) */ + if(jit_fast_if_p(untag_array_fast(array),i)) + { + TAIL_CALL; + + if(compiling) + { + jit_compile(array_nth(untag_array_fast(array),i),relocate); + jit_compile(array_nth(untag_array_fast(array),i + 1),relocate); + } + + jit_emit_with(jit,userenv[JIT_IF_1],array_nth(untag_array_fast(array),i)); + jit_emit_with(jit,userenv[JIT_IF_2],array_nth(untag_array_fast(array),i + 1)); + + i += 2; + + break; + } + /* dip */ + else if(jit_fast_dip_p(untag_array_fast(array),i)) + { + if(compiling) + jit_compile(obj,relocate); + jit_emit_with(jit,userenv[JIT_DIP],obj); + i++; + break; + } + /* 2dip */ + else if(jit_fast_2dip_p(untag_array_fast(array),i)) + { + if(compiling) + jit_compile(obj,relocate); + jit_emit_with(jit,userenv[JIT_2DIP],obj); + i++; + break; + } + /* 3dip */ + else if(jit_fast_3dip_p(untag_array_fast(array),i)) + { + if(compiling) + jit_compile(obj,relocate); + jit_emit_with(jit,userenv[JIT_3DIP],obj); + i++; + break; + } + case ARRAY_TYPE: + /* Method dispatch */ + if(jit_mega_lookup_p(untag_array_fast(array),i)) + { + jit_emit_mega_cache_lookup(jit, + array_nth(untag_array_fast(array),i), + untag_fixnum_fast(array_nth(untag_array_fast(array),i + 1)), + array_nth(untag_array_fast(array),i + 2)); + i += 3; + tail_call = true; + break; + } + default: + jit_push(jit,obj); + break; + } + + UNREGISTER_ROOT(obj); + } + + if(!tail_call) + { + jit_set_position(jit,length); + + if(stack_frame) + jit_emit(jit,userenv[JIT_EPILOG]); + jit_emit(jit,userenv[JIT_RETURN]); + } + + UNREGISTER_ROOT(array); +} + +void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code) +{ + if(code->block.type != QUOTATION_TYPE) + critical_error("Bad param to set_quot_xt",(CELL)code); + + quot->code = code; + quot->xt = (XT)(code + 1); + quot->compiledp = T; +} + +/* Allocates memory */ +void jit_compile(CELL quot, bool relocate) +{ + if(untag_quotation(quot)->compiledp != F) + return; + + CELL array = untag_quotation(quot)->array; + + REGISTER_ROOT(quot); + REGISTER_ROOT(array); + + F_JIT jit; + jit_init(&jit,QUOTATION_TYPE,quot); + + jit_iterate_quotation(&jit,array,true,relocate); + + F_CODE_BLOCK *compiled = jit_make_code_block(&jit); + + set_quot_xt(untag_quotation_fast(quot),compiled); + + if(relocate) relocate_code_block(compiled); + + jit_dispose(&jit); + + UNREGISTER_ROOT(array); + UNREGISTER_ROOT(quot); +} + +F_FIXNUM quot_code_offset_to_scan(CELL quot, CELL offset) +{ + CELL array = untag_quotation(quot)->array; + REGISTER_ROOT(array); + + F_JIT jit; + jit_init(&jit,QUOTATION_TYPE,quot); + jit_compute_position(&jit,offset); + jit_iterate_quotation(&jit,array,false,false); + jit_dispose(&jit); + + UNREGISTER_ROOT(array); + + return jit_get_position(&jit); +} + +F_FASTCALL CELL lazy_jit_compile_impl(CELL quot, F_STACK_FRAME *stack) +{ + stack_chain->callstack_top = stack; + REGISTER_ROOT(quot); + jit_compile(quot,true); + UNREGISTER_ROOT(quot); + return quot; +} + +void primitive_jit_compile(void) +{ + jit_compile(dpop(),true); +} + +/* push a new quotation on the stack */ +void primitive_array_to_quotation(void) +{ + F_QUOTATION *quot = (F_QUOTATION *)allot_object(QUOTATION_TYPE,sizeof(F_QUOTATION)); + quot->array = dpeek(); + quot->xt = (void *)lazy_jit_compile; + quot->compiledp = F; + quot->cached_effect = F; + quot->cache_counter = F; + drepl(tag_quotation(quot)); +} + +void primitive_quotation_xt(void) +{ + F_QUOTATION *quot = untag_quotation(dpeek()); + drepl(allot_cell((CELL)quot->xt)); +} + +void compile_all_words(void) +{ + CELL words = find_all_words(); + + REGISTER_ROOT(words); + + CELL i; + CELL length = array_capacity(untag_array(words)); + for(i = 0; i < length; i++) + { + F_WORD *word = untag_word(array_nth(untag_array(words),i)); + REGISTER_UNTAGGED(word); + + if(!word->code || !word_optimized_p(word)) + jit_compile_word(word,word->def,false); + + UNREGISTER_UNTAGGED(F_WORD,word); + update_word_xt(word); + + } + + UNREGISTER_ROOT(words); + + iterate_code_heap(relocate_code_block); +} diff --git a/vmpp/quotations.hpp b/vmpp/quotations.hpp new file mode 100755 index 0000000000..f3dc9920de --- /dev/null +++ b/vmpp/quotations.hpp @@ -0,0 +1,16 @@ +DEFINE_UNTAG(F_QUOTATION,QUOTATION_TYPE,quotation) + +INLINE CELL tag_quotation(F_QUOTATION *quotation) +{ + return RETAG(quotation,QUOTATION_TYPE); +} + +void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code); +void jit_compile(CELL quot, bool relocate); +F_FIXNUM quot_code_offset_to_scan(CELL quot, CELL offset); +void primitive_array_to_quotation(void); +void primitive_quotation_xt(void); +void primitive_jit_compile(void); +void compile_all_words(void); + +F_FASTCALL CELL lazy_jit_compile_impl(CELL quot, F_STACK_FRAME *stack); diff --git a/vmpp/run.cpp b/vmpp/run.cpp new file mode 100755 index 0000000000..bb14ea94f3 --- /dev/null +++ b/vmpp/run.cpp @@ -0,0 +1,254 @@ +#include "master.hpp" + +CELL userenv[USER_ENV]; +CELL T; +F_CONTEXT *stack_chain; +CELL ds_size, rs_size; +F_CONTEXT *unused_contexts; + +void reset_datastack(void) +{ + ds = ds_bot - CELLS; +} + +void reset_retainstack(void) +{ + rs = rs_bot - CELLS; +} + +#define RESERVED (64 * CELLS) + +void fix_stacks(void) +{ + if(ds + CELLS < ds_bot || ds + RESERVED >= ds_top) reset_datastack(); + if(rs + CELLS < rs_bot || rs + RESERVED >= rs_top) reset_retainstack(); +} + +/* called before entry into foreign C code. Note that ds and rs might +be stored in registers, so callbacks must save and restore the correct values */ +void save_stacks(void) +{ + if(stack_chain) + { + stack_chain->datastack = ds; + stack_chain->retainstack = rs; + } +} + +F_CONTEXT *alloc_context(void) +{ + F_CONTEXT *context; + + if(unused_contexts) + { + context = unused_contexts; + unused_contexts = unused_contexts->next; + } + else + { + context = (F_CONTEXT *)safe_malloc(sizeof(F_CONTEXT)); + context->datastack_region = alloc_segment(ds_size); + context->retainstack_region = alloc_segment(rs_size); + } + + return context; +} + +void dealloc_context(F_CONTEXT *context) +{ + context->next = unused_contexts; + unused_contexts = context; +} + +/* called on entry into a compiled callback */ +void nest_stacks(void) +{ + F_CONTEXT *new_stacks = alloc_context(); + + new_stacks->callstack_bottom = (F_STACK_FRAME *)-1; + new_stacks->callstack_top = (F_STACK_FRAME *)-1; + + /* note that these register values are not necessarily valid stack + pointers. they are merely saved non-volatile registers, and are + restored in unnest_stacks(). consider this scenario: + - factor code calls C function + - C function saves ds/cs registers (since they're non-volatile) + - C function clobbers them + - C function calls Factor callback + - Factor callback returns + - C function restores registers + - C function returns to Factor code */ + new_stacks->datastack_save = ds; + new_stacks->retainstack_save = rs; + + /* save per-callback userenv */ + new_stacks->current_callback_save = userenv[CURRENT_CALLBACK_ENV]; + new_stacks->catchstack_save = userenv[CATCHSTACK_ENV]; + + new_stacks->next = stack_chain; + stack_chain = new_stacks; + + reset_datastack(); + reset_retainstack(); +} + +/* called when leaving a compiled callback */ +void unnest_stacks(void) +{ + ds = stack_chain->datastack_save; + rs = stack_chain->retainstack_save; + + /* restore per-callback userenv */ + userenv[CURRENT_CALLBACK_ENV] = stack_chain->current_callback_save; + userenv[CATCHSTACK_ENV] = stack_chain->catchstack_save; + + F_CONTEXT *old_stacks = stack_chain; + stack_chain = old_stacks->next; + dealloc_context(old_stacks); +} + +/* called on startup */ +void init_stacks(CELL ds_size_, CELL rs_size_) +{ + ds_size = ds_size_; + rs_size = rs_size_; + stack_chain = NULL; + unused_contexts = NULL; +} + +bool stack_to_array(CELL bottom, CELL top) +{ + F_FIXNUM depth = (F_FIXNUM)(top - bottom + CELLS); + + if(depth < 0) + return false; + else + { + F_ARRAY *a = allot_array_internal(ARRAY_TYPE,depth / CELLS); + memcpy(a + 1,(void*)bottom,depth); + dpush(tag_array(a)); + return true; + } +} + +void primitive_datastack(void) +{ + if(!stack_to_array(ds_bot,ds)) + general_error(ERROR_DS_UNDERFLOW,F,F,NULL); +} + +void primitive_retainstack(void) +{ + if(!stack_to_array(rs_bot,rs)) + general_error(ERROR_RS_UNDERFLOW,F,F,NULL); +} + +/* returns pointer to top of stack */ +CELL array_to_stack(F_ARRAY *array, CELL bottom) +{ + CELL depth = array_capacity(array) * CELLS; + memcpy((void*)bottom,array + 1,depth); + return bottom + depth - CELLS; +} + +void primitive_set_datastack(void) +{ + ds = array_to_stack(untag_array(dpop()),ds_bot); +} + +void primitive_set_retainstack(void) +{ + rs = array_to_stack(untag_array(dpop()),rs_bot); +} + +/* Used to implement call( */ +void primitive_check_datastack(void) +{ + F_FIXNUM out = to_fixnum(dpop()); + F_FIXNUM in = to_fixnum(dpop()); + F_FIXNUM height = out - in; + F_ARRAY *array = untag_array(dpop()); + F_FIXNUM length = array_capacity(array); + F_FIXNUM depth = (ds - ds_bot + CELLS) / CELLS; + if(depth - height != length) + dpush(F); + else + { + F_FIXNUM i; + for(i = 0; i < length - in; i++) + { + if(get(ds_bot + i * CELLS) != array_nth(array,i)) + { + dpush(F); + return; + } + } + dpush(T); + } +} + +void primitive_getenv(void) +{ + F_FIXNUM e = untag_fixnum_fast(dpeek()); + drepl(userenv[e]); +} + +void primitive_setenv(void) +{ + F_FIXNUM e = untag_fixnum_fast(dpop()); + CELL value = dpop(); + userenv[e] = value; +} + +void primitive_exit(void) +{ + exit(to_fixnum(dpop())); +} + +void primitive_micros(void) +{ + box_unsigned_8(current_micros()); +} + +void primitive_sleep(void) +{ + sleep_micros(to_cell(dpop())); +} + +void primitive_set_slot(void) +{ + F_FIXNUM slot = untag_fixnum_fast(dpop()); + CELL obj = dpop(); + CELL value = dpop(); + set_slot(obj,slot,value); +} + +void primitive_load_locals(void) +{ + F_FIXNUM count = untag_fixnum_fast(dpop()); + memcpy((CELL *)(rs + CELLS),(CELL *)(ds - CELLS * (count - 1)),CELLS * count); + ds -= CELLS * count; + rs += CELLS * count; +} + +static CELL clone_object(CELL object) +{ + CELL size = object_size(object); + if(size == 0) + return object; + else + { + REGISTER_ROOT(object); + void *new_obj = allot_object(type_of(object),size); + UNREGISTER_ROOT(object); + + CELL tag = TAG(object); + memcpy(new_obj,(void*)UNTAG(object),size); + return RETAG(new_obj,tag); + } +} + +void primitive_clone(void) +{ + drepl(clone_object(dpeek())); +} diff --git a/vmpp/run.hpp b/vmpp/run.hpp new file mode 100755 index 0000000000..d3bec859ef --- /dev/null +++ b/vmpp/run.hpp @@ -0,0 +1,273 @@ +#define USER_ENV 70 + +typedef enum { + NAMESTACK_ENV, /* used by library only */ + CATCHSTACK_ENV, /* used by library only, per-callback */ + + CURRENT_CALLBACK_ENV = 2, /* used by library only, per-callback */ + WALKER_HOOK_ENV, /* non-local exit hook, used by library only */ + CALLCC_1_ENV, /* used to pass the value in callcc1 */ + + BREAK_ENV = 5, /* quotation called by throw primitive */ + ERROR_ENV, /* a marker consed onto kernel errors */ + + CELL_SIZE_ENV = 7, /* sizeof(CELL) */ + CPU_ENV, /* CPU architecture */ + OS_ENV, /* operating system name */ + + ARGS_ENV = 10, /* command line arguments */ + STDIN_ENV, /* stdin FILE* handle */ + STDOUT_ENV, /* stdout FILE* handle */ + + IMAGE_ENV = 13, /* image path name */ + EXECUTABLE_ENV, /* runtime executable path name */ + + EMBEDDED_ENV = 15, /* are we embedded in another app? */ + EVAL_CALLBACK_ENV, /* used when Factor is embedded in a C app */ + YIELD_CALLBACK_ENV, /* used when Factor is embedded in a C app */ + SLEEP_CALLBACK_ENV, /* used when Factor is embedded in a C app */ + + COCOA_EXCEPTION_ENV = 19, /* Cocoa exception handler quotation */ + + BOOT_ENV = 20, /* boot quotation */ + GLOBAL_ENV, /* global namespace */ + + /* Quotation compilation in quotations.c */ + JIT_PROLOG = 23, + JIT_PRIMITIVE_WORD, + JIT_PRIMITIVE, + JIT_WORD_JUMP, + JIT_WORD_CALL, + JIT_IF_WORD, + JIT_IF_1, + JIT_IF_2, + JIT_EPILOG = 33, + JIT_RETURN, + JIT_PROFILING, + JIT_PUSH_IMMEDIATE, + JIT_SAVE_STACK = 38, + JIT_DIP_WORD, + JIT_DIP, + JIT_2DIP_WORD, + JIT_2DIP, + JIT_3DIP_WORD, + JIT_3DIP, + JIT_EXECUTE_WORD, + JIT_EXECUTE_JUMP, + JIT_EXECUTE_CALL, + + /* Polymorphic inline cache generation in inline_cache.c */ + PIC_LOAD = 48, + PIC_TAG, + PIC_HI_TAG, + PIC_TUPLE, + PIC_HI_TAG_TUPLE, + PIC_CHECK_TAG, + PIC_CHECK, + PIC_HIT, + PIC_MISS_WORD, + + /* Megamorphic cache generation in dispatch.c */ + MEGA_LOOKUP = 57, + MEGA_LOOKUP_WORD, + MEGA_MISS_WORD, + + UNDEFINED_ENV = 60, /* default quotation for undefined words */ + + STDERR_ENV = 61, /* stderr FILE* handle */ + + STAGE2_ENV = 62, /* have we bootstrapped? */ + + CURRENT_THREAD_ENV = 63, + + THREADS_ENV = 64, + RUN_QUEUE_ENV = 65, + SLEEP_QUEUE_ENV = 66, + + STACK_TRACES_ENV = 67, +} F_ENVTYPE; + +#define FIRST_SAVE_ENV BOOT_ENV +#define LAST_SAVE_ENV STAGE2_ENV + +/* TAGGED user environment data; see getenv/setenv prims */ +extern CELL userenv[USER_ENV]; + +/* macros for reading/writing memory, useful when working around +C's type system */ +INLINE CELL get(CELL where) +{ + return *((CELL*)where); +} + +INLINE void put(CELL where, CELL what) +{ + *((CELL*)where) = what; +} + +INLINE CELL cget(CELL where) +{ + return *((u16 *)where); +} + +INLINE void cput(CELL where, CELL what) +{ + *((u16 *)where) = what; +} + +INLINE CELL bget(CELL where) +{ + return *((u8 *)where); +} + +INLINE void bput(CELL where, CELL what) +{ + *((u8 *)where) = what; +} + +INLINE CELL align(CELL a, CELL b) +{ + return (a + (b-1)) & ~(b-1); +} + +#define align8(a) align(a,8) +#define align_page(a) align(a,getpagesize()) + +/* Canonical T object. It's just a word */ +extern CELL T; + +INLINE CELL tag_header(CELL cell) +{ + return cell << TAG_BITS; +} + +INLINE void check_header(CELL cell) +{ +#ifdef FACTOR_DEBUG + assert(TAG(cell) == FIXNUM_TYPE && untag_fixnum_fast(cell) < TYPE_COUNT); +#endif +} + +INLINE CELL untag_header(CELL cell) +{ + check_header(cell); + return cell >> TAG_BITS; +} + +INLINE CELL hi_tag(CELL tagged) +{ + return untag_header(get(UNTAG(tagged))); +} + +INLINE CELL tag_object(void *cell) +{ +#ifdef FACTOR_DEBUG + assert(hi_tag((CELL)cell) >= HEADER_TYPE); +#endif + return RETAG(cell,OBJECT_TYPE); +} + +INLINE CELL type_of(CELL tagged) +{ + CELL tag = TAG(tagged); + if(tag == OBJECT_TYPE) + return hi_tag(tagged); + else + return tag; +} + +#define DEFPUSHPOP(prefix,ptr) \ + INLINE CELL prefix##pop(void) \ + { \ + CELL value = get(ptr); \ + ptr -= CELLS; \ + return value; \ + } \ + INLINE void prefix##push(CELL tagged) \ + { \ + ptr += CELLS; \ + put(ptr,tagged); \ + } \ + INLINE void prefix##repl(CELL tagged) \ + { \ + put(ptr,tagged); \ + } \ + INLINE CELL prefix##peek() \ + { \ + return get(ptr); \ + } + +DEFPUSHPOP(d,ds) +DEFPUSHPOP(r,rs) + +typedef struct { + CELL start; + CELL size; + CELL end; +} F_SEGMENT; + +/* Assembly code makes assumptions about the layout of this struct: + - callstack_top field is 0 + - callstack_bottom field is 1 + - datastack field is 2 + - retainstack field is 3 */ +typedef struct _F_CONTEXT { + /* C stack pointer on entry */ + F_STACK_FRAME *callstack_top; + F_STACK_FRAME *callstack_bottom; + + /* current datastack top pointer */ + CELL datastack; + + /* current retain stack top pointer */ + CELL retainstack; + + /* saved contents of ds register on entry to callback */ + CELL datastack_save; + + /* saved contents of rs register on entry to callback */ + CELL retainstack_save; + + /* memory region holding current datastack */ + F_SEGMENT *datastack_region; + + /* memory region holding current retain stack */ + F_SEGMENT *retainstack_region; + + /* saved userenv slots on entry to callback */ + CELL catchstack_save; + CELL current_callback_save; + + struct _F_CONTEXT *next; +} F_CONTEXT; + +extern F_CONTEXT *stack_chain; + +extern CELL ds_size, rs_size; + +#define ds_bot (stack_chain->datastack_region->start) +#define ds_top (stack_chain->datastack_region->end) +#define rs_bot (stack_chain->retainstack_region->start) +#define rs_top (stack_chain->retainstack_region->end) + +void reset_datastack(void); +void reset_retainstack(void); +void fix_stacks(void); +DLLEXPORT void save_stacks(void); +DLLEXPORT void nest_stacks(void); +DLLEXPORT void unnest_stacks(void); +void init_stacks(CELL ds_size, CELL rs_size); + +void primitive_datastack(void); +void primitive_retainstack(void); +void primitive_set_datastack(void); +void primitive_set_retainstack(void); +void primitive_check_datastack(void); +void primitive_getenv(void); +void primitive_setenv(void); +void primitive_exit(void); +void primitive_micros(void); +void primitive_sleep(void); +void primitive_set_slot(void); +void primitive_load_locals(void); +void primitive_clone(void); diff --git a/vmpp/strings.cpp b/vmpp/strings.cpp new file mode 100644 index 0000000000..7864484c54 --- /dev/null +++ b/vmpp/strings.cpp @@ -0,0 +1,294 @@ +#include "master.hpp" + +CELL string_nth(F_STRING* string, CELL index) +{ + /* If high bit is set, the most significant 16 bits of the char + come from the aux vector. The least significant bit of the + corresponding aux vector entry is negated, so that we can + XOR the two components together and get the original code point + back. */ + CELL ch = bget(SREF(string,index)); + if((ch & 0x80) == 0) + return ch; + else + { + F_BYTE_ARRAY *aux = untag_byte_array_fast(string->aux); + return (cget(BREF(aux,index * sizeof(u16))) << 7) ^ ch; + } +} + +void set_string_nth_fast(F_STRING* string, CELL index, CELL ch) +{ + bput(SREF(string,index),ch); +} + +void set_string_nth_slow(F_STRING* string, CELL index, CELL ch) +{ + F_BYTE_ARRAY *aux; + + bput(SREF(string,index),(ch & 0x7f) | 0x80); + + if(string->aux == F) + { + REGISTER_UNTAGGED(string); + /* We don't need to pre-initialize the + byte array with any data, since we + only ever read from the aux vector + if the most significant bit of a + character is set. Initially all of + the bits are clear. */ + aux = allot_byte_array_internal( + untag_fixnum_fast(string->length) + * sizeof(u16)); + UNREGISTER_UNTAGGED(F_STRING,string); + + write_barrier((CELL)string); + string->aux = tag_object(aux); + } + else + aux = untag_byte_array_fast(string->aux); + + cput(BREF(aux,index * sizeof(u16)),(ch >> 7) ^ 1); +} + +/* allocates memory */ +void set_string_nth(F_STRING* string, CELL index, CELL ch) +{ + if(ch <= 0x7f) + set_string_nth_fast(string,index,ch); + else + set_string_nth_slow(string,index,ch); +} + +/* untagged */ +F_STRING* allot_string_internal(CELL capacity) +{ + F_STRING *string = (F_STRING *)allot_object(STRING_TYPE,string_size(capacity)); + + string->length = tag_fixnum(capacity); + string->hashcode = F; + string->aux = F; + + return string; +} + +/* allocates memory */ +void fill_string(F_STRING *string, CELL start, CELL capacity, CELL fill) +{ + if(fill <= 0x7f) + memset((void *)SREF(string,start),fill,capacity - start); + else + { + CELL i; + + for(i = start; i < capacity; i++) + { + REGISTER_UNTAGGED(string); + set_string_nth(string,i,fill); + UNREGISTER_UNTAGGED(F_STRING,string); + } + } +} + +/* untagged */ +F_STRING *allot_string(CELL capacity, CELL fill) +{ + F_STRING* string = allot_string_internal(capacity); + REGISTER_UNTAGGED(string); + fill_string(string,0,capacity,fill); + UNREGISTER_UNTAGGED(F_STRING,string); + return string; +} + +void primitive_string(void) +{ + CELL initial = to_cell(dpop()); + CELL length = unbox_array_size(); + dpush(tag_object(allot_string(length,initial))); +} + +static bool reallot_string_in_place_p(F_STRING *string, CELL capacity) +{ + return in_zone(&nursery,(CELL)string) && capacity <= string_capacity(string); +} + +F_STRING* reallot_string(F_STRING* string, CELL capacity) +{ + if(reallot_string_in_place_p(string,capacity)) + { + string->length = tag_fixnum(capacity); + + if(string->aux != F) + { + F_BYTE_ARRAY *aux = untag_byte_array_fast(string->aux); + aux->capacity = tag_fixnum(capacity * 2); + } + + return string; + } + else + { + CELL to_copy = string_capacity(string); + if(capacity < to_copy) + to_copy = capacity; + + REGISTER_UNTAGGED(string); + F_STRING *new_string = allot_string_internal(capacity); + UNREGISTER_UNTAGGED(F_STRING,string); + + memcpy(new_string + 1,string + 1,to_copy); + + if(string->aux != F) + { + REGISTER_UNTAGGED(string); + REGISTER_UNTAGGED(new_string); + F_BYTE_ARRAY *new_aux = allot_byte_array(capacity * sizeof(u16)); + UNREGISTER_UNTAGGED(F_STRING,new_string); + UNREGISTER_UNTAGGED(F_STRING,string); + + write_barrier((CELL)new_string); + new_string->aux = tag_object(new_aux); + + F_BYTE_ARRAY *aux = untag_byte_array_fast(string->aux); + memcpy(new_aux + 1,aux + 1,to_copy * sizeof(u16)); + } + + REGISTER_UNTAGGED(string); + REGISTER_UNTAGGED(new_string); + fill_string(new_string,to_copy,capacity,'\0'); + UNREGISTER_UNTAGGED(F_STRING,new_string); + UNREGISTER_UNTAGGED(F_STRING,string); + + return new_string; + } +} + +void primitive_resize_string(void) +{ + F_STRING* string = untag_string(dpop()); + CELL capacity = unbox_array_size(); + dpush(tag_object(reallot_string(string,capacity))); +} + +/* Some ugly macros to prevent a 2x code duplication */ + +#define MEMORY_TO_STRING(type,utype) \ + F_STRING *memory_to_##type##_string(const type *string, CELL length) \ + { \ + REGISTER_C_STRING(string); \ + F_STRING *s = allot_string_internal(length); \ + UNREGISTER_C_STRING(type,string); \ + CELL i; \ + for(i = 0; i < length; i++) \ + { \ + REGISTER_UNTAGGED(s); \ + set_string_nth(s,i,(utype)*string); \ + UNREGISTER_UNTAGGED(F_STRING,s); \ + string++; \ + } \ + return s; \ + } \ + F_STRING *from_##type##_string(const type *str) \ + { \ + CELL length = 0; \ + const type *scan = str; \ + while(*scan++) length++; \ + return memory_to_##type##_string(str,length); \ + } \ + void box_##type##_string(const type *str) \ + { \ + dpush(str ? tag_object(from_##type##_string(str)) : F); \ + } + +MEMORY_TO_STRING(char,u8) +MEMORY_TO_STRING(u16,u16) +MEMORY_TO_STRING(u32,u32) + +bool check_string(F_STRING *s, CELL max) +{ + CELL capacity = string_capacity(s); + CELL i; + for(i = 0; i < capacity; i++) + { + CELL ch = string_nth(s,i); + if(ch == 0 || ch >= ((CELL)1 << (max * 8))) + return false; + } + return true; +} + +F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size) +{ + return allot_byte_array((capacity + 1) * size); +} + +#define STRING_TO_MEMORY(type) \ + void type##_string_to_memory(F_STRING *s, type *string) \ + { \ + CELL i; \ + CELL capacity = string_capacity(s); \ + for(i = 0; i < capacity; i++) \ + string[i] = string_nth(s,i); \ + } \ + void primitive_##type##_string_to_memory(void) \ + { \ + type *address = (type *)unbox_alien(); \ + F_STRING *str = untag_string(dpop()); \ + type##_string_to_memory(str,address); \ + } \ + F_BYTE_ARRAY *string_to_##type##_alien(F_STRING *s, bool check) \ + { \ + CELL capacity = string_capacity(s); \ + F_BYTE_ARRAY *_c_str; \ + if(check && !check_string(s,sizeof(type))) \ + general_error(ERROR_C_STRING,tag_object(s),F,NULL); \ + REGISTER_UNTAGGED(s); \ + _c_str = allot_c_string(capacity,sizeof(type)); \ + UNREGISTER_UNTAGGED(F_STRING,s); \ + type *c_str = (type*)(_c_str + 1); \ + type##_string_to_memory(s,c_str); \ + c_str[capacity] = 0; \ + return _c_str; \ + } \ + type *to_##type##_string(F_STRING *s, bool check) \ + { \ + return (type*)(string_to_##type##_alien(s,check) + 1); \ + } \ + type *unbox_##type##_string(void) \ + { \ + return to_##type##_string(untag_string(dpop()),true); \ + } + +STRING_TO_MEMORY(char); +STRING_TO_MEMORY(u16); + +void primitive_string_nth(void) +{ + F_STRING *string = untag_string_fast(dpop()); + CELL index = untag_fixnum_fast(dpop()); + dpush(tag_fixnum(string_nth(string,index))); +} + +void primitive_set_string_nth(void) +{ + F_STRING *string = untag_string_fast(dpop()); + CELL index = untag_fixnum_fast(dpop()); + CELL value = untag_fixnum_fast(dpop()); + set_string_nth(string,index,value); +} + +void primitive_set_string_nth_fast(void) +{ + F_STRING *string = untag_string_fast(dpop()); + CELL index = untag_fixnum_fast(dpop()); + CELL value = untag_fixnum_fast(dpop()); + set_string_nth_fast(string,index,value); +} + +void primitive_set_string_nth_slow(void) +{ + F_STRING *string = untag_string_fast(dpop()); + CELL index = untag_fixnum_fast(dpop()); + CELL value = untag_fixnum_fast(dpop()); + set_string_nth_slow(string,index,value); +} diff --git a/vmpp/strings.hpp b/vmpp/strings.hpp new file mode 100644 index 0000000000..3248df3625 --- /dev/null +++ b/vmpp/strings.hpp @@ -0,0 +1,46 @@ +INLINE CELL string_capacity(F_STRING *str) +{ + return untag_fixnum_fast(str->length); +} + +INLINE CELL string_size(CELL size) +{ + return sizeof(F_STRING) + size; +} + +#define BREF(byte_array,index) ((CELL)byte_array + sizeof(F_BYTE_ARRAY) + (index)) +#define SREF(string,index) ((CELL)string + sizeof(F_STRING) + (index)) + +DEFINE_UNTAG(F_STRING,STRING_TYPE,string) + +F_STRING* allot_string_internal(CELL capacity); +F_STRING* allot_string(CELL capacity, CELL fill); +void primitive_string(void); +F_STRING *reallot_string(F_STRING *string, CELL capacity); +void primitive_resize_string(void); + +F_STRING *memory_to_char_string(const char *string, CELL length); +F_STRING *from_char_string(const char *c_string); +DLLEXPORT void box_char_string(const char *c_string); + +F_STRING *memory_to_u16_string(const u16 *string, CELL length); +F_STRING *from_u16_string(const u16 *c_string); +DLLEXPORT void box_u16_string(const u16 *c_string); + +void char_string_to_memory(F_STRING *s, char *string); +F_BYTE_ARRAY *string_to_char_alien(F_STRING *s, bool check); +char* to_char_string(F_STRING *s, bool check); +DLLEXPORT char *unbox_char_string(void); + +void u16_string_to_memory(F_STRING *s, u16 *string); +F_BYTE_ARRAY *string_to_u16_alien(F_STRING *s, bool check); +u16* to_u16_string(F_STRING *s, bool check); +DLLEXPORT u16 *unbox_u16_string(void); + +/* String getters and setters */ +CELL string_nth(F_STRING* string, CELL index); +void set_string_nth(F_STRING* string, CELL index, CELL value); + +void primitive_string_nth(void); +void primitive_set_string_nth_slow(void); +void primitive_set_string_nth_fast(void); diff --git a/vmpp/tuples.cpp b/vmpp/tuples.cpp new file mode 100644 index 0000000000..27a8cf21d9 --- /dev/null +++ b/vmpp/tuples.cpp @@ -0,0 +1,35 @@ +#include "master.hpp" + +/* push a new tuple on the stack */ +F_TUPLE *allot_tuple(F_TUPLE_LAYOUT *layout) +{ + REGISTER_UNTAGGED(layout); + F_TUPLE *tuple = (F_TUPLE *)allot_object(TUPLE_TYPE,tuple_size(layout)); + UNREGISTER_UNTAGGED(F_TUPLE_LAYOUT,layout); + tuple->layout = tag_array((F_ARRAY *)layout); + return tuple; +} + +void primitive_tuple(void) +{ + F_TUPLE_LAYOUT *layout = untag_tuple_layout(dpop()); + F_FIXNUM size = untag_fixnum_fast(layout->size); + + F_TUPLE *tuple = allot_tuple(layout); + F_FIXNUM i; + for(i = size - 1; i >= 0; i--) + put(AREF(tuple,i),F); + + dpush(tag_tuple(tuple)); +} + +/* push a new tuple on the stack, filling its slots from the stack */ +void primitive_tuple_boa(void) +{ + F_TUPLE_LAYOUT *layout = untag_tuple_layout(dpop()); + F_FIXNUM size = untag_fixnum_fast(layout->size); + F_TUPLE *tuple = allot_tuple(layout); + memcpy(tuple + 1,(CELL *)(ds - CELLS * (size - 1)),CELLS * size); + ds -= CELLS * size; + dpush(tag_tuple(tuple)); +} diff --git a/vmpp/tuples.hpp b/vmpp/tuples.hpp new file mode 100644 index 0000000000..832be71b04 --- /dev/null +++ b/vmpp/tuples.hpp @@ -0,0 +1,32 @@ +INLINE CELL tag_tuple(F_TUPLE *tuple) +{ + return RETAG(tuple,TUPLE_TYPE); +} + +INLINE CELL tuple_size(F_TUPLE_LAYOUT *layout) +{ + CELL size = untag_fixnum_fast(layout->size); + return sizeof(F_TUPLE) + size * CELLS; +} + +DEFINE_UNTAG(F_TUPLE,TUPLE_TYPE,tuple) + +INLINE F_TUPLE_LAYOUT *untag_tuple_layout(CELL obj) +{ + return (F_TUPLE_LAYOUT *)UNTAG(obj); +} + +INLINE CELL tuple_nth(F_TUPLE *tuple, CELL slot) +{ + return get(AREF(tuple,slot)); +} + +INLINE void set_tuple_nth(F_TUPLE *tuple, CELL slot, CELL value) +{ + put(AREF(tuple,slot),value); + write_barrier((CELL)tuple); +} + +void primitive_tuple(void); +void primitive_tuple_boa(void); +void primitive_tuple_layout(void); diff --git a/vmpp/utilities.cpp b/vmpp/utilities.cpp new file mode 100755 index 0000000000..b567c4d0a9 --- /dev/null +++ b/vmpp/utilities.cpp @@ -0,0 +1,55 @@ +#include "master.hpp" + +/* If memory allocation fails, bail out */ +void *safe_malloc(size_t size) +{ + void *ptr = malloc(size); + if(!ptr) fatal_error("Out of memory in safe_malloc", 0); + return ptr; +} + +F_CHAR *safe_strdup(const F_CHAR *str) +{ + F_CHAR *ptr = STRDUP(str); + if(!ptr) fatal_error("Out of memory in safe_strdup", 0); + return ptr; +} + +/* We don't use printf directly, because format directives are not portable. +Instead we define the common cases here. */ +void nl(void) +{ + fputs("\n",stdout); +} + +void print_string(const char *str) +{ + fputs(str,stdout); +} + +void print_cell(CELL x) +{ + printf(CELL_FORMAT,x); +} + +void print_cell_hex(CELL x) +{ + printf(CELL_HEX_FORMAT,x); +} + +void print_cell_hex_pad(CELL x) +{ + printf(CELL_HEX_PAD_FORMAT,x); +} + +void print_fixnum(F_FIXNUM x) +{ + printf(FIXNUM_FORMAT,x); +} + +CELL read_cell_hex(void) +{ + CELL cell; + if(scanf(CELL_HEX_FORMAT,&cell) < 0) exit(1); + return cell; +}; diff --git a/vmpp/utilities.hpp b/vmpp/utilities.hpp new file mode 100755 index 0000000000..d2b3223ce4 --- /dev/null +++ b/vmpp/utilities.hpp @@ -0,0 +1,10 @@ +void *safe_malloc(size_t size); +F_CHAR *safe_strdup(const F_CHAR *str); + +void nl(void); +void print_string(const char *str); +void print_cell(CELL x); +void print_cell_hex(CELL x); +void print_cell_hex_pad(CELL x); +void print_fixnum(F_FIXNUM x); +CELL read_cell_hex(void); diff --git a/vmpp/words.cpp b/vmpp/words.cpp new file mode 100644 index 0000000000..ed13671bab --- /dev/null +++ b/vmpp/words.cpp @@ -0,0 +1,82 @@ +#include "master.hpp" + +F_WORD *allot_word(CELL vocab, CELL name) +{ + REGISTER_ROOT(vocab); + REGISTER_ROOT(name); + F_WORD *word = (F_WORD *)allot_object(WORD_TYPE,sizeof(F_WORD)); + UNREGISTER_ROOT(name); + UNREGISTER_ROOT(vocab); + + word->hashcode = tag_fixnum((rand() << 16) ^ rand()); + word->vocabulary = vocab; + word->name = name; + word->def = userenv[UNDEFINED_ENV]; + word->props = F; + word->counter = tag_fixnum(0); + word->direct_entry_def = F; + word->subprimitive = F; + word->profiling = NULL; + word->code = NULL; + + REGISTER_UNTAGGED(word); + jit_compile_word(word,word->def,true); + UNREGISTER_UNTAGGED(F_WORD,word); + + REGISTER_UNTAGGED(word); + update_word_xt(word); + UNREGISTER_UNTAGGED(F_WORD,word); + + if(profiling_p) + relocate_code_block(word->profiling); + + return word; +} + +/* ( name vocabulary -- word ) */ +void primitive_word(void) +{ + CELL vocab = dpop(); + CELL name = dpop(); + dpush(tag_object(allot_word(vocab,name))); +} + +/* word-xt ( word -- start end ) */ +void primitive_word_xt(void) +{ + F_WORD *word = untag_word(dpop()); + F_CODE_BLOCK *code = (profiling_p ? word->profiling : word->code); + dpush(allot_cell((CELL)code + sizeof(F_CODE_BLOCK))); + dpush(allot_cell((CELL)code + code->block.size)); +} + +/* Allocates memory */ +void update_word_xt(F_WORD *word) +{ + if(profiling_p) + { + if(!word->profiling) + { + REGISTER_UNTAGGED(word); + F_CODE_BLOCK *profiling = compile_profiling_stub(tag_object(word)); + UNREGISTER_UNTAGGED(F_WORD,word); + word->profiling = profiling; + } + + word->xt = (XT)(word->profiling + 1); + } + else + word->xt = (XT)(word->code + 1); +} + +void primitive_optimized_p(void) +{ + drepl(tag_boolean(word_optimized_p(untag_word(dpeek())))); +} + +void primitive_wrapper(void) +{ + F_WRAPPER *wrapper = (F_WRAPPER *)allot_object(WRAPPER_TYPE,sizeof(F_WRAPPER)); + wrapper->object = dpeek(); + drepl(tag_object(wrapper)); +} diff --git a/vmpp/words.hpp b/vmpp/words.hpp new file mode 100644 index 0000000000..cbc0d3c0d0 --- /dev/null +++ b/vmpp/words.hpp @@ -0,0 +1,18 @@ +DEFINE_UNTAG(F_WORD,WORD_TYPE,word) + +F_WORD *allot_word(CELL vocab, CELL name); + +void primitive_word(void); +void primitive_word_xt(void); +void update_word_xt(F_WORD *word); + +INLINE bool word_optimized_p(F_WORD *word) +{ + return word->code->block.type == WORD_TYPE; +} + +void primitive_optimized_p(void); + +DEFINE_UNTAG(F_WRAPPER,WRAPPER_TYPE,wrapper) + +void primitive_wrapper(void); diff --git a/vmpp/write_barrier.cpp b/vmpp/write_barrier.cpp new file mode 100644 index 0000000000..a97caff69e --- /dev/null +++ b/vmpp/write_barrier.cpp @@ -0,0 +1,5 @@ +#include "master.hpp" + +CELL cards_offset; +CELL decks_offset; +CELL allot_markers_offset; diff --git a/vmpp/write_barrier.hpp b/vmpp/write_barrier.hpp new file mode 100644 index 0000000000..fbd5fa8b82 --- /dev/null +++ b/vmpp/write_barrier.hpp @@ -0,0 +1,66 @@ +/* card marking write barrier. a card is a byte storing a mark flag, +and the offset (in cells) of the first object in the card. + +the mark flag is set by the write barrier when an object in the +card has a slot written to. + +the offset of the first object is set by the allocator. */ + +/* if CARD_POINTS_TO_NURSERY is set, CARD_POINTS_TO_AGING must also be set. */ +#define CARD_POINTS_TO_NURSERY 0x80 +#define CARD_POINTS_TO_AGING 0x40 +#define CARD_MARK_MASK (CARD_POINTS_TO_NURSERY | CARD_POINTS_TO_AGING) +typedef u8 F_CARD; + +#define CARD_BITS 8 +#define CARD_SIZE (1<> CARD_BITS) + cards_offset) +#define CARD_TO_ADDR(c) (CELL*)(((CELL)(c) - cards_offset)<> DECK_BITS) + decks_offset) +#define DECK_TO_ADDR(c) (CELL*)(((CELL)(c) - decks_offset) << DECK_BITS) + +#define DECK_TO_CARD(d) (F_CARD*)((((CELL)(d) - decks_offset) << (DECK_BITS - CARD_BITS)) + cards_offset) + +#define ADDR_TO_ALLOT_MARKER(a) (F_CARD*)(((CELL)(a) >> CARD_BITS) + allot_markers_offset) +#define CARD_OFFSET(c) (*((c) - (CELL)data_heap->cards + (CELL)data_heap->allot_markers)) + +#define INVALID_ALLOT_MARKER 0xff + +extern "C" CELL allot_markers_offset; + +/* the write barrier must be called any time we are potentially storing a +pointer from an older generation to a younger one */ +INLINE void write_barrier(CELL address) +{ + *ADDR_TO_CARD(address) = CARD_MARK_MASK; + *ADDR_TO_DECK(address) = CARD_MARK_MASK; +} + +#define SLOT(obj,slot) (UNTAG(obj) + (slot) * CELLS) + +INLINE void set_slot(CELL obj, CELL slot, CELL value) +{ + put(SLOT(obj,slot),value); + write_barrier(obj); +} + +/* we need to remember the first object allocated in the card */ +INLINE void allot_barrier(CELL address) +{ + F_CARD *ptr = ADDR_TO_ALLOT_MARKER(address); + if(*ptr == INVALID_ALLOT_MARKER) + *ptr = (address & ADDR_CARD_MASK); +} From b8b44911a75392835d75df2b800fa2aa6081120e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 2 May 2009 04:43:58 -0500 Subject: [PATCH 02/44] Clean up VM's array code --- vmpp/arrays.cpp | 55 +-------- vmpp/arrays.hpp | 17 +-- vmpp/bignum.cpp | 245 ++++++++++++++++++++-------------------- vmpp/bignum.hpp | 123 ++++++++++---------- vmpp/bignumint.hpp | 2 +- vmpp/byte_arrays.cpp | 53 +-------- vmpp/byte_arrays.hpp | 18 +-- vmpp/callstack.cpp | 2 +- vmpp/code_block.cpp | 2 +- vmpp/data_heap.cpp | 8 +- vmpp/factor.cpp | 2 +- vmpp/generic_arrays.hpp | 82 ++++++++++++++ vmpp/layouts.hpp | 3 + vmpp/master.hpp | 2 +- vmpp/math.cpp | 24 ++-- vmpp/math.hpp | 6 +- vmpp/run.cpp | 2 +- vmpp/strings.cpp | 2 +- vmpp/tagged.hpp | 32 ++++++ 19 files changed, 346 insertions(+), 334 deletions(-) create mode 100644 vmpp/generic_arrays.hpp create mode 100644 vmpp/tagged.hpp diff --git a/vmpp/arrays.cpp b/vmpp/arrays.cpp index 0bddf04f97..3203da2c99 100644 --- a/vmpp/arrays.cpp +++ b/vmpp/arrays.cpp @@ -1,19 +1,10 @@ #include "master.hpp" -/* the array is full of undefined data, and must be correctly filled before the -next GC. size is in cells */ -F_ARRAY *allot_array_internal(CELL type, CELL capacity) -{ - F_ARRAY *array = (F_ARRAY *)allot_object(type,array_size(capacity)); - array->capacity = tag_fixnum(capacity); - return array; -} - /* make a new array with an initial element */ -F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill) +F_ARRAY *allot_array(CELL capacity, CELL fill) { REGISTER_ROOT(fill); - F_ARRAY* array = allot_array_internal(type, capacity); + F_ARRAY* array = allot_array_internal(capacity); UNREGISTER_ROOT(fill); if(fill == 0) memset((void*)AREF(array,0),'\0',capacity * CELLS); @@ -34,13 +25,13 @@ void primitive_array(void) { CELL initial = dpop(); CELL size = unbox_array_size(); - dpush(tag_array(allot_array(ARRAY_TYPE,size,initial))); + dpush(tag_array(allot_array(size,initial))); } CELL allot_array_1(CELL obj) { REGISTER_ROOT(obj); - F_ARRAY *a = allot_array_internal(ARRAY_TYPE,1); + F_ARRAY *a = allot_array_internal(1); UNREGISTER_ROOT(obj); set_array_nth(a,0,obj); return tag_array(a); @@ -50,7 +41,7 @@ CELL allot_array_2(CELL v1, CELL v2) { REGISTER_ROOT(v1); REGISTER_ROOT(v2); - F_ARRAY *a = allot_array_internal(ARRAY_TYPE,2); + F_ARRAY *a = allot_array_internal(2); UNREGISTER_ROOT(v2); UNREGISTER_ROOT(v1); set_array_nth(a,0,v1); @@ -64,7 +55,7 @@ CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4) REGISTER_ROOT(v2); REGISTER_ROOT(v3); REGISTER_ROOT(v4); - F_ARRAY *a = allot_array_internal(ARRAY_TYPE,4); + F_ARRAY *a = allot_array_internal(4); UNREGISTER_ROOT(v4); UNREGISTER_ROOT(v3); UNREGISTER_ROOT(v2); @@ -76,40 +67,6 @@ CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4) return tag_array(a); } -static bool reallot_array_in_place_p(F_ARRAY *array, CELL capacity) -{ - return in_zone(&nursery,(CELL)array) && capacity <= array_capacity(array); -} - -F_ARRAY *reallot_array(F_ARRAY *array, CELL capacity) -{ -#ifdef FACTOR_DEBUG - CELL header = untag_header(array->header); - assert(header == ARRAY_TYPE || header == BIGNUM_TYPE); -#endif - - if(reallot_array_in_place_p(array,capacity)) - { - array->capacity = tag_fixnum(capacity); - return array; - } - else - { - CELL to_copy = array_capacity(array); - if(capacity < to_copy) - to_copy = capacity; - - REGISTER_UNTAGGED(array); - F_ARRAY* new_array = allot_array_internal(untag_header(array->header),capacity); - UNREGISTER_UNTAGGED(F_ARRAY,array); - - memcpy(new_array + 1,array + 1,to_copy * CELLS); - memset((char *)AREF(new_array,to_copy),'\0',(capacity - to_copy) * CELLS); - - return new_array; - } -} - void primitive_resize_array(void) { F_ARRAY* array = untag_array(dpop()); diff --git a/vmpp/arrays.hpp b/vmpp/arrays.hpp index 6fe8a5464c..15caf3c56f 100644 --- a/vmpp/arrays.hpp +++ b/vmpp/arrays.hpp @@ -5,14 +5,7 @@ INLINE CELL tag_array(F_ARRAY *array) return RETAG(array,ARRAY_TYPE); } -/* Inline functions */ -INLINE CELL array_size(CELL size) -{ - return sizeof(F_ARRAY) + size * CELLS; -} - -F_ARRAY *allot_array_internal(CELL type, CELL capacity); -F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill); +F_ARRAY *allot_array(CELL capacity, CELL fill); F_BYTE_ARRAY *allot_byte_array(CELL size); CELL allot_array_1(CELL obj); @@ -20,22 +13,20 @@ CELL allot_array_2(CELL v1, CELL v2); CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4); void primitive_array(void); - -F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity); void primitive_resize_array(void); /* Macros to simulate a vector in C */ -typedef struct { +struct F_GROWABLE_ARRAY { CELL count; CELL array; -} F_GROWABLE_ARRAY; +}; /* Allocates memory */ INLINE F_GROWABLE_ARRAY make_growable_array(void) { F_GROWABLE_ARRAY result; result.count = 0; - result.array = tag_array(allot_array(ARRAY_TYPE,2,F)); + result.array = tag_array(allot_array(2,F)); return result; } diff --git a/vmpp/bignum.cpp b/vmpp/bignum.cpp index b431b6be88..e8920a5ac6 100755 --- a/vmpp/bignum.cpp +++ b/vmpp/bignum.cpp @@ -46,6 +46,7 @@ MIT in each case. */ * - Add local variable GC root recording * - Remove s48 prefix from function names * - Various fixes for Win64 + * - Port to C++ */ #include "master.hpp" @@ -58,7 +59,7 @@ MIT in each case. */ /* Exports */ int -bignum_equal_p(bignum_type x, bignum_type y) +bignum_equal_p(F_BIGNUM * x, F_BIGNUM * y) { return ((BIGNUM_ZERO_P (x)) @@ -71,7 +72,7 @@ bignum_equal_p(bignum_type x, bignum_type y) } enum bignum_comparison -bignum_compare(bignum_type x, bignum_type y) +bignum_compare(F_BIGNUM * x, F_BIGNUM * y) { return ((BIGNUM_ZERO_P (x)) @@ -94,8 +95,8 @@ bignum_compare(bignum_type x, bignum_type y) } /* allocates memory */ -bignum_type -bignum_add(bignum_type x, bignum_type y) +F_BIGNUM * +bignum_add(F_BIGNUM * x, F_BIGNUM * y) { return ((BIGNUM_ZERO_P (x)) @@ -112,8 +113,8 @@ bignum_add(bignum_type x, bignum_type y) } /* allocates memory */ -bignum_type -bignum_subtract(bignum_type x, bignum_type y) +F_BIGNUM * +bignum_subtract(F_BIGNUM * x, F_BIGNUM * y) { return ((BIGNUM_ZERO_P (x)) @@ -132,8 +133,8 @@ bignum_subtract(bignum_type x, bignum_type y) } /* allocates memory */ -bignum_type -bignum_multiply(bignum_type x, bignum_type y) +F_BIGNUM * +bignum_multiply(F_BIGNUM * x, F_BIGNUM * y) { bignum_length_type x_length = (BIGNUM_LENGTH (x)); bignum_length_type y_length = (BIGNUM_LENGTH (y)); @@ -166,8 +167,8 @@ bignum_multiply(bignum_type x, bignum_type y) /* allocates memory */ void -bignum_divide(bignum_type numerator, bignum_type denominator, - bignum_type * quotient, bignum_type * remainder) +bignum_divide(F_BIGNUM * numerator, F_BIGNUM * denominator, + F_BIGNUM * * quotient, F_BIGNUM * * remainder) { if (BIGNUM_ZERO_P (denominator)) { @@ -238,8 +239,8 @@ bignum_divide(bignum_type numerator, bignum_type denominator, } /* allocates memory */ -bignum_type -bignum_quotient(bignum_type numerator, bignum_type denominator) +F_BIGNUM * +bignum_quotient(F_BIGNUM * numerator, F_BIGNUM * denominator) { if (BIGNUM_ZERO_P (denominator)) { @@ -262,7 +263,7 @@ bignum_quotient(bignum_type numerator, bignum_type denominator) case bignum_comparison_greater: default: /* to appease gcc -Wall */ { - bignum_type quotient; + F_BIGNUM * quotient; if ((BIGNUM_LENGTH (denominator)) == 1) { bignum_digit_type digit = (BIGNUM_REF (denominator, 0)); @@ -271,18 +272,18 @@ bignum_quotient(bignum_type numerator, bignum_type denominator) if (digit < BIGNUM_RADIX_ROOT) bignum_divide_unsigned_small_denominator (numerator, digit, - ("ient), ((bignum_type *) 0), + ("ient), ((F_BIGNUM * *) 0), q_negative_p, 0); else bignum_divide_unsigned_medium_denominator (numerator, digit, - ("ient), ((bignum_type *) 0), + ("ient), ((F_BIGNUM * *) 0), q_negative_p, 0); } else bignum_divide_unsigned_large_denominator (numerator, denominator, - ("ient), ((bignum_type *) 0), + ("ient), ((F_BIGNUM * *) 0), q_negative_p, 0); return (quotient); } @@ -291,8 +292,8 @@ bignum_quotient(bignum_type numerator, bignum_type denominator) } /* allocates memory */ -bignum_type -bignum_remainder(bignum_type numerator, bignum_type denominator) +F_BIGNUM * +bignum_remainder(F_BIGNUM * numerator, F_BIGNUM * denominator) { if (BIGNUM_ZERO_P (denominator)) { @@ -310,7 +311,7 @@ bignum_remainder(bignum_type numerator, bignum_type denominator) case bignum_comparison_greater: default: /* to appease gcc -Wall */ { - bignum_type remainder; + F_BIGNUM * remainder; if ((BIGNUM_LENGTH (denominator)) == 1) { bignum_digit_type digit = (BIGNUM_REF (denominator, 0)); @@ -322,13 +323,13 @@ bignum_remainder(bignum_type numerator, bignum_type denominator) (numerator, digit, (BIGNUM_NEGATIVE_P (numerator)))); bignum_divide_unsigned_medium_denominator (numerator, digit, - ((bignum_type *) 0), (&remainder), + ((F_BIGNUM * *) 0), (&remainder), 0, (BIGNUM_NEGATIVE_P (numerator))); } else bignum_divide_unsigned_large_denominator (numerator, denominator, - ((bignum_type *) 0), (&remainder), + ((F_BIGNUM * *) 0), (&remainder), 0, (BIGNUM_NEGATIVE_P (numerator))); return (remainder); } @@ -336,7 +337,7 @@ bignum_remainder(bignum_type numerator, bignum_type denominator) } #define FOO_TO_BIGNUM(name,type,utype) \ - bignum_type name##_to_bignum(type n) \ + F_BIGNUM * name##_to_bignum(type n) \ { \ int negative_p; \ bignum_digit_type result_digits [BIGNUM_DIGITS_FOR(type)]; \ @@ -355,7 +356,7 @@ bignum_remainder(bignum_type numerator, bignum_type denominator) while (accumulator != 0); \ } \ { \ - bignum_type result = \ + F_BIGNUM * result = \ (allot_bignum ((end_digits - result_digits), negative_p)); \ bignum_digit_type * scan_digits = result_digits; \ bignum_digit_type * scan_result = (BIGNUM_START_PTR (result)); \ @@ -372,7 +373,7 @@ FOO_TO_BIGNUM(long_long,s64,u64) FOO_TO_BIGNUM(ulong_long,u64,u64) #define BIGNUM_TO_FOO(name,type,utype) \ - type bignum_to_##name(bignum_type bignum) \ + type bignum_to_##name(F_BIGNUM * bignum) \ { \ if (BIGNUM_ZERO_P (bignum)) \ return (0); \ @@ -393,7 +394,7 @@ BIGNUM_TO_FOO(long_long,s64,u64) BIGNUM_TO_FOO(ulong_long,u64,u64) double -bignum_to_double(bignum_type bignum) +bignum_to_double(F_BIGNUM * bignum) { if (BIGNUM_ZERO_P (bignum)) return (0); @@ -418,7 +419,7 @@ bignum_to_double(bignum_type bignum) /* allocates memory */ #define inf std::numeric_limits::infinity() -bignum_type +F_BIGNUM * double_to_bignum(double x) { if (x == inf || x == -inf || x != x) return (BIGNUM_ZERO ()); @@ -429,7 +430,7 @@ double_to_bignum(double x) if (significand < 0) significand = (-significand); { bignum_length_type length = (BIGNUM_BITS_TO_DIGITS (exponent)); - bignum_type result = (allot_bignum (length, (x < 0))); + F_BIGNUM * result = (allot_bignum (length, (x < 0))); bignum_digit_type * start = (BIGNUM_START_PTR (result)); bignum_digit_type * scan = (start + length); bignum_digit_type digit; @@ -455,7 +456,7 @@ double_to_bignum(double x) /* Comparisons */ int -bignum_equal_p_unsigned(bignum_type x, bignum_type y) +bignum_equal_p_unsigned(F_BIGNUM * x, F_BIGNUM * y) { bignum_length_type length = (BIGNUM_LENGTH (x)); if (length != (BIGNUM_LENGTH (y))) @@ -473,7 +474,7 @@ bignum_equal_p_unsigned(bignum_type x, bignum_type y) } enum bignum_comparison -bignum_compare_unsigned(bignum_type x, bignum_type y) +bignum_compare_unsigned(F_BIGNUM * x, F_BIGNUM * y) { bignum_length_type x_length = (BIGNUM_LENGTH (x)); bignum_length_type y_length = (BIGNUM_LENGTH (y)); @@ -501,12 +502,12 @@ bignum_compare_unsigned(bignum_type x, bignum_type y) /* Addition */ /* allocates memory */ -bignum_type -bignum_add_unsigned(bignum_type x, bignum_type y, int negative_p) +F_BIGNUM * +bignum_add_unsigned(F_BIGNUM * x, F_BIGNUM * y, int negative_p) { if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x))) { - bignum_type z = x; + F_BIGNUM * z = x; x = y; y = z; } @@ -515,7 +516,7 @@ bignum_add_unsigned(bignum_type x, bignum_type y, int negative_p) REGISTER_BIGNUM(x); REGISTER_BIGNUM(y); - bignum_type r = (allot_bignum ((x_length + 1), negative_p)); + F_BIGNUM * r = (allot_bignum ((x_length + 1), negative_p)); UNREGISTER_BIGNUM(y); UNREGISTER_BIGNUM(x); @@ -571,8 +572,8 @@ bignum_add_unsigned(bignum_type x, bignum_type y, int negative_p) /* Subtraction */ /* allocates memory */ -bignum_type -bignum_subtract_unsigned(bignum_type x, bignum_type y) +F_BIGNUM * +bignum_subtract_unsigned(F_BIGNUM * x, F_BIGNUM * y) { int negative_p = 0; switch (bignum_compare_unsigned (x, y)) @@ -581,7 +582,7 @@ bignum_subtract_unsigned(bignum_type x, bignum_type y) return (BIGNUM_ZERO ()); case bignum_comparison_less: { - bignum_type z = x; + F_BIGNUM * z = x; x = y; y = z; } @@ -596,7 +597,7 @@ bignum_subtract_unsigned(bignum_type x, bignum_type y) REGISTER_BIGNUM(x); REGISTER_BIGNUM(y); - bignum_type r = (allot_bignum (x_length, negative_p)); + F_BIGNUM * r = (allot_bignum (x_length, negative_p)); UNREGISTER_BIGNUM(y); UNREGISTER_BIGNUM(x); @@ -652,12 +653,12 @@ bignum_subtract_unsigned(bignum_type x, bignum_type y) where R == BIGNUM_RADIX_ROOT */ /* allocates memory */ -bignum_type -bignum_multiply_unsigned(bignum_type x, bignum_type y, int negative_p) +F_BIGNUM * +bignum_multiply_unsigned(F_BIGNUM * x, F_BIGNUM * y, int negative_p) { if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x))) { - bignum_type z = x; + F_BIGNUM * z = x; x = y; y = z; } @@ -675,7 +676,7 @@ bignum_multiply_unsigned(bignum_type x, bignum_type y, int negative_p) REGISTER_BIGNUM(x); REGISTER_BIGNUM(y); - bignum_type r = + F_BIGNUM * r = (allot_bignum_zeroed ((x_length + y_length), negative_p)); UNREGISTER_BIGNUM(y); UNREGISTER_BIGNUM(x); @@ -726,14 +727,14 @@ bignum_multiply_unsigned(bignum_type x, bignum_type y, int negative_p) } /* allocates memory */ -bignum_type -bignum_multiply_unsigned_small_factor(bignum_type x, bignum_digit_type y, +F_BIGNUM * +bignum_multiply_unsigned_small_factor(F_BIGNUM * x, bignum_digit_type y, int negative_p) { bignum_length_type length_x = (BIGNUM_LENGTH (x)); REGISTER_BIGNUM(x); - bignum_type p = (allot_bignum ((length_x + 1), negative_p)); + F_BIGNUM * p = (allot_bignum ((length_x + 1), negative_p)); UNREGISTER_BIGNUM(x); bignum_destructive_copy (x, p); @@ -743,7 +744,7 @@ bignum_multiply_unsigned_small_factor(bignum_type x, bignum_digit_type y, } void -bignum_destructive_add(bignum_type bignum, bignum_digit_type n) +bignum_destructive_add(F_BIGNUM * bignum, bignum_digit_type n) { bignum_digit_type * scan = (BIGNUM_START_PTR (bignum)); bignum_digit_type digit; @@ -767,7 +768,7 @@ bignum_destructive_add(bignum_type bignum, bignum_digit_type n) } void -bignum_destructive_scale_up(bignum_type bignum, bignum_digit_type factor) +bignum_destructive_scale_up(F_BIGNUM * bignum, bignum_digit_type factor) { bignum_digit_type carry = 0; bignum_digit_type * scan = (BIGNUM_START_PTR (bignum)); @@ -805,10 +806,10 @@ bignum_destructive_scale_up(bignum_type bignum, bignum_digit_type factor) /* allocates memory */ void -bignum_divide_unsigned_large_denominator(bignum_type numerator, - bignum_type denominator, - bignum_type * quotient, - bignum_type * remainder, +bignum_divide_unsigned_large_denominator(F_BIGNUM * numerator, + F_BIGNUM * denominator, + F_BIGNUM * * quotient, + F_BIGNUM * * remainder, int q_negative_p, int r_negative_p) { @@ -818,13 +819,13 @@ bignum_divide_unsigned_large_denominator(bignum_type numerator, REGISTER_BIGNUM(numerator); REGISTER_BIGNUM(denominator); - bignum_type q = - ((quotient != ((bignum_type *) 0)) + F_BIGNUM * q = + ((quotient != ((F_BIGNUM * *) 0)) ? (allot_bignum ((length_n - length_d), q_negative_p)) : BIGNUM_OUT_OF_BAND); REGISTER_BIGNUM(q); - bignum_type u = (allot_bignum (length_n, r_negative_p)); + F_BIGNUM * u = (allot_bignum (length_n, r_negative_p)); UNREGISTER_BIGNUM(q); UNREGISTER_BIGNUM(denominator); @@ -852,7 +853,7 @@ bignum_divide_unsigned_large_denominator(bignum_type numerator, REGISTER_BIGNUM(denominator); REGISTER_BIGNUM(u); REGISTER_BIGNUM(q); - bignum_type v = (allot_bignum (length_d, 0)); + F_BIGNUM * v = (allot_bignum (length_d, 0)); UNREGISTER_BIGNUM(q); UNREGISTER_BIGNUM(u); UNREGISTER_BIGNUM(denominator); @@ -861,7 +862,7 @@ bignum_divide_unsigned_large_denominator(bignum_type numerator, bignum_destructive_normalization (numerator, u, shift); bignum_destructive_normalization (denominator, v, shift); bignum_divide_unsigned_normalized (u, v, q); - if (remainder != ((bignum_type *) 0)) + if (remainder != ((F_BIGNUM * *) 0)) bignum_destructive_unnormalization (u, shift); } @@ -874,17 +875,17 @@ bignum_divide_unsigned_large_denominator(bignum_type numerator, u = bignum_trim (u); UNREGISTER_BIGNUM(q); - if (quotient != ((bignum_type *) 0)) + if (quotient != ((F_BIGNUM * *) 0)) (*quotient) = q; - if (remainder != ((bignum_type *) 0)) + if (remainder != ((F_BIGNUM * *) 0)) (*remainder) = u; return; } void -bignum_divide_unsigned_normalized(bignum_type u, bignum_type v, bignum_type q) +bignum_divide_unsigned_normalized(F_BIGNUM * u, F_BIGNUM * v, F_BIGNUM * q) { bignum_length_type u_length = (BIGNUM_LENGTH (u)); bignum_length_type v_length = (BIGNUM_LENGTH (v)); @@ -1039,16 +1040,16 @@ bignum_divide_subtract(bignum_digit_type * v_start, /* allocates memory */ void -bignum_divide_unsigned_medium_denominator(bignum_type numerator, +bignum_divide_unsigned_medium_denominator(F_BIGNUM * numerator, bignum_digit_type denominator, - bignum_type * quotient, - bignum_type * remainder, + F_BIGNUM * * quotient, + F_BIGNUM * * 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; + F_BIGNUM * q; int shift = 0; /* Because `bignum_digit_divide' requires a normalized denominator. */ while (denominator < (BIGNUM_RADIX / 2)) @@ -1090,7 +1091,7 @@ bignum_divide_unsigned_medium_denominator(bignum_type numerator, q = bignum_trim (q); - if (remainder != ((bignum_type *) 0)) + if (remainder != ((F_BIGNUM * *) 0)) { if (shift != 0) r >>= shift; @@ -1100,14 +1101,14 @@ bignum_divide_unsigned_medium_denominator(bignum_type numerator, UNREGISTER_BIGNUM(q); } - if (quotient != ((bignum_type *) 0)) + if (quotient != ((F_BIGNUM * *) 0)) (*quotient) = q; } return; } void -bignum_destructive_normalization(bignum_type source, bignum_type target, +bignum_destructive_normalization(F_BIGNUM * source, F_BIGNUM * target, int shift_left) { bignum_digit_type digit; @@ -1132,7 +1133,7 @@ bignum_destructive_normalization(bignum_type source, bignum_type target, } void -bignum_destructive_unnormalization(bignum_type bignum, int shift_right) +bignum_destructive_unnormalization(F_BIGNUM * bignum, int shift_right) { bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); @@ -1287,22 +1288,22 @@ bignum_digit_divide_subtract(bignum_digit_type v1, bignum_digit_type v2, /* allocates memory */ void -bignum_divide_unsigned_small_denominator(bignum_type numerator, +bignum_divide_unsigned_small_denominator(F_BIGNUM * numerator, bignum_digit_type denominator, - bignum_type * quotient, - bignum_type * remainder, + F_BIGNUM * * quotient, + F_BIGNUM * * remainder, int q_negative_p, int r_negative_p) { REGISTER_BIGNUM(numerator); - bignum_type q = (bignum_new_sign (numerator, q_negative_p)); + F_BIGNUM * q = (bignum_new_sign (numerator, q_negative_p)); UNREGISTER_BIGNUM(numerator); bignum_digit_type r = (bignum_destructive_scale_down (q, denominator)); q = (bignum_trim (q)); - if (remainder != ((bignum_type *) 0)) + if (remainder != ((F_BIGNUM * *) 0)) { REGISTER_BIGNUM(q); (*remainder) = (bignum_digit_to_bignum (r, r_negative_p)); @@ -1319,7 +1320,7 @@ bignum_divide_unsigned_small_denominator(bignum_type numerator, that all digits are < BIGNUM_RADIX. */ bignum_digit_type -bignum_destructive_scale_down(bignum_type bignum, bignum_digit_type denominator) +bignum_destructive_scale_down(F_BIGNUM * bignum, bignum_digit_type denominator) { bignum_digit_type numerator; bignum_digit_type remainder = 0; @@ -1342,9 +1343,9 @@ bignum_destructive_scale_down(bignum_type bignum, bignum_digit_type denominator) } /* allocates memory */ -bignum_type +F_BIGNUM * bignum_remainder_unsigned_small_denominator( - bignum_type n, bignum_digit_type d, int negative_p) + F_BIGNUM * n, bignum_digit_type d, int negative_p) { bignum_digit_type two_digits; bignum_digit_type * start = (BIGNUM_START_PTR (n)); @@ -1363,34 +1364,34 @@ bignum_remainder_unsigned_small_denominator( } /* allocates memory */ -bignum_type +F_BIGNUM * bignum_digit_to_bignum(bignum_digit_type digit, int negative_p) { if (digit == 0) return (BIGNUM_ZERO ()); else { - bignum_type result = (allot_bignum (1, negative_p)); + F_BIGNUM * result = (allot_bignum (1, negative_p)); (BIGNUM_REF (result, 0)) = digit; return (result); } } /* allocates memory */ -bignum_type +F_BIGNUM * allot_bignum(bignum_length_type length, int negative_p) { BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX)); - bignum_type result = allot_array_internal(BIGNUM_TYPE,length + 1); + F_BIGNUM * result = allot_array_internal(length + 1); BIGNUM_SET_NEGATIVE_P (result, negative_p); return (result); } /* allocates memory */ -bignum_type +F_BIGNUM * allot_bignum_zeroed(bignum_length_type length, int negative_p) { - bignum_type result = allot_bignum(length,negative_p); + F_BIGNUM * result = allot_bignum(length,negative_p); bignum_digit_type * scan = (BIGNUM_START_PTR (result)); bignum_digit_type * end = (scan + length); while (scan < end) @@ -1399,11 +1400,11 @@ allot_bignum_zeroed(bignum_length_type length, int negative_p) } #define BIGNUM_REDUCE_LENGTH(source, length) \ - source = reallot_array(source,length + 1) + source = reallot_array(source,length + 1) /* allocates memory */ -bignum_type -bignum_shorten_length(bignum_type bignum, bignum_length_type length) +F_BIGNUM * +bignum_shorten_length(F_BIGNUM * bignum, bignum_length_type length) { bignum_length_type current_length = (BIGNUM_LENGTH (bignum)); BIGNUM_ASSERT ((length >= 0) || (length <= current_length)); @@ -1416,8 +1417,8 @@ bignum_shorten_length(bignum_type bignum, bignum_length_type length) } /* allocates memory */ -bignum_type -bignum_trim(bignum_type bignum) +F_BIGNUM * +bignum_trim(F_BIGNUM * bignum) { bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); bignum_digit_type * end = (start + (BIGNUM_LENGTH (bignum))); @@ -1437,11 +1438,11 @@ bignum_trim(bignum_type bignum) /* Copying */ /* allocates memory */ -bignum_type -bignum_new_sign(bignum_type bignum, int negative_p) +F_BIGNUM * +bignum_new_sign(F_BIGNUM * bignum, int negative_p) { REGISTER_BIGNUM(bignum); - bignum_type result = + F_BIGNUM * result = (allot_bignum ((BIGNUM_LENGTH (bignum)), negative_p)); UNREGISTER_BIGNUM(bignum); @@ -1450,14 +1451,14 @@ bignum_new_sign(bignum_type bignum, int negative_p) } /* allocates memory */ -bignum_type -bignum_maybe_new_sign(bignum_type bignum, int negative_p) +F_BIGNUM * +bignum_maybe_new_sign(F_BIGNUM * bignum, int negative_p) { if ((BIGNUM_NEGATIVE_P (bignum)) ? negative_p : (! negative_p)) return (bignum); else { - bignum_type result = + F_BIGNUM * result = (allot_bignum ((BIGNUM_LENGTH (bignum)), negative_p)); bignum_destructive_copy (bignum, result); return (result); @@ -1465,7 +1466,7 @@ bignum_maybe_new_sign(bignum_type bignum, int negative_p) } void -bignum_destructive_copy(bignum_type source, bignum_type target) +bignum_destructive_copy(F_BIGNUM * source, F_BIGNUM * target) { bignum_digit_type * scan_source = (BIGNUM_START_PTR (source)); bignum_digit_type * end_source = @@ -1481,15 +1482,15 @@ bignum_destructive_copy(bignum_type source, bignum_type target) */ /* allocates memory */ -bignum_type -bignum_bitwise_not(bignum_type x) +F_BIGNUM * +bignum_bitwise_not(F_BIGNUM * x) { return bignum_subtract(BIGNUM_ONE(1), x); } /* allocates memory */ -bignum_type -bignum_arithmetic_shift(bignum_type arg1, F_FIXNUM n) +F_BIGNUM * +bignum_arithmetic_shift(F_BIGNUM * arg1, F_FIXNUM n) { if (BIGNUM_NEGATIVE_P(arg1) && n < 0) return bignum_bitwise_not(bignum_magnitude_ash(bignum_bitwise_not(arg1), n)); @@ -1502,8 +1503,8 @@ bignum_arithmetic_shift(bignum_type arg1, F_FIXNUM n) #define XOR_OP 2 /* allocates memory */ -bignum_type -bignum_bitwise_and(bignum_type arg1, bignum_type arg2) +F_BIGNUM * +bignum_bitwise_and(F_BIGNUM * arg1, F_BIGNUM * arg2) { return( (BIGNUM_NEGATIVE_P (arg1)) @@ -1517,8 +1518,8 @@ bignum_bitwise_and(bignum_type arg1, bignum_type arg2) } /* allocates memory */ -bignum_type -bignum_bitwise_ior(bignum_type arg1, bignum_type arg2) +F_BIGNUM * +bignum_bitwise_ior(F_BIGNUM * arg1, F_BIGNUM * arg2) { return( (BIGNUM_NEGATIVE_P (arg1)) @@ -1532,8 +1533,8 @@ bignum_bitwise_ior(bignum_type arg1, bignum_type arg2) } /* allocates memory */ -bignum_type -bignum_bitwise_xor(bignum_type arg1, bignum_type arg2) +F_BIGNUM * +bignum_bitwise_xor(F_BIGNUM * arg1, F_BIGNUM * arg2) { return( (BIGNUM_NEGATIVE_P (arg1)) @@ -1549,10 +1550,10 @@ bignum_bitwise_xor(bignum_type arg1, bignum_type arg2) /* allocates memory */ /* ash for the magnitude */ /* assume arg1 is a big number, n is a long */ -bignum_type -bignum_magnitude_ash(bignum_type arg1, F_FIXNUM n) +F_BIGNUM * +bignum_magnitude_ash(F_BIGNUM * arg1, F_FIXNUM n) { - bignum_type result = NULL; + F_BIGNUM * result = NULL; bignum_digit_type *scan1; bignum_digit_type *scanr; bignum_digit_type *end; @@ -1613,10 +1614,10 @@ bignum_magnitude_ash(bignum_type arg1, F_FIXNUM n) } /* allocates memory */ -bignum_type -bignum_pospos_bitwise_op(int op, bignum_type arg1, bignum_type arg2) +F_BIGNUM * +bignum_pospos_bitwise_op(int op, F_BIGNUM * arg1, F_BIGNUM * arg2) { - bignum_type result; + F_BIGNUM * result; bignum_length_type max_length; bignum_digit_type *scan1, *end1, digit1; @@ -1650,10 +1651,10 @@ bignum_pospos_bitwise_op(int op, bignum_type arg1, bignum_type arg2) } /* allocates memory */ -bignum_type -bignum_posneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2) +F_BIGNUM * +bignum_posneg_bitwise_op(int op, F_BIGNUM * arg1, F_BIGNUM * arg2) { - bignum_type result; + F_BIGNUM * result; bignum_length_type max_length; bignum_digit_type *scan1, *end1, digit1; @@ -1705,10 +1706,10 @@ bignum_posneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2) } /* allocates memory */ -bignum_type -bignum_negneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2) +F_BIGNUM * +bignum_negneg_bitwise_op(int op, F_BIGNUM * arg1, F_BIGNUM * arg2) { - bignum_type result; + F_BIGNUM * result; bignum_length_type max_length; bignum_digit_type *scan1, *end1, digit1, carry1; @@ -1768,7 +1769,7 @@ bignum_negneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2) } void -bignum_negate_magnitude(bignum_type arg) +bignum_negate_magnitude(F_BIGNUM * arg) { bignum_digit_type *scan; bignum_digit_type *end; @@ -1796,14 +1797,14 @@ bignum_negate_magnitude(bignum_type arg) } /* Allocates memory */ -bignum_type -bignum_integer_length(bignum_type bignum) +F_BIGNUM * +bignum_integer_length(F_BIGNUM * bignum) { bignum_length_type index = ((BIGNUM_LENGTH (bignum)) - 1); bignum_digit_type digit = (BIGNUM_REF (bignum, index)); REGISTER_BIGNUM(bignum); - bignum_type result = (allot_bignum (2, 0)); + F_BIGNUM * result = (allot_bignum (2, 0)); UNREGISTER_BIGNUM(bignum); (BIGNUM_REF (result, 0)) = index; @@ -1819,7 +1820,7 @@ bignum_integer_length(bignum_type bignum) /* Allocates memory */ int -bignum_logbitp(int shift, bignum_type arg) +bignum_logbitp(int shift, F_BIGNUM * arg) { return((BIGNUM_NEGATIVE_P (arg)) ? !bignum_unsigned_logbitp (shift, bignum_bitwise_not (arg)) @@ -1827,7 +1828,7 @@ bignum_logbitp(int shift, bignum_type arg) } int -bignum_unsigned_logbitp(int shift, bignum_type bignum) +bignum_unsigned_logbitp(int shift, F_BIGNUM * bignum) { bignum_length_type len = (BIGNUM_LENGTH (bignum)); int index = shift / BIGNUM_DIGIT_LENGTH; @@ -1840,7 +1841,7 @@ bignum_unsigned_logbitp(int shift, bignum_type bignum) } /* Allocates memory */ -bignum_type +F_BIGNUM * digit_stream_to_bignum(unsigned int n_digits, unsigned int (*producer)(unsigned int), unsigned int radix, @@ -1868,7 +1869,7 @@ digit_stream_to_bignum(unsigned int n_digits, length = (BIGNUM_BITS_TO_DIGITS (n_digits * log_radix)); } { - bignum_type result = (allot_bignum_zeroed (length, negative_p)); + F_BIGNUM * result = (allot_bignum_zeroed (length, negative_p)); while ((n_digits--) > 0) { bignum_destructive_scale_up (result, ((bignum_digit_type) radix)); diff --git a/vmpp/bignum.hpp b/vmpp/bignum.hpp index 02309cad34..23a0dd2142 100644 --- a/vmpp/bignum.hpp +++ b/vmpp/bignum.hpp @@ -32,8 +32,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -typedef F_ARRAY * bignum_type; -#define BIGNUM_OUT_OF_BAND ((bignum_type) 0) +#define BIGNUM_OUT_OF_BAND ((F_BIGNUM *) 0) enum bignum_comparison { @@ -42,86 +41,86 @@ enum bignum_comparison bignum_comparison_greater = 1 }; -int bignum_equal_p(bignum_type, bignum_type); -enum bignum_comparison bignum_compare(bignum_type, bignum_type); -bignum_type bignum_add(bignum_type, bignum_type); -bignum_type bignum_subtract(bignum_type, bignum_type); -bignum_type bignum_negate(bignum_type); -bignum_type bignum_multiply(bignum_type, bignum_type); +int bignum_equal_p(F_BIGNUM *, F_BIGNUM *); +enum bignum_comparison bignum_compare(F_BIGNUM *, F_BIGNUM *); +F_BIGNUM * bignum_add(F_BIGNUM *, F_BIGNUM *); +F_BIGNUM * bignum_subtract(F_BIGNUM *, F_BIGNUM *); +F_BIGNUM * bignum_negate(F_BIGNUM *); +F_BIGNUM * bignum_multiply(F_BIGNUM *, F_BIGNUM *); void -bignum_divide(bignum_type numerator, bignum_type denominator, - bignum_type * quotient, bignum_type * remainder); -bignum_type bignum_quotient(bignum_type, bignum_type); -bignum_type bignum_remainder(bignum_type, bignum_type); -DLLEXPORT bignum_type fixnum_to_bignum(F_FIXNUM); -DLLEXPORT bignum_type cell_to_bignum(CELL); -DLLEXPORT bignum_type long_long_to_bignum(s64 n); -DLLEXPORT bignum_type ulong_long_to_bignum(u64 n); -F_FIXNUM bignum_to_fixnum(bignum_type); -CELL bignum_to_cell(bignum_type); -s64 bignum_to_long_long(bignum_type); -u64 bignum_to_ulong_long(bignum_type); -bignum_type double_to_bignum(double); -double bignum_to_double(bignum_type); +bignum_divide(F_BIGNUM * numerator, F_BIGNUM * denominator, + F_BIGNUM * * quotient, F_BIGNUM * * remainder); +F_BIGNUM * bignum_quotient(F_BIGNUM *, F_BIGNUM *); +F_BIGNUM * bignum_remainder(F_BIGNUM *, F_BIGNUM *); +F_BIGNUM * fixnum_to_bignum(F_FIXNUM); +F_BIGNUM * cell_to_bignum(CELL); +F_BIGNUM * long_long_to_bignum(s64 n); +F_BIGNUM * ulong_long_to_bignum(u64 n); +F_FIXNUM bignum_to_fixnum(F_BIGNUM *); +CELL bignum_to_cell(F_BIGNUM *); +s64 bignum_to_long_long(F_BIGNUM *); +u64 bignum_to_ulong_long(F_BIGNUM *); +F_BIGNUM * double_to_bignum(double); +double bignum_to_double(F_BIGNUM *); /* Added bitwise operators. */ -DLLEXPORT bignum_type bignum_bitwise_not(bignum_type), - bignum_arithmetic_shift(bignum_type, F_FIXNUM), - bignum_bitwise_and(bignum_type, bignum_type), - bignum_bitwise_ior(bignum_type, bignum_type), - bignum_bitwise_xor(bignum_type, bignum_type); +F_BIGNUM * bignum_bitwise_not(F_BIGNUM *); +F_BIGNUM * bignum_arithmetic_shift(F_BIGNUM *, F_FIXNUM); +F_BIGNUM * bignum_bitwise_and(F_BIGNUM *, F_BIGNUM *); +F_BIGNUM * bignum_bitwise_ior(F_BIGNUM *, F_BIGNUM *); +F_BIGNUM * bignum_bitwise_xor(F_BIGNUM *, F_BIGNUM *); /* 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); +int bignum_equal_p_unsigned(F_BIGNUM *, F_BIGNUM *); +enum bignum_comparison bignum_compare_unsigned(F_BIGNUM *, F_BIGNUM *); +F_BIGNUM * bignum_add_unsigned(F_BIGNUM *, F_BIGNUM *, int); +F_BIGNUM * bignum_subtract_unsigned(F_BIGNUM *, F_BIGNUM *); +F_BIGNUM * bignum_multiply_unsigned(F_BIGNUM *, F_BIGNUM *, int); +F_BIGNUM * bignum_multiply_unsigned_small_factor + (F_BIGNUM *, bignum_digit_type, int); +void bignum_destructive_scale_up(F_BIGNUM *, bignum_digit_type); +void bignum_destructive_add(F_BIGNUM *, 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); + (F_BIGNUM *, F_BIGNUM *, F_BIGNUM * *, F_BIGNUM * *, int, int); +void bignum_destructive_normalization(F_BIGNUM *, F_BIGNUM *, int); +void bignum_destructive_unnormalization(F_BIGNUM *, int); +void bignum_divide_unsigned_normalized(F_BIGNUM *, F_BIGNUM *, F_BIGNUM *); 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); + (F_BIGNUM *, bignum_digit_type, F_BIGNUM * *, F_BIGNUM * *, 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); + (F_BIGNUM *, bignum_digit_type, F_BIGNUM * *, F_BIGNUM * *, int, int); bignum_digit_type bignum_destructive_scale_down - (bignum_type, bignum_digit_type); -bignum_type bignum_remainder_unsigned_small_denominator - (bignum_type, bignum_digit_type, int); -bignum_type bignum_digit_to_bignum(bignum_digit_type, int); -bignum_type allot_bignum(bignum_length_type, int); -bignum_type allot_bignum_zeroed(bignum_length_type, int); -bignum_type bignum_shorten_length(bignum_type, bignum_length_type); -bignum_type bignum_trim(bignum_type); -bignum_type bignum_new_sign(bignum_type, int); -bignum_type bignum_maybe_new_sign(bignum_type, int); -void bignum_destructive_copy(bignum_type, bignum_type); + (F_BIGNUM *, bignum_digit_type); +F_BIGNUM * bignum_remainder_unsigned_small_denominator + (F_BIGNUM *, bignum_digit_type, int); +F_BIGNUM * bignum_digit_to_bignum(bignum_digit_type, int); +F_BIGNUM * allot_bignum(bignum_length_type, int); +F_BIGNUM * allot_bignum_zeroed(bignum_length_type, int); +F_BIGNUM * bignum_shorten_length(F_BIGNUM *, bignum_length_type); +F_BIGNUM * bignum_trim(F_BIGNUM *); +F_BIGNUM * bignum_new_sign(F_BIGNUM *, int); +F_BIGNUM * bignum_maybe_new_sign(F_BIGNUM *, int); +void bignum_destructive_copy(F_BIGNUM *, F_BIGNUM *); /* Added for bitwise operations. */ -bignum_type bignum_magnitude_ash(bignum_type arg1, F_FIXNUM n); -bignum_type bignum_pospos_bitwise_op(int op, bignum_type, bignum_type); -bignum_type bignum_posneg_bitwise_op(int op, bignum_type, bignum_type); -bignum_type bignum_negneg_bitwise_op(int op, bignum_type, bignum_type); -void bignum_negate_magnitude(bignum_type); +F_BIGNUM * bignum_magnitude_ash(F_BIGNUM * arg1, F_FIXNUM n); +F_BIGNUM * bignum_pospos_bitwise_op(int op, F_BIGNUM *, F_BIGNUM *); +F_BIGNUM * bignum_posneg_bitwise_op(int op, F_BIGNUM *, F_BIGNUM *); +F_BIGNUM * bignum_negneg_bitwise_op(int op, F_BIGNUM *, F_BIGNUM *); +void bignum_negate_magnitude(F_BIGNUM *); -bignum_type bignum_integer_length(bignum_type arg1); -int bignum_unsigned_logbitp(int shift, bignum_type bignum); -int bignum_logbitp(int shift, bignum_type arg); -bignum_type digit_stream_to_bignum(unsigned int n_digits, +F_BIGNUM * bignum_integer_length(F_BIGNUM * arg1); +int bignum_unsigned_logbitp(int shift, F_BIGNUM * bignum); +int bignum_logbitp(int shift, F_BIGNUM * arg); +F_BIGNUM * digit_stream_to_bignum(unsigned int n_digits, unsigned int (*producer)(unsigned int), unsigned int radix, int negative_p); diff --git a/vmpp/bignumint.hpp b/vmpp/bignumint.hpp index 9a8ff806ef..5e0b799090 100644 --- a/vmpp/bignumint.hpp +++ b/vmpp/bignumint.hpp @@ -46,7 +46,7 @@ typedef F_FIXNUM bignum_digit_type; typedef F_FIXNUM bignum_length_type; /* BIGNUM_TO_POINTER casts a bignum object to a digit array pointer. */ -#define BIGNUM_TO_POINTER(bignum) ((bignum_digit_type *)AREF(bignum,0)) +#define BIGNUM_TO_POINTER(bignum) ((bignum_digit_type *)(bignum + 1)) /* BIGNUM_EXCEPTION is invoked to handle assertion violations. */ #define BIGNUM_EXCEPTION abort diff --git a/vmpp/byte_arrays.cpp b/vmpp/byte_arrays.cpp index 3a4b155587..da44fc135b 100644 --- a/vmpp/byte_arrays.cpp +++ b/vmpp/byte_arrays.cpp @@ -1,22 +1,12 @@ #include "master.hpp" -/* must fill out array before next GC */ -F_BYTE_ARRAY *allot_byte_array_internal(CELL size) -{ - F_BYTE_ARRAY *array = (F_BYTE_ARRAY *)allot_object(BYTE_ARRAY_TYPE,byte_array_size(size)); - array->capacity = tag_fixnum(size); - return array; -} - -/* size is in bytes this time */ F_BYTE_ARRAY *allot_byte_array(CELL size) { - F_BYTE_ARRAY *array = allot_byte_array_internal(size); + F_BYTE_ARRAY *array = allot_array_internal(size); memset(array + 1,0,size); return array; } -/* push a new byte array on the stack */ void primitive_byte_array(void) { CELL size = unbox_array_size(); @@ -26,45 +16,14 @@ void primitive_byte_array(void) void primitive_uninitialized_byte_array(void) { CELL size = unbox_array_size(); - dpush(tag_object(allot_byte_array_internal(size))); -} - -static bool reallot_byte_array_in_place_p(F_BYTE_ARRAY *array, CELL capacity) -{ - return in_zone(&nursery,(CELL)array) && capacity <= array_capacity(array); -} - -F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity) -{ -#ifdef FACTOR_DEBUG - assert(untag_header(array->header) == BYTE_ARRAY_TYPE); -#endif - if(reallot_byte_array_in_place_p(array,capacity)) - { - array->capacity = tag_fixnum(capacity); - return array; - } - else - { - CELL to_copy = array_capacity(array); - if(capacity < to_copy) - to_copy = capacity; - - REGISTER_UNTAGGED(array); - F_BYTE_ARRAY *new_array = allot_byte_array_internal(capacity); - UNREGISTER_UNTAGGED(F_BYTE_ARRAY,array); - - memcpy(new_array + 1,array + 1,to_copy); - - return new_array; - } + dpush(tag_object(allot_array_internal(size))); } void primitive_resize_byte_array(void) { - F_BYTE_ARRAY* array = untag_byte_array(dpop()); + F_BYTE_ARRAY *array = untag_byte_array(dpop()); CELL capacity = unbox_array_size(); - dpush(tag_object(reallot_byte_array(array,capacity))); + dpush(tag_object(reallot_array(array,capacity))); } void growable_byte_array_append(F_GROWABLE_BYTE_ARRAY *array, void *elts, CELL len) @@ -72,9 +31,9 @@ void growable_byte_array_append(F_GROWABLE_BYTE_ARRAY *array, void *elts, CELL l CELL new_size = array->count + len; F_BYTE_ARRAY *underlying = untag_byte_array_fast(array->array); - if(new_size >= byte_array_capacity(underlying)) + if(new_size >= array_capacity(underlying)) { - underlying = reallot_byte_array(underlying,new_size * 2); + underlying = reallot_array(underlying,new_size * 2); array->array = tag_object(underlying); } diff --git a/vmpp/byte_arrays.hpp b/vmpp/byte_arrays.hpp index a297eff85d..fe0e5f7acd 100644 --- a/vmpp/byte_arrays.hpp +++ b/vmpp/byte_arrays.hpp @@ -1,28 +1,16 @@ DEFINE_UNTAG(F_BYTE_ARRAY,BYTE_ARRAY_TYPE,byte_array) -INLINE CELL byte_array_capacity(F_BYTE_ARRAY *array) -{ - return untag_fixnum_fast(array->capacity); -} - -INLINE CELL byte_array_size(CELL size) -{ - return sizeof(F_BYTE_ARRAY) + size; -} - F_BYTE_ARRAY *allot_byte_array(CELL size); -F_BYTE_ARRAY *allot_byte_array_internal(CELL size); -F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity); void primitive_byte_array(void); void primitive_uninitialized_byte_array(void); void primitive_resize_byte_array(void); /* Macros to simulate a byte vector in C */ -typedef struct { +struct F_GROWABLE_BYTE_ARRAY { CELL count; CELL array; -} F_GROWABLE_BYTE_ARRAY; +}; INLINE F_GROWABLE_BYTE_ARRAY make_growable_byte_array(void) { @@ -36,5 +24,5 @@ void growable_byte_array_append(F_GROWABLE_BYTE_ARRAY *result, void *elts, CELL INLINE void growable_byte_array_trim(F_GROWABLE_BYTE_ARRAY *byte_array) { - byte_array->array = tag_object(reallot_byte_array(untag_byte_array_fast(byte_array->array),byte_array->count)); + byte_array->array = tag_object(reallot_array(untag_byte_array_fast(byte_array->array),byte_array->count)); } diff --git a/vmpp/callstack.cpp b/vmpp/callstack.cpp index 325e91ebf6..00f31b9b56 100755 --- a/vmpp/callstack.cpp +++ b/vmpp/callstack.cpp @@ -164,7 +164,7 @@ void primitive_callstack_to_array(void) iterate_callstack_object(stack,count_stack_frame); REGISTER_UNTAGGED(stack); - array = allot_array_internal(ARRAY_TYPE,frame_count); + array = allot_array_internal(frame_count); UNREGISTER_UNTAGGED(F_CALLSTACK,stack); frame_index = 0; diff --git a/vmpp/code_block.cpp b/vmpp/code_block.cpp index 606eac1d66..7ef365f66b 100644 --- a/vmpp/code_block.cpp +++ b/vmpp/code_block.cpp @@ -14,7 +14,7 @@ void iterate_relocations(F_CODE_BLOCK *compiled, RELOCATION_ITERATOR iter) CELL index = stack_traces_p() ? 1 : 0; F_REL *rel = (F_REL *)(relocation + 1); - F_REL *rel_end = (F_REL *)((char *)rel + byte_array_capacity(relocation)); + F_REL *rel_end = (F_REL *)((char *)rel + array_capacity(relocation)); while(rel < rel_end) { diff --git a/vmpp/data_heap.cpp b/vmpp/data_heap.cpp index 21f4124707..c02c1c2a2f 100644 --- a/vmpp/data_heap.cpp +++ b/vmpp/data_heap.cpp @@ -216,11 +216,11 @@ CELL unaligned_object_size(CELL pointer) switch(untag_header(get(pointer))) { case ARRAY_TYPE: + return array_size((F_ARRAY*)pointer); case BIGNUM_TYPE: - return array_size(array_capacity((F_ARRAY*)pointer)); + return array_size((F_BIGNUM*)pointer); case BYTE_ARRAY_TYPE: - return byte_array_size( - byte_array_capacity((F_BYTE_ARRAY*)pointer)); + return array_size((F_BYTE_ARRAY*)pointer); case STRING_TYPE: return string_size(string_capacity((F_STRING*)pointer)); case TUPLE_TYPE: @@ -282,7 +282,7 @@ CELL binary_payload_start(CELL pointer) return sizeof(F_STRING); /* everything else consists entirely of pointers */ case ARRAY_TYPE: - return array_size(array_capacity((F_ARRAY*)pointer)); + return array_size(array_capacity((F_ARRAY*)pointer)); case TUPLE_TYPE: tuple = untag_tuple_fast(pointer); layout = untag_tuple_layout(tuple->layout); diff --git a/vmpp/factor.cpp b/vmpp/factor.cpp index f2f928190a..2321a7cc1f 100755 --- a/vmpp/factor.cpp +++ b/vmpp/factor.cpp @@ -152,7 +152,7 @@ void init_factor(F_PARAMETERS *p) /* May allocate memory */ void pass_args_to_factor(int argc, F_CHAR **argv) { - F_ARRAY *args = allot_array(ARRAY_TYPE,argc,F); + F_ARRAY *args = allot_array(argc,F); int i; for(i = 1; i < argc; i++) diff --git a/vmpp/generic_arrays.hpp b/vmpp/generic_arrays.hpp new file mode 100644 index 0000000000..1c505acea1 --- /dev/null +++ b/vmpp/generic_arrays.hpp @@ -0,0 +1,82 @@ +template CELL array_capacity(T *array) +{ +#ifdef FACTOR_DEBUG + CELL header = untag_header(array->header); + assert(header == T::type_number); +#endif + return array->capacity >> TAG_BITS; +} + +#define AREF(array,index) ((CELL)(array) + sizeof(F_ARRAY) + (index) * CELLS) +#define UNAREF(array,ptr) (((CELL)(ptr)-(CELL)(array)-sizeof(F_ARRAY)) / CELLS) + +template CELL array_nth(T *array, CELL slot) +{ +#ifdef FACTOR_DEBUG + assert(slot < array_capacity(array)); + assert(untag_header(array->header) == T::type_number); +#endif + return get(AREF(array,slot)); +} + +template void set_array_nth(T *array, CELL slot, CELL value) +{ +#ifdef FACTOR_DEBUG + assert(slot < array_capacity(array)); + assert(untag_header(array->header) == T::type_number); +#endif + put(AREF(array,slot),value); + write_barrier((CELL)array); +} + +template CELL array_size(CELL capacity) +{ + return sizeof(T) + capacity * T::element_size; +} + +template CELL array_size(T *array) +{ + return array_size(array_capacity(array)); +} + +template T *allot_array_internal(CELL capacity) +{ + T *array = (T *)allot_object(T::type_number,array_size(capacity)); + array->capacity = tag_fixnum(capacity); + return array; +} + +template bool reallot_array_in_place_p(T *array, CELL capacity) +{ + return in_zone(&nursery,(CELL)array) && capacity <= array_capacity(array); +} + +template T *reallot_array(T *array, CELL capacity) +{ +#ifdef FACTOR_DEBUG + CELL header = untag_header(array->header); + assert(header == T::type_number); +#endif + + if(reallot_array_in_place_p(array,capacity)) + { + array->capacity = tag_fixnum(capacity); + return array; + } + else + { + CELL to_copy = array_capacity(array); + if(capacity < to_copy) + to_copy = capacity; + + REGISTER_UNTAGGED(array); + T *new_array = allot_array_internal(capacity); + UNREGISTER_UNTAGGED(T,array); + + memcpy(new_array + 1,array + 1,to_copy * T::element_size); + memset((char *)(new_array + 1) + to_copy * T::element_size, + 0,(capacity - to_copy) * T::element_size); + + return new_array; + } +} diff --git a/vmpp/layouts.hpp b/vmpp/layouts.hpp index f00cb12622..75f91c41e5 100755 --- a/vmpp/layouts.hpp +++ b/vmpp/layouts.hpp @@ -87,6 +87,7 @@ struct F_OBJECT { /* Assembly code makes assumptions about the layout of this struct */ struct F_ARRAY : public F_OBJECT { static const CELL type_number = ARRAY_TYPE; + static const CELL element_size = CELLS; /* tagged */ CELL capacity; }; @@ -104,12 +105,14 @@ struct F_TUPLE_LAYOUT : public F_ARRAY { struct F_BIGNUM : public F_OBJECT { static const CELL type_number = BIGNUM_TYPE; + static const CELL element_size = CELLS; /* tagged */ CELL capacity; }; struct F_BYTE_ARRAY : public F_OBJECT { static const CELL type_number = BYTE_ARRAY_TYPE; + static const CELL element_size = 1; /* tagged */ CELL capacity; }; diff --git a/vmpp/master.hpp b/vmpp/master.hpp index 22f3be27b7..3ba7b70813 100644 --- a/vmpp/master.hpp +++ b/vmpp/master.hpp @@ -30,10 +30,10 @@ #include "bignumint.hpp" #include "bignum.hpp" #include "write_barrier.hpp" -#include "generic_arrays.hpp" #include "data_heap.hpp" #include "data_gc.hpp" #include "local_roots.hpp" +#include "generic_arrays.hpp" #include "debug.hpp" #include "arrays.hpp" #include "strings.hpp" diff --git a/vmpp/math.cpp b/vmpp/math.cpp index 7bc27b35c1..eb78bf0f7c 100644 --- a/vmpp/math.cpp +++ b/vmpp/math.cpp @@ -50,9 +50,9 @@ F_FASTCALL void overflow_fixnum_subtract(F_FIXNUM x, F_FIXNUM y) F_FASTCALL void overflow_fixnum_multiply(F_FIXNUM x, F_FIXNUM y) { - F_ARRAY *bx = fixnum_to_bignum(x); + F_BIGNUM *bx = fixnum_to_bignum(x); REGISTER_BIGNUM(bx); - F_ARRAY *by = fixnum_to_bignum(y); + F_BIGNUM *by = fixnum_to_bignum(y); UNREGISTER_BIGNUM(bx); drepl(tag_bignum(bignum_multiply(bx,by))); } @@ -133,8 +133,8 @@ void primitive_float_to_bignum(void) } #define POP_BIGNUMS(x,y) \ - bignum_type y = untag_bignum_fast(dpop()); \ - bignum_type x = untag_bignum_fast(dpop()); + F_BIGNUM * y = untag_bignum_fast(dpop()); \ + F_BIGNUM * x = untag_bignum_fast(dpop()); void primitive_bignum_eq(void) { @@ -168,7 +168,7 @@ void primitive_bignum_divint(void) void primitive_bignum_divmod(void) { - F_ARRAY *q, *r; + F_BIGNUM *q, *r; POP_BIGNUMS(x,y); bignum_divide(x,y,&q,&r); dpush(tag_bignum(q)); @@ -202,7 +202,7 @@ void primitive_bignum_xor(void) void primitive_bignum_shift(void) { F_FIXNUM y = untag_fixnum_fast(dpop()); - F_ARRAY* x = untag_bignum_fast(dpop()); + F_BIGNUM* x = untag_bignum_fast(dpop()); dpush(tag_bignum(bignum_arithmetic_shift(x,y))); } @@ -238,7 +238,7 @@ void primitive_bignum_not(void) void primitive_bignum_bitp(void) { F_FIXNUM bit = to_fixnum(dpop()); - F_ARRAY *x = untag_bignum_fast(dpop()); + F_BIGNUM *x = untag_bignum_fast(dpop()); box_boolean(bignum_logbitp(bit,x)); } @@ -256,8 +256,8 @@ unsigned int bignum_producer(unsigned int digit) void primitive_byte_array_to_bignum(void) { type_check(BYTE_ARRAY_TYPE,dpeek()); - CELL n_digits = array_capacity(untag_bignum_fast(dpeek())); - bignum_type bignum = digit_stream_to_bignum( + CELL n_digits = array_capacity(untag_byte_array_fast(dpeek())) / CELLS; + F_BIGNUM * bignum = digit_stream_to_bignum( n_digits,bignum_producer,0x100,0); drepl(tag_bignum(bignum)); } @@ -362,9 +362,9 @@ CELL unbox_array_size(void) } case BIGNUM_TYPE: { - bignum_type zero = untag_bignum_fast(bignum_zero); - bignum_type max = cell_to_bignum(ARRAY_SIZE_MAX); - bignum_type n = untag_bignum_fast(dpeek()); + F_BIGNUM * zero = untag_bignum_fast(bignum_zero); + F_BIGNUM * max = cell_to_bignum(ARRAY_SIZE_MAX); + F_BIGNUM * n = untag_bignum_fast(dpeek()); if(bignum_compare(n,zero) != bignum_comparison_less && bignum_compare(n,max) == bignum_comparison_less) { diff --git a/vmpp/math.hpp b/vmpp/math.hpp index dc8218c0c1..2f80cc7732 100644 --- a/vmpp/math.hpp +++ b/vmpp/math.hpp @@ -21,9 +21,9 @@ extern CELL bignum_zero; extern CELL bignum_pos_one; extern CELL bignum_neg_one; -DEFINE_UNTAG(F_ARRAY,BIGNUM_TYPE,bignum); +DEFINE_UNTAG(F_BIGNUM,BIGNUM_TYPE,bignum); -INLINE CELL tag_bignum(F_ARRAY* bignum) +INLINE CELL tag_bignum(F_BIGNUM* bignum) { return RETAG(bignum,BIGNUM_TYPE); } @@ -106,7 +106,7 @@ INLINE F_FIXNUM float_to_fixnum(CELL tagged) return (F_FIXNUM)untag_float_fast(tagged); } -INLINE F_ARRAY *float_to_bignum(CELL tagged) +INLINE F_BIGNUM *float_to_bignum(CELL tagged) { return double_to_bignum(untag_float_fast(tagged)); } diff --git a/vmpp/run.cpp b/vmpp/run.cpp index bb14ea94f3..588caacc74 100755 --- a/vmpp/run.cpp +++ b/vmpp/run.cpp @@ -124,7 +124,7 @@ bool stack_to_array(CELL bottom, CELL top) return false; else { - F_ARRAY *a = allot_array_internal(ARRAY_TYPE,depth / CELLS); + F_ARRAY *a = allot_array_internal(depth / CELLS); memcpy(a + 1,(void*)bottom,depth); dpush(tag_array(a)); return true; diff --git a/vmpp/strings.cpp b/vmpp/strings.cpp index 7864484c54..fcb7dbcf97 100644 --- a/vmpp/strings.cpp +++ b/vmpp/strings.cpp @@ -37,7 +37,7 @@ void set_string_nth_slow(F_STRING* string, CELL index, CELL ch) if the most significant bit of a character is set. Initially all of the bits are clear. */ - aux = allot_byte_array_internal( + aux = allot_array_internal( untag_fixnum_fast(string->length) * sizeof(u16)); UNREGISTER_UNTAGGED(F_STRING,string); diff --git a/vmpp/tagged.hpp b/vmpp/tagged.hpp new file mode 100644 index 0000000000..c6ccc66cd9 --- /dev/null +++ b/vmpp/tagged.hpp @@ -0,0 +1,32 @@ +template CELL tag(T *value) +{ + if(T::type_number < HEADER_TYPE) + return RETAG(value,T::type_number); + else + return RETAG(value,OBJECT_TYPE); +} + +template +class tagged +{ + CELL value; +public: + explicit tagged(CELL tagged) : value(tagged) {} + explicit tagged(T *untagged) : value(::tag(untagged)) {} + + CELL tag() const { return value; } + T *untag() const { type_check(T::type_number,value); } + T *untag_fast() const { return (T *)(UNTAG(value)); } + T *operator->() const { return untag_fast(); } + CELL *operator&() const { return &value; } +}; + +template T *untag(CELL value) +{ + return tagged(value).untag(); +} + +template T *untag_fast(CELL value) +{ + return tagged(value).untag_fast(); +} From 6a3e15665a00f93a5ce651151e38aea76388b885 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sat, 2 May 2009 14:09:32 +0200 Subject: [PATCH 03/44] fixed sorting --- extra/mongodb/driver/driver.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/mongodb/driver/driver.factor b/extra/mongodb/driver/driver.factor index a972d1c380..967d4f11c5 100644 --- a/extra/mongodb/driver/driver.factor +++ b/extra/mongodb/driver/driver.factor @@ -178,7 +178,7 @@ M: mdb-query-msg skip GENERIC# sort 1 ( mdb-query-msg sort-quot -- mdb-query-msg ) M: mdb-query-msg sort - output>array >>orderby ; inline + output>array [ 1array >hashtable ] map >>orderby ; inline : key-spec ( spec-quot -- spec-assoc ) output>array >hashtable ; inline From 91e8e9522c60698caec955875d289dc40e21f6e1 Mon Sep 17 00:00:00 2001 From: Sam Anklesaria Date: Sat, 2 May 2009 08:22:14 -0500 Subject: [PATCH 04/44] str-fry can take non-literals --- extra/str-fry/str-fry.factor | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/extra/str-fry/str-fry.factor b/extra/str-fry/str-fry.factor index aafdaa95d9..65e25e2580 100644 --- a/extra/str-fry/str-fry.factor +++ b/extra/str-fry/str-fry.factor @@ -1,4 +1,7 @@ -USING: kernel sequences splitting strings.parser ; +USING: fry.private kernel macros math sequences splitting strings.parser ; IN: str-fry -: str-fry ( str -- quot ) "_" split unclip [ [ rot glue ] reduce ] 2curry ; +: str-fry ( str -- quot ) "_" split + [ length 1 - [ncurry] [ call ] append ] + [ unclip [ [ rot glue ] reduce ] 2curry ] bi + prefix ; SYNTAX: I" parse-string rest str-fry over push-all ; \ No newline at end of file From 58512cbbdb8e25d9ca50e767ea1ac2f95b761ff4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 2 May 2009 09:19:09 -0500 Subject: [PATCH 05/44] Cleaning up VM code --- README.txt | 4 +- core/generic/standard/standard.factor | 2 +- vmpp/alien.cpp | 52 ++--- vmpp/arrays.cpp | 110 ++++------- vmpp/arrays.hpp | 44 +---- vmpp/byte_arrays.cpp | 36 +++- vmpp/byte_arrays.hpp | 26 +-- vmpp/callstack.cpp | 26 +-- vmpp/code_block.cpp | 48 ++--- vmpp/code_block.hpp | 7 +- vmpp/code_heap.cpp | 71 +++---- vmpp/code_heap.hpp | 2 +- vmpp/data_gc.cpp | 31 ++- vmpp/data_gc.hpp | 27 +-- vmpp/data_heap.cpp | 21 +- vmpp/data_heap.hpp | 10 +- vmpp/dispatch.cpp | 38 ++-- vmpp/dispatch.hpp | 4 +- vmpp/factor.cpp | 12 +- vmpp/generic_arrays.hpp | 19 +- vmpp/inline_cache.cpp | 158 ++++++++------- vmpp/io.cpp | 10 +- vmpp/jit.cpp | 149 +++++++-------- vmpp/jit.hpp | 130 +++++-------- vmpp/layouts.hpp | 1 + vmpp/local_roots.hpp | 24 +-- vmpp/master.hpp | 4 +- vmpp/math.hpp | 2 +- vmpp/profiler.cpp | 28 ++- vmpp/quotations.cpp | 265 +++++++++++--------------- vmpp/quotations.hpp | 31 ++- vmpp/run.cpp | 16 +- vmpp/strings.cpp | 98 ++++------ vmpp/tagged.hpp | 51 +++-- vmpp/tuples.cpp | 31 ++- vmpp/words.cpp | 36 ++-- vmpp/words.hpp | 2 +- 37 files changed, 713 insertions(+), 913 deletions(-) diff --git a/README.txt b/README.txt index c0d56dfa09..addbe38f0d 100755 --- a/README.txt +++ b/README.txt @@ -20,7 +20,7 @@ implementation. It is not an introduction to the language itself. * Compiling the Factor VM -The Factor runtime is written in GNU C99, and is built with GNU make and +The Factor runtime is written in GNU C++, and is built with GNU make and gcc. Factor supports various platforms. For an up-to-date list, see @@ -138,7 +138,7 @@ usage documentation, enter the following in the UI listener: The Factor source tree is organized as follows: build-support/ - scripts used for compiling Factor - vm/ - sources for the Factor VM, written in C + vm/ - sources for the Factor VM, written in C++ core/ - Factor core library basis/ - Factor basis library, compiler, tools extra/ - more libraries and applications diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 96c273e3f8..499adcc818 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -44,7 +44,7 @@ M: standard-combination inline-cache-quot ( word methods -- ) #! Direct calls to the generic word (not tail calls or indirect calls) #! will jump to the inline cache entry point instead of the megamorphic #! dispatch entry point. - combination get #>> [ f inline-cache-miss ] 3curry [ ] like ; + combination get #>> [ { } inline-cache-miss ] 3curry [ ] like ; : make-empty-cache ( -- array ) mega-cache-size get f ; diff --git a/vmpp/alien.cpp b/vmpp/alien.cpp index d55ea75b0d..f7c1d8919a 100755 --- a/vmpp/alien.cpp +++ b/vmpp/alien.cpp @@ -9,10 +9,10 @@ char *alien_offset(CELL object) switch(type_of(object)) { case BYTE_ARRAY_TYPE: - byte_array = untag_byte_array_fast(object); + byte_array = untagged(object); return (char *)(byte_array + 1); case ALIEN_TYPE: - alien = untag_alien_fast(object); + alien = untagged(object); if(alien->expired != F) general_error(ERROR_EXPIRED,object,F,NULL); return alien_offset(alien->alien) + alien->displacement; @@ -33,7 +33,7 @@ char *pinned_alien_offset(CELL object) switch(type_of(object)) { case ALIEN_TYPE: - alien = untag_alien_fast(object); + alien = untagged(object); if(alien->expired != F) general_error(ERROR_EXPIRED,object,F,NULL); return pinned_alien_offset(alien->alien) + alien->displacement; @@ -52,24 +52,24 @@ char *unbox_alien(void) } /* make an alien */ -CELL allot_alien(CELL delegate, CELL displacement) +CELL allot_alien(CELL delegate_, CELL displacement) { - REGISTER_ROOT(delegate); - F_ALIEN *alien = (F_ALIEN *)allot_object(ALIEN_TYPE,sizeof(F_ALIEN)); - UNREGISTER_ROOT(delegate); + gc_root delegate(delegate_); + gc_root alien(allot(sizeof(F_ALIEN))); - if(type_of(delegate) == ALIEN_TYPE) + if(delegate.isa(ALIEN_TYPE)) { - F_ALIEN *delegate_alien = untag_alien_fast(delegate); + tagged delegate_alien = delegate.as(); displacement += delegate_alien->displacement; alien->alien = delegate_alien->alien; } else - alien->alien = delegate; + alien->alien = delegate.value(); alien->displacement = displacement; alien->expired = F; - return tag_object(alien); + + return alien.value(); } /* make an alien and push */ @@ -183,35 +183,28 @@ void box_medium_struct(CELL x1, CELL x2, CELL x3, CELL x4, CELL size) /* open a native library and push a handle */ void primitive_dlopen(void) { - CELL path = tag_object(string_to_native_alien( - untag_string(dpop()))); - REGISTER_ROOT(path); - F_DLL *dll = (F_DLL *)allot_object(DLL_TYPE,sizeof(F_DLL)); - UNREGISTER_ROOT(path); - dll->path = path; - ffi_dlopen(dll); - dpush(tag_object(dll)); + gc_root path(tag_object(string_to_native_alien(untag_string(dpop())))); + gc_root dll(allot(sizeof(F_DLL))); + dll->path = path.value(); + ffi_dlopen(dll.untagged()); + dpush(dll.value()); } /* look up a symbol in a native library */ void primitive_dlsym(void) { - CELL dll = dpop(); - REGISTER_ROOT(dll); + gc_root dll(dpop()); F_SYMBOL *sym = unbox_symbol_string(); - UNREGISTER_ROOT(dll); - F_DLL *d; - - if(dll == F) + if(dll.value() == F) box_alien(ffi_dlsym(NULL,sym)); else { - d = untag_dll(dll); + tagged d = dll.as(); if(d->dll == NULL) dpush(F); else - box_alien(ffi_dlsym(d,sym)); + box_alien(ffi_dlsym(d.untagged(),sym)); } } @@ -227,8 +220,5 @@ void primitive_dll_validp(void) if(dll == F) dpush(T); else - { - F_DLL *d = untag_dll(dll); - dpush(d->dll == NULL ? F : T); - } + dpush(tagged(dll)->dll == NULL ? F : T); } diff --git a/vmpp/arrays.cpp b/vmpp/arrays.cpp index 3203da2c99..83953d20bc 100644 --- a/vmpp/arrays.cpp +++ b/vmpp/arrays.cpp @@ -1,13 +1,13 @@ #include "master.hpp" /* make a new array with an initial element */ -F_ARRAY *allot_array(CELL capacity, CELL fill) +F_ARRAY *allot_array(CELL capacity, CELL fill_) { - REGISTER_ROOT(fill); - F_ARRAY* array = allot_array_internal(capacity); - UNREGISTER_ROOT(fill); - if(fill == 0) - memset((void*)AREF(array,0),'\0',capacity * CELLS); + gc_root fill(fill_); + gc_root array(allot_array_internal(capacity)); + + if(fill.value() == tag_fixnum(0)) + memset((void*)AREF(array.untagged(),0),'\0',capacity * CELLS); else { /* No need for write barrier here. Either the object is in @@ -15,9 +15,9 @@ F_ARRAY *allot_array(CELL capacity, CELL fill) and the write barrier is already hit for us in that case. */ CELL i; for(i = 0; i < capacity; i++) - put(AREF(array,i),fill); + put(AREF(array.untagged(),i),fill.value()); } - return array; + return array.untagged(); } /* push a new array on the stack */ @@ -28,43 +28,36 @@ void primitive_array(void) dpush(tag_array(allot_array(size,initial))); } -CELL allot_array_1(CELL obj) +CELL allot_array_1(CELL obj_) { - REGISTER_ROOT(obj); - F_ARRAY *a = allot_array_internal(1); - UNREGISTER_ROOT(obj); - set_array_nth(a,0,obj); - return tag_array(a); + gc_root obj(obj_); + gc_root a(allot_array_internal(1)); + set_array_nth(a.untagged(),0,obj.value()); + return a.value(); } -CELL allot_array_2(CELL v1, CELL v2) +CELL allot_array_2(CELL v1_, CELL v2_) { - REGISTER_ROOT(v1); - REGISTER_ROOT(v2); - F_ARRAY *a = allot_array_internal(2); - UNREGISTER_ROOT(v2); - UNREGISTER_ROOT(v1); - set_array_nth(a,0,v1); - set_array_nth(a,1,v2); - return tag_array(a); + gc_root v1(v1_); + gc_root v2(v2_); + gc_root a(allot_array_internal(2)); + set_array_nth(a.untagged(),0,v1.value()); + set_array_nth(a.untagged(),1,v2.value()); + return a.value(); } -CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4) +CELL allot_array_4(CELL v1_, CELL v2_, CELL v3_, CELL v4_) { - REGISTER_ROOT(v1); - REGISTER_ROOT(v2); - REGISTER_ROOT(v3); - REGISTER_ROOT(v4); - F_ARRAY *a = allot_array_internal(4); - UNREGISTER_ROOT(v4); - UNREGISTER_ROOT(v3); - UNREGISTER_ROOT(v2); - UNREGISTER_ROOT(v1); - set_array_nth(a,0,v1); - set_array_nth(a,1,v2); - set_array_nth(a,2,v3); - set_array_nth(a,3,v4); - return tag_array(a); + gc_root v1(v1_); + gc_root v2(v2_); + gc_root v3(v3_); + gc_root v4(v4_); + gc_root a(allot_array_internal(4)); + set_array_nth(a.untagged(),0,v1.value()); + set_array_nth(a.untagged(),1,v2.value()); + set_array_nth(a.untagged(),2,v3.value()); + set_array_nth(a.untagged(),3,v4.value()); + return a.value(); } void primitive_resize_array(void) @@ -74,43 +67,16 @@ void primitive_resize_array(void) dpush(tag_array(reallot_array(array,capacity))); } -void growable_array_add(F_GROWABLE_ARRAY *array, CELL elt) +void growable_array::add(CELL elt_) { - F_ARRAY *underlying = untag_array_fast(array->array); - REGISTER_ROOT(elt); + gc_root elt(elt_); + if(count == array_capacity(array.untagged())) + array = reallot_array(array.untagged(),count * 2); - if(array->count == array_capacity(underlying)) - { - underlying = reallot_array(underlying,array->count * 2); - array->array = tag_array(underlying); - } - - UNREGISTER_ROOT(elt); - set_array_nth(underlying,array->count++,elt); + set_array_nth(array.untagged(),count++,elt.value()); } -void growable_array_append(F_GROWABLE_ARRAY *array, F_ARRAY *elts) +void growable_array::trim() { - REGISTER_UNTAGGED(elts); - - F_ARRAY *underlying = untag_array_fast(array->array); - - CELL elts_size = array_capacity(elts); - CELL new_size = array->count + elts_size; - - if(new_size >= array_capacity(underlying)) - { - underlying = reallot_array(underlying,new_size * 2); - array->array = tag_array(underlying); - } - - UNREGISTER_UNTAGGED(F_ARRAY,elts); - - write_barrier(array->array); - - memcpy((void *)AREF(underlying,array->count), - (void *)AREF(elts,0), - elts_size * CELLS); - - array->count += elts_size; + array = reallot_array(array.untagged(),count); } diff --git a/vmpp/arrays.hpp b/vmpp/arrays.hpp index 15caf3c56f..ad1112e81c 100644 --- a/vmpp/arrays.hpp +++ b/vmpp/arrays.hpp @@ -6,7 +6,6 @@ INLINE CELL tag_array(F_ARRAY *array) } F_ARRAY *allot_array(CELL capacity, CELL fill); -F_BYTE_ARRAY *allot_byte_array(CELL size); CELL allot_array_1(CELL obj); CELL allot_array_2(CELL v1, CELL v2); @@ -15,41 +14,12 @@ CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4); void primitive_array(void); void primitive_resize_array(void); -/* Macros to simulate a vector in C */ -struct F_GROWABLE_ARRAY { +struct growable_array { CELL count; - CELL array; + gc_root array; + + growable_array() : count(0), array(allot_array(2,F)) {} + + void add(CELL elt); + void trim(); }; - -/* Allocates memory */ -INLINE F_GROWABLE_ARRAY make_growable_array(void) -{ - F_GROWABLE_ARRAY result; - result.count = 0; - result.array = tag_array(allot_array(2,F)); - return result; -} - -#define GROWABLE_ARRAY(result) F_GROWABLE_ARRAY result##_g = make_growable_array(); \ - REGISTER_ROOT(result##_g.array) - -void growable_array_add(F_GROWABLE_ARRAY *result, CELL elt); - -#define GROWABLE_ARRAY_ADD(result,elt) \ - growable_array_add(&result##_g,elt) - -void growable_array_append(F_GROWABLE_ARRAY *result, F_ARRAY *elts); - -#define GROWABLE_ARRAY_APPEND(result,elts) \ - growable_array_append(&result##_g,elts) - -INLINE void growable_array_trim(F_GROWABLE_ARRAY *array) -{ - array->array = tag_array(reallot_array(untag_array_fast(array->array),array->count)); -} - -#define GROWABLE_ARRAY_TRIM(result) growable_array_trim(&result##_g) - -#define GROWABLE_ARRAY_DONE(result) \ - UNREGISTER_ROOT(result##_g.array); \ - CELL result = result##_g.array; diff --git a/vmpp/byte_arrays.cpp b/vmpp/byte_arrays.cpp index da44fc135b..389576e1ef 100644 --- a/vmpp/byte_arrays.cpp +++ b/vmpp/byte_arrays.cpp @@ -26,18 +26,34 @@ void primitive_resize_byte_array(void) dpush(tag_object(reallot_array(array,capacity))); } -void growable_byte_array_append(F_GROWABLE_BYTE_ARRAY *array, void *elts, CELL len) +void growable_byte_array::append_bytes(void *elts, CELL len) { - CELL new_size = array->count + len; - F_BYTE_ARRAY *underlying = untag_byte_array_fast(array->array); + CELL new_size = count + len; - if(new_size >= array_capacity(underlying)) - { - underlying = reallot_array(underlying,new_size * 2); - array->array = tag_object(underlying); - } + if(new_size >= array_capacity(array.untagged())) + array = reallot_array(array.untagged(),new_size * 2); - memcpy((void *)BREF(underlying,array->count),elts,len); + memcpy((void *)BREF(array.untagged(),count),elts,len); - array->count += len; + count += len; +} + +void growable_byte_array::append_byte_array(CELL byte_array_) +{ + gc_root byte_array(byte_array_); + + CELL len = array_capacity(byte_array.untagged()); + CELL new_size = count + len; + + if(new_size >= array_capacity(array.untagged())) + array = reallot_array(array.untagged(),new_size * 2); + + memcpy((void *)BREF(array.untagged(),count),byte_array.untagged() + 1,len); + + count += len; +} + +void growable_byte_array::trim() +{ + array = reallot_array(array.untagged(),count); } diff --git a/vmpp/byte_arrays.hpp b/vmpp/byte_arrays.hpp index fe0e5f7acd..6b89a16e48 100644 --- a/vmpp/byte_arrays.hpp +++ b/vmpp/byte_arrays.hpp @@ -7,22 +7,14 @@ void primitive_uninitialized_byte_array(void); void primitive_resize_byte_array(void); /* Macros to simulate a byte vector in C */ -struct F_GROWABLE_BYTE_ARRAY { +struct growable_byte_array { CELL count; - CELL array; + gc_root array; + + growable_byte_array() : count(0), array(allot_byte_array(2)) { } + + void append_bytes(void *elts, CELL len); + void append_byte_array(CELL elts); + + void trim(); }; - -INLINE F_GROWABLE_BYTE_ARRAY make_growable_byte_array(void) -{ - F_GROWABLE_BYTE_ARRAY result; - result.count = 0; - result.array = tag_object(allot_byte_array(2)); - return result; -} - -void growable_byte_array_append(F_GROWABLE_BYTE_ARRAY *result, void *elts, CELL len); - -INLINE void growable_byte_array_trim(F_GROWABLE_BYTE_ARRAY *byte_array) -{ - byte_array->array = tag_object(reallot_array(untag_byte_array_fast(byte_array->array),byte_array->count)); -} diff --git a/vmpp/callstack.cpp b/vmpp/callstack.cpp index 00f31b9b56..ff50186a7d 100755 --- a/vmpp/callstack.cpp +++ b/vmpp/callstack.cpp @@ -28,9 +28,7 @@ void iterate_callstack_object(F_CALLSTACK *stack, CALLSTACK_ITER iterator) F_CALLSTACK *allot_callstack(CELL size) { - F_CALLSTACK *callstack = (F_CALLSTACK *)allot_object( - CALLSTACK_TYPE, - callstack_size(size)); + F_CALLSTACK *callstack = allot(callstack_size(size)); callstack->length = tag_fixnum(size); return callstack; } @@ -158,17 +156,15 @@ void stack_frame_to_array(F_STACK_FRAME *frame) void primitive_callstack_to_array(void) { - F_CALLSTACK *stack = untag_callstack(dpop()); + gc_root callstack(dpop()); frame_count = 0; - iterate_callstack_object(stack,count_stack_frame); + iterate_callstack_object(callstack.untagged(),count_stack_frame); - REGISTER_UNTAGGED(stack); array = allot_array_internal(frame_count); - UNREGISTER_UNTAGGED(F_CALLSTACK,stack); frame_index = 0; - iterate_callstack_object(stack,stack_frame_to_array); + iterate_callstack_object(callstack.untagged(),stack_frame_to_array); dpush(tag_array(array)); } @@ -208,18 +204,12 @@ void primitive_innermost_stack_frame_scan(void) void primitive_set_innermost_stack_frame_quot(void) { - F_CALLSTACK *callstack = untag_callstack(dpop()); - F_QUOTATION *quot = untag_quotation(dpop()); + gc_root callstack(dpop()); + gc_root quot(dpop()); - REGISTER_UNTAGGED(callstack); - REGISTER_UNTAGGED(quot); + jit_compile(quot.value(),true); - jit_compile(tag_quotation(quot),true); - - UNREGISTER_UNTAGGED(F_QUOTATION,quot); - UNREGISTER_UNTAGGED(F_CALLSTACK,callstack); - - F_STACK_FRAME *inner = innermost_stack_frame(callstack); + F_STACK_FRAME *inner = innermost_stack_frame(callstack.untagged()); type_check(QUOTATION_TYPE,frame_executing(inner)); CELL offset = (char *)FRAME_RETURN_ADDRESS(inner) - (char *)inner->xt; diff --git a/vmpp/code_block.cpp b/vmpp/code_block.cpp index 7ef365f66b..4e42a2be84 100644 --- a/vmpp/code_block.cpp +++ b/vmpp/code_block.cpp @@ -454,47 +454,37 @@ F_CODE_BLOCK *allot_code_block(CELL size) /* Might GC */ F_CODE_BLOCK *add_code_block( CELL type, - F_BYTE_ARRAY *code, - F_ARRAY *labels, - CELL relocation, - CELL literals) + CELL code_, + CELL labels_, + CELL relocation_, + CELL literals_) { -#ifdef FACTOR_DEBUG - type_check(ARRAY_TYPE,literals); - type_check(BYTE_ARRAY_TYPE,relocation); - assert(untag_header(code->header) == BYTE_ARRAY_TYPE); -#endif - - CELL code_length = align8(array_capacity(code)); - - REGISTER_ROOT(literals); - REGISTER_ROOT(relocation); - REGISTER_UNTAGGED(code); - REGISTER_UNTAGGED(labels); + gc_root code(code_); + gc_root labels(labels_); + gc_root relocation(relocation_); + gc_root literals(literals_); + CELL code_length = align8(array_capacity(code.untagged())); F_CODE_BLOCK *compiled = allot_code_block(code_length); - UNREGISTER_UNTAGGED(F_ARRAY,labels); - UNREGISTER_UNTAGGED(F_BYTE_ARRAY,code); - UNREGISTER_ROOT(relocation); - UNREGISTER_ROOT(literals); - - /* slight space optimization */ - if(type_of(literals) == ARRAY_TYPE && array_capacity(untag_array_fast(literals)) == 0) - literals = F; - /* compiled header */ compiled->block.type = type; compiled->block.last_scan = NURSERY; compiled->block.needs_fixup = true; - compiled->literals = literals; - compiled->relocation = relocation; + compiled->relocation = relocation.value(); + + /* slight space optimization */ + if(literals.type() == ARRAY_TYPE && array_capacity(literals.untagged()) == 0) + compiled->literals = F; + else + compiled->literals = literals.value(); /* code */ - memcpy(compiled + 1,code + 1,code_length); + memcpy(compiled + 1,code.untagged() + 1,code_length); /* fixup labels */ - if(labels) fixup_labels(labels,compiled); + if(labels.value() != F) + fixup_labels(labels.as().untagged(),compiled); /* next time we do a minor GC, we have to scan the code heap for literals */ diff --git a/vmpp/code_block.hpp b/vmpp/code_block.hpp index a8350ad5cb..1115b9b891 100644 --- a/vmpp/code_block.hpp +++ b/vmpp/code_block.hpp @@ -84,9 +84,4 @@ INLINE bool stack_traces_p(void) return userenv[STACK_TRACES_ENV] != F; } -F_CODE_BLOCK *add_code_block( - CELL type, - F_BYTE_ARRAY *code, - F_ARRAY *labels, - CELL relocation, - CELL literals); +F_CODE_BLOCK *add_code_block(CELL type, CELL code, CELL labels, CELL relocation, CELL literals); diff --git a/vmpp/code_heap.cpp b/vmpp/code_heap.cpp index 1545dbeaf6..c1b6cdbc3e 100755 --- a/vmpp/code_heap.cpp +++ b/vmpp/code_heap.cpp @@ -15,15 +15,14 @@ bool in_code_heap_p(CELL ptr) } /* Compile a word definition with the non-optimizing compiler. Allocates memory */ -void jit_compile_word(F_WORD *word, CELL def, bool relocate) +void jit_compile_word(CELL word_, CELL def_, bool relocate) { - REGISTER_ROOT(def); - REGISTER_UNTAGGED(word); - jit_compile(def,relocate); - UNREGISTER_UNTAGGED(F_WORD,word); - UNREGISTER_ROOT(def); + gc_root word(word_); + gc_root def(def_); - word->code = untag_quotation(def)->code; + jit_compile(def.value(),relocate); + + word->code = def->code; if(word->direct_entry_def != F) jit_compile(word->direct_entry_def,relocate); @@ -58,40 +57,32 @@ void update_code_heap_words(void) void primitive_modify_code_heap(void) { - F_ARRAY *alist = untag_array(dpop()); + gc_root alist(dpop()); + + CELL count = array_capacity(alist.untagged()); - CELL count = untag_fixnum_fast(alist->capacity); if(count == 0) return; CELL i; for(i = 0; i < count; i++) { - F_ARRAY *pair = untag_array(array_nth(alist,i)); + gc_root pair(array_nth(alist.untagged(),i)); - F_WORD *word = untag_word(array_nth(pair,0)); + gc_root word(array_nth(pair.untagged(),0)); + gc_root data(array_nth(pair.untagged(),1)); - CELL data = array_nth(pair,1); - - if(type_of(data) == QUOTATION_TYPE) + switch(data.type()) { - REGISTER_UNTAGGED(alist); - REGISTER_UNTAGGED(word); - jit_compile_word(word,data,false); - UNREGISTER_UNTAGGED(F_WORD,word); - UNREGISTER_UNTAGGED(F_ARRAY,alist); - } - else if(type_of(data) == ARRAY_TYPE) - { - F_ARRAY *compiled_code = untag_array(data); - - CELL literals = array_nth(compiled_code,0); - CELL relocation = array_nth(compiled_code,1); - F_ARRAY *labels = untag_array(array_nth(compiled_code,2)); - F_BYTE_ARRAY *code = untag_byte_array(array_nth(compiled_code,3)); - - REGISTER_UNTAGGED(alist); - REGISTER_UNTAGGED(word); + case QUOTATION_TYPE: + jit_compile_word(word.value(),data.value(),false); + break; + case ARRAY_TYPE: + F_ARRAY *compiled_data = data.as().untagged(); + CELL literals = array_nth(compiled_data,0); + CELL relocation = array_nth(compiled_data,1); + CELL labels = array_nth(compiled_data,2); + CELL code = array_nth(compiled_data,3); F_CODE_BLOCK *compiled = add_code_block( WORD_TYPE, @@ -100,17 +91,14 @@ void primitive_modify_code_heap(void) relocation, literals); - UNREGISTER_UNTAGGED(F_WORD,word); - UNREGISTER_UNTAGGED(F_ARRAY,alist); - word->code = compiled; + break; + default: + critical_error("Expected a quotation or an array",data.value()); + break; } - else - critical_error("Expected a quotation or an array",data); - REGISTER_UNTAGGED(alist); - update_word_xt(word); - UNREGISTER_UNTAGGED(F_ARRAY,alist); + update_word_xt(word.value()); } update_code_heap_words(); @@ -184,10 +172,7 @@ void fixup_object_xts(void) while((obj = next_object()) != F) { if(type_of(obj) == WORD_TYPE) - { - F_WORD *word = untag_word_fast(obj); - update_word_xt(word); - } + update_word_xt(obj); else if(type_of(obj) == QUOTATION_TYPE) { F_QUOTATION *quot = untag_quotation_fast(obj); diff --git a/vmpp/code_heap.hpp b/vmpp/code_heap.hpp index e312d0ccd4..42571825be 100755 --- a/vmpp/code_heap.hpp +++ b/vmpp/code_heap.hpp @@ -5,7 +5,7 @@ void init_code_heap(CELL size); bool in_code_heap_p(CELL ptr); -void jit_compile_word(F_WORD *word, CELL def, bool relocate); +void jit_compile_word(CELL word, CELL def, bool relocate); typedef void (*CODE_HEAP_ITERATOR)(F_CODE_BLOCK *compiled); diff --git a/vmpp/data_gc.cpp b/vmpp/data_gc.cpp index 07242d4d56..634d44ab2c 100755 --- a/vmpp/data_gc.cpp +++ b/vmpp/data_gc.cpp @@ -179,7 +179,7 @@ void copy_registered_locals(void) } /* Copy roots over at the start of GC, namely various constants, stacks, -the user environment and extra roots registered with REGISTER_ROOT */ +the user environment and extra roots registered by local_roots.hpp */ void copy_roots(void) { copy_handle(&T); @@ -595,7 +595,7 @@ void primitive_gc(void) void primitive_gc_stats(void) { - GROWABLE_ARRAY(stats); + growable_array stats; CELL i; u64 total_gc_time = 0; @@ -603,25 +603,24 @@ void primitive_gc_stats(void) for(i = 0; i < MAX_GEN_COUNT; i++) { F_GC_STATS *s = &gc_stats[i]; - GROWABLE_ARRAY_ADD(stats,allot_cell(s->collections)); - GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(s->gc_time))); - GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(s->max_gc_time))); - GROWABLE_ARRAY_ADD(stats,allot_cell(s->collections == 0 ? 0 : s->gc_time / s->collections)); - GROWABLE_ARRAY_ADD(stats,allot_cell(s->object_count)); - GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(s->bytes_copied))); + stats.add(allot_cell(s->collections)); + stats.add(tag_bignum(long_long_to_bignum(s->gc_time))); + stats.add(tag_bignum(long_long_to_bignum(s->max_gc_time))); + stats.add(allot_cell(s->collections == 0 ? 0 : s->gc_time / s->collections)); + stats.add(allot_cell(s->object_count)); + stats.add(tag_bignum(long_long_to_bignum(s->bytes_copied))); total_gc_time += s->gc_time; } - GROWABLE_ARRAY_ADD(stats,tag_bignum(ulong_long_to_bignum(total_gc_time))); - GROWABLE_ARRAY_ADD(stats,tag_bignum(ulong_long_to_bignum(cards_scanned))); - GROWABLE_ARRAY_ADD(stats,tag_bignum(ulong_long_to_bignum(decks_scanned))); - GROWABLE_ARRAY_ADD(stats,tag_bignum(ulong_long_to_bignum(card_scan_time))); - GROWABLE_ARRAY_ADD(stats,allot_cell(code_heap_scans)); + stats.add(tag_bignum(ulong_long_to_bignum(total_gc_time))); + stats.add(tag_bignum(ulong_long_to_bignum(cards_scanned))); + stats.add(tag_bignum(ulong_long_to_bignum(decks_scanned))); + stats.add(tag_bignum(ulong_long_to_bignum(card_scan_time))); + stats.add(allot_cell(code_heap_scans)); - GROWABLE_ARRAY_TRIM(stats); - GROWABLE_ARRAY_DONE(stats); - dpush(stats); + stats.trim(); + dpush(stats.array.value()); } void clear_gc_stats(void) diff --git a/vmpp/data_gc.hpp b/vmpp/data_gc.hpp index 2978b20cf6..9dc3a77071 100755 --- a/vmpp/data_gc.hpp +++ b/vmpp/data_gc.hpp @@ -46,24 +46,24 @@ registers) does not run out of memory */ * It is up to the caller to fill in the object's fields in a meaningful * fashion! */ -INLINE void *allot_object(CELL type, CELL a) +INLINE void *allot_object(CELL header, CELL size) { #ifdef GC_DEBUG if(!gc_off) gc(); #endif - CELL *object; + F_OBJECT *object; - if(nursery.size - ALLOT_BUFFER_ZONE > a) + if(nursery.size - ALLOT_BUFFER_ZONE > size) { /* If there is insufficient room, collect the nursery */ - if(nursery.here + ALLOT_BUFFER_ZONE + a > nursery.end) + if(nursery.here + ALLOT_BUFFER_ZONE + size > nursery.end) garbage_collection(NURSERY,false,0); CELL h = nursery.here; - nursery.here = h + align8(a); - object = (CELL*)h; + nursery.here = h + align8(size); + object = (F_OBJECT *)h; } /* If the object is bigger than the nursery, allocate it in tenured space */ @@ -72,20 +72,20 @@ INLINE void *allot_object(CELL type, CELL a) F_ZONE *tenured = &data_heap->generations[TENURED]; /* If tenured space does not have enough room, collect */ - if(tenured->here + a > tenured->end) + if(tenured->here + size > tenured->end) { gc(); tenured = &data_heap->generations[TENURED]; } /* If it still won't fit, grow the heap */ - if(tenured->here + a > tenured->end) + if(tenured->here + size > tenured->end) { - garbage_collection(TENURED,true,a); + garbage_collection(TENURED,true,size); tenured = &data_heap->generations[TENURED]; } - object = (CELL *)allot_zone(tenured,a); + object = (F_OBJECT *)allot_zone(tenured,size); /* We have to do this */ allot_barrier((CELL)object); @@ -96,10 +96,15 @@ INLINE void *allot_object(CELL type, CELL a) write_barrier((CELL)object); } - *object = tag_header(type); + object->header = header; return object; } +template T *allot(CELL size) +{ + return (T *)allot_object(tag_header(T::type_number),size); +} + void copy_reachable_objects(CELL scan, CELL *end); void primitive_gc(void); diff --git a/vmpp/data_heap.cpp b/vmpp/data_heap.cpp index c02c1c2a2f..a3ba93ee58 100644 --- a/vmpp/data_heap.cpp +++ b/vmpp/data_heap.cpp @@ -301,19 +301,18 @@ void primitive_data_room(void) dpush(tag_fixnum((data_heap->cards_end - data_heap->cards) >> 10)); dpush(tag_fixnum((data_heap->decks_end - data_heap->decks) >> 10)); - GROWABLE_ARRAY(a); + growable_array a; CELL gen; for(gen = 0; gen < data_heap->gen_count; gen++) { F_ZONE *z = (gen == NURSERY ? &nursery : &data_heap->generations[gen]); - GROWABLE_ARRAY_ADD(a,tag_fixnum((z->end - z->here) >> 10)); - GROWABLE_ARRAY_ADD(a,tag_fixnum((z->size) >> 10)); + a.add(tag_fixnum((z->end - z->here) >> 10)); + a.add(tag_fixnum((z->size) >> 10)); } - GROWABLE_ARRAY_TRIM(a); - GROWABLE_ARRAY_DONE(a); - dpush(a); + a.trim(); + dpush(a.array.value()); } /* A heap walk allows useful things to be done, like finding all @@ -364,7 +363,7 @@ void primitive_end_scan(void) CELL find_all_words(void) { - GROWABLE_ARRAY(words); + growable_array words; begin_scan(); @@ -372,14 +371,12 @@ CELL find_all_words(void) while((obj = next_object()) != F) { if(type_of(obj) == WORD_TYPE) - GROWABLE_ARRAY_ADD(words,obj); + words.add(obj); } /* End heap scan */ gc_off = false; - GROWABLE_ARRAY_TRIM(words); - GROWABLE_ARRAY_DONE(words); - - return words; + words.trim(); + return words.array.value(); } diff --git a/vmpp/data_heap.hpp b/vmpp/data_heap.hpp index 4753db6d61..3b4231d98f 100644 --- a/vmpp/data_heap.hpp +++ b/vmpp/data_heap.hpp @@ -2,16 +2,16 @@ extern bool secure_gc; /* generational copying GC divides memory into zones */ -typedef struct { +struct F_ZONE { /* allocation pointer is 'here'; its offset is hardcoded in the - compiler backends*/ + compiler backends */ CELL start; CELL here; CELL size; CELL end; -} F_ZONE; +}; -typedef struct { +struct F_DATA_HEAP { F_SEGMENT *segment; CELL young_size; @@ -31,7 +31,7 @@ typedef struct { CELL *decks; CELL *decks_end; -} F_DATA_HEAP; +}; extern F_DATA_HEAP *data_heap; diff --git a/vmpp/dispatch.cpp b/vmpp/dispatch.cpp index a759894b22..fc76d8b34e 100644 --- a/vmpp/dispatch.cpp +++ b/vmpp/dispatch.cpp @@ -167,39 +167,35 @@ void primitive_reset_dispatch_stats(void) void primitive_dispatch_stats(void) { - GROWABLE_ARRAY(stats); - GROWABLE_ARRAY_ADD(stats,allot_cell(megamorphic_cache_hits)); - GROWABLE_ARRAY_ADD(stats,allot_cell(megamorphic_cache_misses)); - GROWABLE_ARRAY_TRIM(stats); - GROWABLE_ARRAY_DONE(stats); - dpush(stats); + growable_array stats; + stats.add(allot_cell(megamorphic_cache_hits)); + stats.add(allot_cell(megamorphic_cache_misses)); + stats.trim(); + dpush(stats.array.value()); } -void jit_emit_class_lookup(F_JIT *jit, F_FIXNUM index, CELL type) +void quotation_jit::emit_mega_cache_lookup(CELL methods_, F_FIXNUM index, CELL cache_) { - jit_emit_with(jit,userenv[PIC_LOAD],tag_fixnum(-index * CELLS)); - jit_emit(jit,userenv[type]); -} + gc_root methods(methods_); + gc_root cache(cache_); -void jit_emit_mega_cache_lookup(F_JIT *jit, CELL methods, F_FIXNUM index, CELL cache) -{ /* Generate machine code to determine the object's class. */ - jit_emit_class_lookup(jit,index,PIC_HI_TAG_TUPLE); + emit_class_lookup(index,PIC_HI_TAG_TUPLE); /* Do a cache lookup. */ - jit_emit_with(jit,userenv[MEGA_LOOKUP],cache); + emit_with(userenv[MEGA_LOOKUP],cache.value()); /* If we end up here, the cache missed. */ - jit_emit(jit,userenv[JIT_PROLOG]); + emit(userenv[JIT_PROLOG]); /* Push index, method table and cache on the stack. */ - jit_push(jit,methods); - jit_push(jit,tag_fixnum(index)); - jit_push(jit,cache); - jit_word_call(jit,userenv[MEGA_MISS_WORD]); + push(methods.value()); + push(tag_fixnum(index)); + push(cache.value()); + word_call(userenv[MEGA_MISS_WORD]); /* Now the new method has been stored into the cache, and its on the stack. */ - jit_emit(jit,userenv[JIT_EPILOG]); - jit_emit(jit,userenv[JIT_EXECUTE_JUMP]); + emit(userenv[JIT_EPILOG]); + emit(userenv[JIT_EXECUTE_JUMP]); } diff --git a/vmpp/dispatch.hpp b/vmpp/dispatch.hpp index 10c9c6b320..be1359fc15 100644 --- a/vmpp/dispatch.hpp +++ b/vmpp/dispatch.hpp @@ -8,6 +8,6 @@ void primitive_mega_cache_miss(void); void primitive_reset_dispatch_stats(void); void primitive_dispatch_stats(void); -void jit_emit_class_lookup(F_JIT *jit, F_FIXNUM index, CELL type); +void jit_emit_class_lookup(jit *jit, F_FIXNUM index, CELL type); -void jit_emit_mega_cache_lookup(F_JIT *jit, CELL methods, F_FIXNUM index, CELL cache); +void jit_emit_mega_cache_lookup(jit *jit, CELL methods, F_FIXNUM index, CELL cache); diff --git a/vmpp/factor.cpp b/vmpp/factor.cpp index 2321a7cc1f..147dff913b 100755 --- a/vmpp/factor.cpp +++ b/vmpp/factor.cpp @@ -152,18 +152,14 @@ void init_factor(F_PARAMETERS *p) /* May allocate memory */ void pass_args_to_factor(int argc, F_CHAR **argv) { - F_ARRAY *args = allot_array(argc,F); + growable_array args; int i; for(i = 1; i < argc; i++) - { - REGISTER_UNTAGGED(args); - CELL arg = tag_object(from_native_string(argv[i])); - UNREGISTER_UNTAGGED(F_ARRAY,args); - set_array_nth(args,i,arg); - } + args.add(tag_object(from_native_string(argv[i]))); - userenv[ARGS_ENV] = tag_array(args); + args.trim(); + userenv[ARGS_ENV] = args.array.value(); } void start_factor(F_PARAMETERS *p) diff --git a/vmpp/generic_arrays.hpp b/vmpp/generic_arrays.hpp index 1c505acea1..ac5a353d83 100644 --- a/vmpp/generic_arrays.hpp +++ b/vmpp/generic_arrays.hpp @@ -41,7 +41,7 @@ template CELL array_size(T *array) template T *allot_array_internal(CELL capacity) { - T *array = (T *)allot_object(T::type_number,array_size(capacity)); + T *array = allot(array_size(capacity)); array->capacity = tag_fixnum(capacity); return array; } @@ -51,29 +51,24 @@ template bool reallot_array_in_place_p(T *array, CELL capacity) return in_zone(&nursery,(CELL)array) && capacity <= array_capacity(array); } -template T *reallot_array(T *array, CELL capacity) +template T *reallot_array(T *array_, CELL capacity) { -#ifdef FACTOR_DEBUG - CELL header = untag_header(array->header); - assert(header == T::type_number); -#endif + gc_root array(array_); - if(reallot_array_in_place_p(array,capacity)) + if(reallot_array_in_place_p(array.untagged(),capacity)) { array->capacity = tag_fixnum(capacity); - return array; + return array.untagged(); } else { - CELL to_copy = array_capacity(array); + CELL to_copy = array_capacity(array.untagged()); if(capacity < to_copy) to_copy = capacity; - REGISTER_UNTAGGED(array); T *new_array = allot_array_internal(capacity); - UNREGISTER_UNTAGGED(T,array); - memcpy(new_array + 1,array + 1,to_copy * T::element_size); + memcpy(new_array + 1,array.untagged() + 1,to_copy * T::element_size); memset((char *)(new_array + 1) + to_copy * T::element_size, 0,(capacity - to_copy) * T::element_size); diff --git a/vmpp/inline_cache.cpp b/vmpp/inline_cache.cpp index d1835231ad..cfdae972b0 100644 --- a/vmpp/inline_cache.cpp +++ b/vmpp/inline_cache.cpp @@ -33,16 +33,14 @@ void deallocate_inline_cache(CELL return_address) /* Figure out what kind of type check the PIC needs based on the methods it contains */ -static CELL determine_inline_cache_type(CELL cache_entries) +static CELL determine_inline_cache_type(F_ARRAY *cache_entries) { - F_ARRAY *array = untag_array_fast(cache_entries); - - bool seen_hi_tag = false, seen_tuple = false; + bool seen_hi_tag = false, seen_tuple = false; CELL i; - for(i = 0; i < array_capacity(array); i += 2) + for(i = 0; i < array_capacity(cache_entries); i += 2) { - CELL klass = array_nth(array,i); + CELL klass = array_nth(cache_entries,i); F_FIXNUM type; /* Is it a tuple layout? */ @@ -76,7 +74,16 @@ static void update_pic_count(CELL type) pic_counts[type - PIC_TAG]++; } -static void jit_emit_check(F_JIT *jit, CELL klass) +struct inline_cache_jit : public jit { + F_FIXNUM index; + + inline_cache_jit(CELL generic_word_) : jit(PIC_TYPE,generic_word_) {}; + + void emit_check(CELL klass); + void compile_inline_cache(F_FIXNUM index, CELL generic_word_, CELL methods_, CELL cache_entries_); +}; + +void inline_cache_jit::emit_check(CELL klass) { CELL code_template; if(TAG(klass) == FIXNUM_TYPE && untag_fixnum_fast(klass) < HEADER_TYPE) @@ -84,43 +91,34 @@ static void jit_emit_check(F_JIT *jit, CELL klass) else code_template = userenv[PIC_CHECK]; - jit_emit_with(jit,code_template,klass); + emit_with(code_template,klass); } /* index: 0 = top of stack, 1 = item underneath, etc cache_entries: array of class/method pairs */ -static F_CODE_BLOCK *compile_inline_cache(F_FIXNUM index, CELL generic_word, CELL methods, CELL cache_entries) +void inline_cache_jit::compile_inline_cache(F_FIXNUM index, CELL generic_word_, CELL methods_, CELL cache_entries_) { -#ifdef FACTOR_DEBUG - type_check(WORD_TYPE,generic_word); - type_check(ARRAY_TYPE,cache_entries); -#endif - - REGISTER_ROOT(generic_word); - REGISTER_ROOT(methods); - REGISTER_ROOT(cache_entries); - - CELL inline_cache_type = determine_inline_cache_type(cache_entries); + gc_root generic_word(generic_word_); + gc_root methods(methods_); + gc_root cache_entries(cache_entries_); + CELL inline_cache_type = determine_inline_cache_type(cache_entries.untagged()); update_pic_count(inline_cache_type); - F_JIT jit; - jit_init(&jit,PIC_TYPE,generic_word); - /* Generate machine code to determine the object's class. */ - jit_emit_class_lookup(&jit,index,inline_cache_type); + emit_class_lookup(index,inline_cache_type); /* Generate machine code to check, in turn, if the class is one of the cached entries. */ CELL i; - for(i = 0; i < array_capacity(untag_array_fast(cache_entries)); i += 2) + for(i = 0; i < array_capacity(cache_entries.untagged()); i += 2) { /* Class equal? */ - CELL klass = array_nth(untag_array_fast(cache_entries),i); - jit_emit_check(&jit,klass); + CELL klass = array_nth(cache_entries.untagged(),i); + emit_check(klass); /* Yes? Jump to method */ - CELL method = array_nth(untag_array_fast(cache_entries),i + 1); - jit_emit_with(&jit,userenv[PIC_HIT],method); + CELL method = array_nth(cache_entries.untagged(),i + 1); + emit_with(userenv[PIC_HIT],method); } /* Generate machine code to handle a cache miss, which ultimately results in @@ -128,21 +126,26 @@ static F_CODE_BLOCK *compile_inline_cache(F_FIXNUM index, CELL generic_word, CEL The inline-cache-miss primitive call receives enough information to reconstruct the PIC. */ - jit_push(&jit,generic_word); - jit_push(&jit,methods); - jit_push(&jit,tag_fixnum(index)); - jit_push(&jit,cache_entries); - jit_word_jump(&jit,userenv[PIC_MISS_WORD]); + push(generic_word.value()); + push(methods.value()); + push(tag_fixnum(index)); + push(cache_entries.value()); + word_jump(userenv[PIC_MISS_WORD]); +} - F_CODE_BLOCK *code = jit_make_code_block(&jit); +static F_CODE_BLOCK *compile_inline_cache(F_FIXNUM index, + CELL generic_word_, + CELL methods_, + CELL cache_entries_) +{ + gc_root generic_word(generic_word_); + gc_root methods(methods_); + gc_root cache_entries(cache_entries_); + + inline_cache_jit jit(generic_word.value()); + jit.compile_inline_cache(index,generic_word.value(),methods.value(),cache_entries.value()); + F_CODE_BLOCK *code = jit.code_block(); relocate_code_block(code); - - jit_dispose(&jit); - - UNREGISTER_ROOT(cache_entries); - UNREGISTER_ROOT(methods); - UNREGISTER_ROOT(generic_word); - return code; } @@ -154,23 +157,21 @@ static XT megamorphic_call_stub(CELL generic_word) static CELL inline_cache_size(CELL cache_entries) { - return (cache_entries == F ? 0 : array_capacity(untag_array(cache_entries)) / 2); + return array_capacity(untag_array(cache_entries)) / 2; } /* Allocates memory */ -static CELL add_inline_cache_entry(CELL cache_entries, CELL klass, CELL method) +static CELL add_inline_cache_entry(CELL cache_entries_, CELL klass_, CELL method_) { - if(cache_entries == F) - return allot_array_2(klass,method); - else - { - F_ARRAY *cache_entries_array = untag_array_fast(cache_entries); - CELL pic_size = array_capacity(cache_entries_array); - cache_entries_array = reallot_array(cache_entries_array,pic_size + 2); - set_array_nth(cache_entries_array,pic_size,klass); - set_array_nth(cache_entries_array,pic_size + 1,method); - return tag_array(cache_entries_array); - } + gc_root cache_entries(cache_entries_); + gc_root klass(klass_); + gc_root method(method_); + + CELL pic_size = array_capacity(cache_entries.untagged()); + gc_root new_cache_entries(reallot_array(cache_entries.untagged(),pic_size + 2)); + set_array_nth(new_cache_entries.untagged(),pic_size,klass.value()); + set_array_nth(new_cache_entries.untagged(),pic_size + 1,method.value()); + return new_cache_entries.value(); } static void update_pic_transitions(CELL pic_size) @@ -194,35 +195,33 @@ XT inline_cache_miss(CELL return_address) instead of leaving dead PICs around until the next GC. */ deallocate_inline_cache(return_address); - CELL cache_entries = dpop(); + gc_root cache_entries(dpop()); F_FIXNUM index = untag_fixnum_fast(dpop()); - CELL methods = dpop(); - CELL generic_word = dpop(); - CELL object = get(ds - index * CELLS); + gc_root methods(dpop()); + gc_root generic_word(dpop()); + gc_root object(get(ds - index * CELLS)); XT xt; - CELL pic_size = inline_cache_size(cache_entries); + CELL pic_size = inline_cache_size(cache_entries.value()); update_pic_transitions(pic_size); if(pic_size >= max_pic_size) - xt = megamorphic_call_stub(generic_word); + xt = megamorphic_call_stub(generic_word.value()); else { - REGISTER_ROOT(generic_word); - REGISTER_ROOT(cache_entries); - REGISTER_ROOT(methods); + CELL klass = object_class(object.value()); + CELL method = lookup_method(object.value(),methods.value()); - CELL klass = object_class(object); - CELL method = lookup_method(object,methods); - - cache_entries = add_inline_cache_entry(cache_entries,klass,method); - xt = compile_inline_cache(index,generic_word,methods,cache_entries) + 1; - - UNREGISTER_ROOT(methods); - UNREGISTER_ROOT(cache_entries); - UNREGISTER_ROOT(generic_word); + gc_root new_cache_entries(add_inline_cache_entry( + cache_entries.value(), + klass, + method)); + xt = compile_inline_cache(index, + generic_word.value(), + methods.value(), + new_cache_entries.value()) + 1; } /* Install the new stub. */ @@ -244,14 +243,13 @@ void primitive_reset_inline_cache_stats(void) void primitive_inline_cache_stats(void) { - GROWABLE_ARRAY(stats); - GROWABLE_ARRAY_ADD(stats,allot_cell(cold_call_to_ic_transitions)); - GROWABLE_ARRAY_ADD(stats,allot_cell(ic_to_pic_transitions)); - GROWABLE_ARRAY_ADD(stats,allot_cell(pic_to_mega_transitions)); + growable_array stats; + stats.add(allot_cell(cold_call_to_ic_transitions)); + stats.add(allot_cell(ic_to_pic_transitions)); + stats.add(allot_cell(pic_to_mega_transitions)); CELL i; for(i = 0; i < 4; i++) - GROWABLE_ARRAY_ADD(stats,allot_cell(pic_counts[i])); - GROWABLE_ARRAY_TRIM(stats); - GROWABLE_ARRAY_DONE(stats); - dpush(stats); + stats.add(allot_cell(pic_counts[i])); + stats.trim(); + dpush(stats.array.value()); } diff --git a/vmpp/io.cpp b/vmpp/io.cpp index a48b252e2a..4a61a317c2 100755 --- a/vmpp/io.cpp +++ b/vmpp/io.cpp @@ -85,11 +85,11 @@ void primitive_fread(void) return; } - F_BYTE_ARRAY *buf = allot_byte_array(size); + gc_root buf(allot_array_internal(size)); for(;;) { - int c = fread(buf + 1,1,size,file); + int c = fread(buf.untagged() + 1,1,size,file); if(c <= 0) { if(feof(file)) @@ -104,13 +104,11 @@ void primitive_fread(void) { if(c != size) { - REGISTER_UNTAGGED(buf); F_BYTE_ARRAY *new_buf = allot_byte_array(c); - UNREGISTER_UNTAGGED(F_BYTE_ARRAY,buf); - memcpy(new_buf + 1, buf + 1,c); + memcpy(new_buf + 1, buf.untagged() + 1,c); buf = new_buf; } - dpush(tag_object(buf)); + dpush(buf.value()); break; } } diff --git a/vmpp/jit.cpp b/vmpp/jit.cpp index d5196ed663..e9018af682 100644 --- a/vmpp/jit.cpp +++ b/vmpp/jit.cpp @@ -1,68 +1,26 @@ #include "master.hpp" /* Simple code generator used by: -- profiler (profiler.c), -- quotation compiler (quotations.c), -- megamorphic caches (dispatch.c), -- polymorphic inline caches (inline_cache.c) */ +- profiler (profiler.cpp), +- quotation compiler (quotations.cpp), +- megamorphic caches (dispatch.cpp), +- polymorphic inline caches (inline_cache.cpp) */ /* Allocates memory */ -void jit_init(F_JIT *jit, CELL jit_type, CELL owner) +jit::jit(CELL type_, CELL owner_) + : type(type_), + owner(owner_), + code(), + relocation(), + literals(), + computing_offset_p(false), + position(0), + offset(0) { - jit->owner = owner; - REGISTER_ROOT(jit->owner); - - jit->type = jit_type; - - jit->code = make_growable_byte_array(); - REGISTER_ROOT(jit->code.array); - jit->relocation = make_growable_byte_array(); - REGISTER_ROOT(jit->relocation.array); - jit->literals = make_growable_array(); - REGISTER_ROOT(jit->literals.array); - - if(stack_traces_p()) - growable_array_add(&jit->literals,jit->owner); - - jit->computing_offset_p = false; + if(stack_traces_p()) literal(owner.value()); } -/* Facility to convert compiled code offsets to quotation offsets. -Call jit_compute_offset() with the compiled code offset, then emit -code, and at the end jit->position is the quotation position. */ -void jit_compute_position(F_JIT *jit, CELL offset) -{ - jit->computing_offset_p = true; - jit->position = 0; - jit->offset = offset; -} - -/* Allocates memory */ -F_CODE_BLOCK *jit_make_code_block(F_JIT *jit) -{ - growable_byte_array_trim(&jit->code); - growable_byte_array_trim(&jit->relocation); - growable_array_trim(&jit->literals); - - F_CODE_BLOCK *code = add_code_block( - jit->type, - untag_byte_array_fast(jit->code.array), - NULL, /* no labels */ - jit->relocation.array, - jit->literals.array); - - return code; -} - -void jit_dispose(F_JIT *jit) -{ - UNREGISTER_ROOT(jit->literals.array); - UNREGISTER_ROOT(jit->relocation.array); - UNREGISTER_ROOT(jit->code.array); - UNREGISTER_ROOT(jit->owner); -} - -static F_REL rel_to_emit(F_JIT *jit, CELL code_template, bool *rel_p) +F_REL jit::rel_to_emit(CELL code_template, bool *rel_p) { F_ARRAY *quadruple = untag_array_fast(code_template); CELL rel_class = array_nth(quadruple,1); @@ -79,45 +37,78 @@ static F_REL rel_to_emit(F_JIT *jit, CELL code_template, bool *rel_p) *rel_p = true; return (untag_fixnum_fast(rel_type) << 28) | (untag_fixnum_fast(rel_class) << 24) - | ((jit->code.count + untag_fixnum_fast(offset))); + | ((code.count + untag_fixnum_fast(offset))); } } /* Allocates memory */ -void jit_emit(F_JIT *jit, CELL code_template) +void jit::emit(CELL code_template_) { -#ifdef FACTOR_DEBUG - type_check(ARRAY_TYPE,code_template); -#endif - - REGISTER_ROOT(code_template); + gc_root code_template(code_template_); bool rel_p; - F_REL rel = rel_to_emit(jit,code_template,&rel_p); - if(rel_p) growable_byte_array_append(&jit->relocation,&rel,sizeof(F_REL)); + F_REL rel = rel_to_emit(code_template.value(),&rel_p); + if(rel_p) relocation.append_bytes(&rel,sizeof(F_REL)); - F_BYTE_ARRAY *code = code_to_emit(code_template); + gc_root insns(array_nth(code_template.untagged(),0)); - if(jit->computing_offset_p) + if(computing_offset_p) { - CELL size = array_capacity(code); + CELL size = array_capacity(insns.untagged()); - if(jit->offset == 0) + if(offset == 0) { - jit->position--; - jit->computing_offset_p = false; + position--; + computing_offset_p = false; } - else if(jit->offset < size) + else if(offset < size) { - jit->position++; - jit->computing_offset_p = false; + position++; + computing_offset_p = false; } else - jit->offset -= size; + offset -= size; } - growable_byte_array_append(&jit->code,code + 1,array_capacity(code)); - - UNREGISTER_ROOT(code_template); + code.append_byte_array(insns.value()); } +void jit::emit_with(CELL code_template_, CELL argument_) { + gc_root code_template(code_template_); + gc_root argument(argument_); + literal(argument.value()); + emit(code_template.value()); +} + +void jit::emit_class_lookup(F_FIXNUM index, CELL type) +{ + emit_with(userenv[PIC_LOAD],tag_fixnum(-index * CELLS)); + emit(userenv[type]); +} + +/* Facility to convert compiled code offsets to quotation offsets. +Call jit_compute_offset() with the compiled code offset, then emit +code, and at the end jit->position is the quotation position. */ +void jit::compute_position(CELL offset_) +{ + computing_offset_p = true; + position = 0; + offset = offset_; +} + +/* Allocates memory */ +F_CODE_BLOCK *jit::code_block() +{ + code.trim(); + relocation.trim(); + literals.trim(); + + return add_code_block( + type, + code.array.value(), + F, /* no labels */ + relocation.array.value(), + literals.array.value()); +} + + diff --git a/vmpp/jit.hpp b/vmpp/jit.hpp index e6219ed8c7..a2233aa4fb 100644 --- a/vmpp/jit.hpp +++ b/vmpp/jit.hpp @@ -1,92 +1,58 @@ -typedef struct { +struct jit { CELL type; - CELL owner; - F_GROWABLE_BYTE_ARRAY code; - F_GROWABLE_BYTE_ARRAY relocation; - F_GROWABLE_ARRAY literals; + gc_root owner; + growable_byte_array code; + growable_byte_array relocation; + growable_array literals; bool computing_offset_p; F_FIXNUM position; CELL offset; -} F_JIT; -void jit_init(F_JIT *jit, CELL jit_type, CELL owner); + jit(CELL jit_type, CELL owner); + void compute_position(CELL offset); -void jit_compute_position(F_JIT *jit, CELL offset); + F_REL rel_to_emit(CELL code_template, bool *rel_p); + void emit(CELL code_template); -F_CODE_BLOCK *jit_make_code_block(F_JIT *jit); + void literal(CELL literal) { literals.add(literal); } + void emit_with(CELL code_template_, CELL literal_); -void jit_dispose(F_JIT *jit); - -INLINE F_BYTE_ARRAY *code_to_emit(CELL code_template) -{ - return untag_byte_array_fast(array_nth(untag_array_fast(code_template),0)); -} - -void jit_emit(F_JIT *jit, CELL code_template); - -/* Allocates memory */ -INLINE void jit_add_literal(F_JIT *jit, CELL literal) -{ -#ifdef FACTOR_DEBUG - type_of(literal); -#endif - growable_array_add(&jit->literals,literal); -} - -/* Allocates memory */ -INLINE void jit_emit_with(F_JIT *jit, CELL code_template, CELL argument) -{ - REGISTER_ROOT(code_template); - jit_add_literal(jit,argument); - UNREGISTER_ROOT(code_template); - jit_emit(jit,code_template); -} - -/* Allocates memory */ -INLINE void jit_push(F_JIT *jit, CELL literal) -{ - jit_emit_with(jit,userenv[JIT_PUSH_IMMEDIATE],literal); -} - -/* Allocates memory */ -INLINE void jit_word_jump(F_JIT *jit, CELL word) -{ - jit_emit_with(jit,userenv[JIT_WORD_JUMP],word); -} - -/* Allocates memory */ -INLINE void jit_word_call(F_JIT *jit, CELL word) -{ - jit_emit_with(jit,userenv[JIT_WORD_CALL],word); -} - -/* Allocates memory */ -INLINE void jit_emit_subprimitive(F_JIT *jit, CELL word) -{ - CELL code_template = untag_word_fast(word)->subprimitive; - REGISTER_ROOT(code_template); - - if(array_nth(untag_array_fast(code_template),1) != F) - jit_add_literal(jit,T); - - jit_emit(jit,code_template); - UNREGISTER_ROOT(code_template); -} - -INLINE F_FIXNUM jit_get_position(F_JIT *jit) -{ - if(jit->computing_offset_p) - { - /* If this is still on, jit_emit() didn't clear it, - so the offset was out of bounds */ - return -1; + void push(CELL literal) { + emit_with(userenv[JIT_PUSH_IMMEDIATE],literal); } - else - return jit->position; -} -INLINE void jit_set_position(F_JIT *jit, F_FIXNUM position) -{ - if(jit->computing_offset_p) - jit->position = position; -} + void word_jump(CELL word) { + emit_with(userenv[JIT_WORD_JUMP],word); + } + + void word_call(CELL word) { + emit_with(userenv[JIT_WORD_CALL],word); + } + + void emit_subprimitive(CELL word) { + gc_root code_template(untagged(word)->subprimitive); + if(array_nth(code_template.untagged(),1) != F) literal(T); + emit(code_template.value()); + } + + void emit_class_lookup(F_FIXNUM index, CELL type); + + F_FIXNUM get_position() { + if(computing_offset_p) + { + /* If this is still on, emit() didn't clear it, + so the offset was out of bounds */ + return -1; + } + else + return position; + } + + void set_position(F_FIXNUM position_) { + if(computing_offset_p) + position = position_; + } + + + F_CODE_BLOCK *code_block(); +}; diff --git a/vmpp/layouts.hpp b/vmpp/layouts.hpp index 75f91c41e5..340d9d3f77 100755 --- a/vmpp/layouts.hpp +++ b/vmpp/layouts.hpp @@ -81,6 +81,7 @@ INLINE CELL tag_fixnum(F_FIXNUM untagged) typedef void *XT; struct F_OBJECT { + static const CELL type_number = TYPE_COUNT; CELL header; }; diff --git a/vmpp/local_roots.hpp b/vmpp/local_roots.hpp index 2a5d3559e5..6dee443f78 100644 --- a/vmpp/local_roots.hpp +++ b/vmpp/local_roots.hpp @@ -7,28 +7,19 @@ extern CELL gc_locals; DEFPUSHPOP(gc_local_,gc_locals) template -class gc_root : public tagged +struct gc_root : public tagged { void push() { gc_local_push((CELL)this); } -public: + explicit gc_root(CELL value_) : tagged(value_) { push(); } explicit gc_root(T *value_) : tagged(value_) { push(); } - gc_root(const gc_root& copy) : tagged(copy.untag()) {} + + const gc_root& operator=(const T *x) { tagged::operator=(x); return *this; } + const gc_root& operator=(const CELL &x) { tagged::operator=(x); return *this; } + ~gc_root() { CELL old = gc_local_pop(); assert(old == (CELL)this); } }; -#define REGISTER_ROOT(obj) \ - { \ - if(!immediate_p(obj)) \ - check_data_pointer(obj); \ - gc_local_push((CELL)&(obj)); \ - } -#define UNREGISTER_ROOT(obj) \ - { \ - if(gc_local_pop() != (CELL)&(obj)) \ - critical_error("Mismatched REGISTER_ROOT/UNREGISTER_ROOT",0); \ - } - /* Extra roots: stores pointers to objects in the heap. Requires extra work (you have to unregister before accessing the object) but more flexible. */ extern F_SEGMENT *extra_roots_region; @@ -36,9 +27,6 @@ extern CELL extra_roots; DEFPUSHPOP(root_,extra_roots) -#define REGISTER_UNTAGGED(obj) root_push(obj ? RETAG(obj,OBJECT_TYPE) : 0) -#define UNREGISTER_UNTAGGED(type,obj) obj = (type *)UNTAG(root_pop()) - /* We ignore strings which point outside the data heap, but we might be given a char* which points inside the data heap, in which case it is a root, for example if we call unbox_char_string() the result is placed in a byte array */ diff --git a/vmpp/master.hpp b/vmpp/master.hpp index 3ba7b70813..172886c946 100644 --- a/vmpp/master.hpp +++ b/vmpp/master.hpp @@ -21,10 +21,10 @@ #include #include "layouts.hpp" -#include "tagged.hpp" #include "platform.hpp" #include "primitives.hpp" #include "run.hpp" +#include "tagged.hpp" #include "profiler.hpp" #include "errors.hpp" #include "bignumint.hpp" @@ -50,8 +50,8 @@ #include "image.hpp" #include "callstack.hpp" #include "alien.hpp" -#include "quotations.hpp" #include "jit.hpp" +#include "quotations.hpp" #include "dispatch.hpp" #include "inline_cache.hpp" #include "factor.hpp" diff --git a/vmpp/math.hpp b/vmpp/math.hpp index 2f80cc7732..20c762d485 100644 --- a/vmpp/math.hpp +++ b/vmpp/math.hpp @@ -96,7 +96,7 @@ INLINE double untag_float(CELL tagged) INLINE CELL allot_float(double n) { - F_FLOAT* flo = (F_FLOAT *)allot_object(FLOAT_TYPE,sizeof(F_FLOAT)); + F_FLOAT *flo = allot(sizeof(F_FLOAT)); flo->n = n; return RETAG(flo,FLOAT_TYPE); } diff --git a/vmpp/profiler.cpp b/vmpp/profiler.cpp index 9a78ae57e7..0dea08254b 100755 --- a/vmpp/profiler.cpp +++ b/vmpp/profiler.cpp @@ -8,16 +8,14 @@ void init_profiler(void) } /* Allocates memory */ -F_CODE_BLOCK *compile_profiling_stub(CELL word) +F_CODE_BLOCK *compile_profiling_stub(CELL word_) { - REGISTER_ROOT(word); - F_JIT jit; - jit_init(&jit,WORD_TYPE,word); - jit_emit_with(&jit,userenv[JIT_PROFILING],word); - F_CODE_BLOCK *block = jit_make_code_block(&jit); - jit_dispose(&jit); - UNREGISTER_ROOT(word); - return block; + gc_root word(word_); + + jit jit(WORD_TYPE,word.value()); + jit.emit_with(userenv[JIT_PROFILING],word.value()); + + return jit.code_block(); } /* Allocates memory */ @@ -32,22 +30,18 @@ static void set_profiling(bool profiling) and allocate profiling blocks if necessary */ gc(); - CELL words = find_all_words(); - - REGISTER_ROOT(words); + gc_root words(find_all_words()); CELL i; - CELL length = array_capacity(untag_array_fast(words)); + CELL length = array_capacity(words.untagged()); for(i = 0; i < length; i++) { - F_WORD *word = untag_word(array_nth(untag_array(words),i)); + tagged word(array_nth(words.untagged(),i)); if(profiling) word->counter = tag_fixnum(0); - update_word_xt(word); + update_word_xt(word.value()); } - UNREGISTER_ROOT(words); - /* Update XTs in code heap */ iterate_code_heap(relocate_code_block); } diff --git a/vmpp/quotations.cpp b/vmpp/quotations.cpp index 8747e4ea3f..e61f8b36ed 100755 --- a/vmpp/quotations.cpp +++ b/vmpp/quotations.cpp @@ -33,70 +33,67 @@ includes stack shufflers, some fixnum arithmetic words, and words such as tag, slot and eq?. A primitive call is relatively expensive (two subroutine calls) so this results in a big speedup for relatively little effort. */ -static bool jit_primitive_call_p(F_ARRAY *array, CELL i) +bool quotation_jit::primitive_call_p(CELL i) { - return (i + 2) == array_capacity(array) - && type_of(array_nth(array,i)) == FIXNUM_TYPE - && array_nth(array,i + 1) == userenv[JIT_PRIMITIVE_WORD]; + return (i + 2) == array_capacity(array.untagged()) + && type_of(array_nth(array.untagged(),i)) == FIXNUM_TYPE + && array_nth(array.untagged(),i + 1) == userenv[JIT_PRIMITIVE_WORD]; } -static bool jit_fast_if_p(F_ARRAY *array, CELL i) +bool quotation_jit::fast_if_p(CELL i) { - return (i + 3) == array_capacity(array) - && type_of(array_nth(array,i)) == QUOTATION_TYPE - && type_of(array_nth(array,i + 1)) == QUOTATION_TYPE - && array_nth(array,i + 2) == userenv[JIT_IF_WORD]; + return (i + 3) == array_capacity(array.untagged()) + && type_of(array_nth(array.untagged(),i)) == QUOTATION_TYPE + && type_of(array_nth(array.untagged(),i + 1)) == QUOTATION_TYPE + && array_nth(array.untagged(),i + 2) == userenv[JIT_IF_WORD]; } -static bool jit_fast_dip_p(F_ARRAY *array, CELL i) +bool quotation_jit::fast_dip_p(CELL i) { - return (i + 2) <= array_capacity(array) - && type_of(array_nth(array,i)) == QUOTATION_TYPE - && array_nth(array,i + 1) == userenv[JIT_DIP_WORD]; + return (i + 2) <= array_capacity(array.untagged()) + && type_of(array_nth(array.untagged(),i)) == QUOTATION_TYPE + && array_nth(array.untagged(),i + 1) == userenv[JIT_DIP_WORD]; } -static bool jit_fast_2dip_p(F_ARRAY *array, CELL i) +bool quotation_jit::fast_2dip_p(CELL i) { - return (i + 2) <= array_capacity(array) - && type_of(array_nth(array,i)) == QUOTATION_TYPE - && array_nth(array,i + 1) == userenv[JIT_2DIP_WORD]; + return (i + 2) <= array_capacity(array.untagged()) + && type_of(array_nth(array.untagged(),i)) == QUOTATION_TYPE + && array_nth(array.untagged(),i + 1) == userenv[JIT_2DIP_WORD]; } -static bool jit_fast_3dip_p(F_ARRAY *array, CELL i) +bool quotation_jit::fast_3dip_p(CELL i) { - return (i + 2) <= array_capacity(array) - && type_of(array_nth(array,i)) == QUOTATION_TYPE - && array_nth(array,i + 1) == userenv[JIT_3DIP_WORD]; + return (i + 2) <= array_capacity(array.untagged()) + && type_of(array_nth(array.untagged(),i)) == QUOTATION_TYPE + && array_nth(array.untagged(),i + 1) == userenv[JIT_3DIP_WORD]; } -static bool jit_mega_lookup_p(F_ARRAY *array, CELL i) +bool quotation_jit::mega_lookup_p(CELL i) { - return (i + 3) < array_capacity(array) - && type_of(array_nth(array,i)) == ARRAY_TYPE - && type_of(array_nth(array,i + 1)) == FIXNUM_TYPE - && type_of(array_nth(array,i + 2)) == ARRAY_TYPE - && array_nth(array,i + 3) == userenv[MEGA_LOOKUP_WORD]; + return (i + 3) < array_capacity(array.untagged()) + && type_of(array_nth(array.untagged(),i)) == ARRAY_TYPE + && type_of(array_nth(array.untagged(),i + 1)) == FIXNUM_TYPE + && type_of(array_nth(array.untagged(),i + 2)) == ARRAY_TYPE + && array_nth(array.untagged(),i + 3) == userenv[MEGA_LOOKUP_WORD]; } -static bool jit_stack_frame_p(F_ARRAY *array) +bool quotation_jit::stack_frame_p() { - F_FIXNUM length = array_capacity(array); + F_FIXNUM length = array_capacity(array.untagged()); F_FIXNUM i; for(i = 0; i < length - 1; i++) { - CELL obj = array_nth(array,i); + CELL obj = array_nth(array.untagged(),i); if(type_of(obj) == WORD_TYPE) { - F_WORD *word = untag_word_fast(obj); - if(word->subprimitive == F) + if(untagged(obj)->subprimitive == F) return true; } else if(type_of(obj) == QUOTATION_TYPE) { - if(jit_fast_dip_p(array,i) - || jit_fast_2dip_p(array,i) - || jit_fast_3dip_p(array,i)) + if(fast_dip_p(i) || fast_2dip_p(i) || fast_3dip_p(i)) return true; } } @@ -104,78 +101,66 @@ static bool jit_stack_frame_p(F_ARRAY *array) return false; } -#define TAIL_CALL { \ - if(stack_frame) jit_emit(jit,userenv[JIT_EPILOG]); \ - tail_call = true; \ - } - /* Allocates memory */ -static void jit_iterate_quotation(F_JIT *jit, CELL array, CELL compiling, CELL relocate) +void quotation_jit::iterate_quotation() { - REGISTER_ROOT(array); + bool stack_frame = stack_frame_p(); - bool stack_frame = jit_stack_frame_p(untag_array_fast(array)); - - jit_set_position(jit,0); + set_position(0); if(stack_frame) - jit_emit(jit,userenv[JIT_PROLOG]); + emit(userenv[JIT_PROLOG]); CELL i; - CELL length = array_capacity(untag_array_fast(array)); + CELL length = array_capacity(array.untagged()); bool tail_call = false; for(i = 0; i < length; i++) { - jit_set_position(jit,i); + set_position(i); - CELL obj = array_nth(untag_array_fast(array),i); - REGISTER_ROOT(obj); + gc_root obj(array_nth(array.untagged(),i)); - F_WORD *word; - F_WRAPPER *wrapper; - - switch(type_of(obj)) + switch(obj.type()) { case WORD_TYPE: - word = untag_word_fast(obj); - /* Intrinsics */ - if(word->subprimitive != F) - jit_emit_subprimitive(jit,obj); + if(obj.as()->subprimitive != F) + emit_subprimitive(obj.value()); /* The (execute) primitive is special-cased */ - else if(obj == userenv[JIT_EXECUTE_WORD]) + else if(obj.value() == userenv[JIT_EXECUTE_WORD]) { if(i == length - 1) { - TAIL_CALL; - jit_emit(jit,userenv[JIT_EXECUTE_JUMP]); + if(stack_frame) emit(userenv[JIT_EPILOG]); + tail_call = true; + emit(userenv[JIT_EXECUTE_JUMP]); } else - jit_emit(jit,userenv[JIT_EXECUTE_CALL]); + emit(userenv[JIT_EXECUTE_CALL]); } /* Everything else */ else { if(i == length - 1) { - TAIL_CALL; - jit_word_jump(jit,obj); + if(stack_frame) emit(userenv[JIT_EPILOG]); + tail_call = true; + word_jump(obj.value()); } else - jit_word_call(jit,obj); + word_call(obj.value()); } break; case WRAPPER_TYPE: - wrapper = untag_wrapper_fast(obj); - jit_push(jit,wrapper->object); + push(obj.as()->object); break; case FIXNUM_TYPE: /* Primitive calls */ - if(jit_primitive_call_p(untag_array_fast(array),i)) + if(primitive_call_p(i)) { - jit_emit(jit,userenv[JIT_SAVE_STACK]); - jit_emit_with(jit,userenv[JIT_PRIMITIVE],obj); + emit(userenv[JIT_SAVE_STACK]); + emit_with(userenv[JIT_PRIMITIVE],obj.value()); i++; @@ -185,80 +170,77 @@ static void jit_iterate_quotation(F_JIT *jit, CELL array, CELL compiling, CELL r case QUOTATION_TYPE: /* 'if' preceeded by two literal quotations (this is why if and ? are mutually recursive in the library, but both still work) */ - if(jit_fast_if_p(untag_array_fast(array),i)) + if(fast_if_p(i)) { - TAIL_CALL; + if(stack_frame) emit(userenv[JIT_EPILOG]); + tail_call = true; if(compiling) { - jit_compile(array_nth(untag_array_fast(array),i),relocate); - jit_compile(array_nth(untag_array_fast(array),i + 1),relocate); + jit_compile(array_nth(array.untagged(),i),relocate); + jit_compile(array_nth(array.untagged(),i + 1),relocate); } - jit_emit_with(jit,userenv[JIT_IF_1],array_nth(untag_array_fast(array),i)); - jit_emit_with(jit,userenv[JIT_IF_2],array_nth(untag_array_fast(array),i + 1)); + emit_with(userenv[JIT_IF_1],array_nth(array.untagged(),i)); + emit_with(userenv[JIT_IF_2],array_nth(array.untagged(),i + 1)); i += 2; break; } /* dip */ - else if(jit_fast_dip_p(untag_array_fast(array),i)) + else if(fast_dip_p(i)) { if(compiling) - jit_compile(obj,relocate); - jit_emit_with(jit,userenv[JIT_DIP],obj); + jit_compile(obj.value(),relocate); + emit_with(userenv[JIT_DIP],obj.value()); i++; break; } /* 2dip */ - else if(jit_fast_2dip_p(untag_array_fast(array),i)) + else if(fast_2dip_p(i)) { if(compiling) - jit_compile(obj,relocate); - jit_emit_with(jit,userenv[JIT_2DIP],obj); + jit_compile(obj.value(),relocate); + emit_with(userenv[JIT_2DIP],obj.value()); i++; break; } /* 3dip */ - else if(jit_fast_3dip_p(untag_array_fast(array),i)) + else if(fast_3dip_p(i)) { if(compiling) - jit_compile(obj,relocate); - jit_emit_with(jit,userenv[JIT_3DIP],obj); + jit_compile(obj.value(),relocate); + emit_with(userenv[JIT_3DIP],obj.value()); i++; break; } case ARRAY_TYPE: /* Method dispatch */ - if(jit_mega_lookup_p(untag_array_fast(array),i)) + if(mega_lookup_p(i)) { - jit_emit_mega_cache_lookup(jit, - array_nth(untag_array_fast(array),i), - untag_fixnum_fast(array_nth(untag_array_fast(array),i + 1)), - array_nth(untag_array_fast(array),i + 2)); + emit_mega_cache_lookup( + array_nth(array.untagged(),i), + untag_fixnum_fast(array_nth(array.untagged(),i + 1)), + array_nth(array.untagged(),i + 2)); i += 3; tail_call = true; break; } default: - jit_push(jit,obj); + push(obj.value()); break; } - - UNREGISTER_ROOT(obj); } if(!tail_call) { - jit_set_position(jit,length); + set_position(length); if(stack_frame) - jit_emit(jit,userenv[JIT_EPILOG]); - jit_emit(jit,userenv[JIT_RETURN]); + emit(userenv[JIT_EPILOG]); + emit(userenv[JIT_RETURN]); } - - UNREGISTER_ROOT(array); } void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code) @@ -272,56 +254,26 @@ void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code) } /* Allocates memory */ -void jit_compile(CELL quot, bool relocate) +void jit_compile(CELL quot_, bool relocating) { - if(untag_quotation(quot)->compiledp != F) - return; + gc_root quot(quot_); + if(quot->compiledp != F) return; - CELL array = untag_quotation(quot)->array; + quotation_jit jit(quot.value(),true,relocating); + jit.iterate_quotation(); - REGISTER_ROOT(quot); - REGISTER_ROOT(array); + F_CODE_BLOCK *compiled = jit.code_block(); + set_quot_xt(quot.untagged(),compiled); - F_JIT jit; - jit_init(&jit,QUOTATION_TYPE,quot); - - jit_iterate_quotation(&jit,array,true,relocate); - - F_CODE_BLOCK *compiled = jit_make_code_block(&jit); - - set_quot_xt(untag_quotation_fast(quot),compiled); - - if(relocate) relocate_code_block(compiled); - - jit_dispose(&jit); - - UNREGISTER_ROOT(array); - UNREGISTER_ROOT(quot); + if(relocating) relocate_code_block(compiled); } -F_FIXNUM quot_code_offset_to_scan(CELL quot, CELL offset) -{ - CELL array = untag_quotation(quot)->array; - REGISTER_ROOT(array); - - F_JIT jit; - jit_init(&jit,QUOTATION_TYPE,quot); - jit_compute_position(&jit,offset); - jit_iterate_quotation(&jit,array,false,false); - jit_dispose(&jit); - - UNREGISTER_ROOT(array); - - return jit_get_position(&jit); -} - -F_FASTCALL CELL lazy_jit_compile_impl(CELL quot, F_STACK_FRAME *stack) +F_FASTCALL CELL lazy_jit_compile_impl(CELL quot_, F_STACK_FRAME *stack) { + gc_root quot(quot_); stack_chain->callstack_top = stack; - REGISTER_ROOT(quot); - jit_compile(quot,true); - UNREGISTER_ROOT(quot); - return quot; + jit_compile(quot.value(),true); + return quot.value(); } void primitive_jit_compile(void) @@ -332,7 +284,7 @@ void primitive_jit_compile(void) /* push a new quotation on the stack */ void primitive_array_to_quotation(void) { - F_QUOTATION *quot = (F_QUOTATION *)allot_object(QUOTATION_TYPE,sizeof(F_QUOTATION)); + F_QUOTATION *quot = allot(sizeof(F_QUOTATION)); quot->array = dpeek(); quot->xt = (void *)lazy_jit_compile; quot->compiledp = F; @@ -349,26 +301,33 @@ void primitive_quotation_xt(void) void compile_all_words(void) { - CELL words = find_all_words(); - - REGISTER_ROOT(words); + gc_root words(find_all_words()); CELL i; - CELL length = array_capacity(untag_array(words)); + CELL length = array_capacity(words.untagged()); for(i = 0; i < length; i++) { - F_WORD *word = untag_word(array_nth(untag_array(words),i)); - REGISTER_UNTAGGED(word); + gc_root word(array_nth(words.untagged(),i)); - if(!word->code || !word_optimized_p(word)) - jit_compile_word(word,word->def,false); + if(!word->code || !word_optimized_p(word.untagged())) + jit_compile_word(word.value(),word->def,false); - UNREGISTER_UNTAGGED(F_WORD,word); - update_word_xt(word); + update_word_xt(word.value()); } - UNREGISTER_ROOT(words); - iterate_code_heap(relocate_code_block); } + +/* Allocates memory */ +F_FIXNUM quot_code_offset_to_scan(CELL quot_, CELL offset) +{ + gc_root quot(quot_); + gc_root array(quot->array); + + quotation_jit jit(quot.value(),false,false); + jit.compute_position(offset); + jit.iterate_quotation(); + + return jit.get_position(); +} diff --git a/vmpp/quotations.hpp b/vmpp/quotations.hpp index f3dc9920de..f802f46b64 100755 --- a/vmpp/quotations.hpp +++ b/vmpp/quotations.hpp @@ -5,12 +5,37 @@ INLINE CELL tag_quotation(F_QUOTATION *quotation) return RETAG(quotation,QUOTATION_TYPE); } +struct quotation_jit : public jit { + gc_root array; + bool compiling, relocate; + + quotation_jit(CELL quot, bool compiling_, bool relocate_) + : jit(QUOTATION_TYPE,quot), + array(owner.as().untagged()->array), + compiling(compiling_), + relocate(relocate_) {}; + + void emit_mega_cache_lookup(CELL methods, F_FIXNUM index, CELL cache); + bool primitive_call_p(CELL i); + bool fast_if_p(CELL i); + bool fast_dip_p(CELL i); + bool fast_2dip_p(CELL i); + bool fast_3dip_p(CELL i); + bool mega_lookup_p(CELL i); + bool stack_frame_p(); + void iterate_quotation(); +}; + void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code); void jit_compile(CELL quot, bool relocate); F_FIXNUM quot_code_offset_to_scan(CELL quot, CELL offset); -void primitive_array_to_quotation(void); -void primitive_quotation_xt(void); + void primitive_jit_compile(void); -void compile_all_words(void); F_FASTCALL CELL lazy_jit_compile_impl(CELL quot, F_STACK_FRAME *stack); + +void compile_all_words(void); + +void primitive_array_to_quotation(void); +void primitive_quotation_xt(void); + diff --git a/vmpp/run.cpp b/vmpp/run.cpp index 588caacc74..9b46e85f7d 100755 --- a/vmpp/run.cpp +++ b/vmpp/run.cpp @@ -231,19 +231,19 @@ void primitive_load_locals(void) rs += CELLS * count; } -static CELL clone_object(CELL object) +static CELL clone_object(CELL object_) { - CELL size = object_size(object); + gc_root object(object_); + + CELL size = object_size(object.value()); if(size == 0) - return object; + return object.value(); else { - REGISTER_ROOT(object); - void *new_obj = allot_object(type_of(object),size); - UNREGISTER_ROOT(object); + void *new_obj = allot_object(object.type(),size); - CELL tag = TAG(object); - memcpy(new_obj,(void*)UNTAG(object),size); + CELL tag = TAG(object.value()); + memcpy(new_obj,object.untagged(),size); return RETAG(new_obj,tag); } } diff --git a/vmpp/strings.cpp b/vmpp/strings.cpp index fcb7dbcf97..a69e7dd3c7 100644 --- a/vmpp/strings.cpp +++ b/vmpp/strings.cpp @@ -17,20 +17,21 @@ CELL string_nth(F_STRING* string, CELL index) } } -void set_string_nth_fast(F_STRING* string, CELL index, CELL ch) +void set_string_nth_fast(F_STRING *string, CELL index, CELL ch) { bput(SREF(string,index),ch); } -void set_string_nth_slow(F_STRING* string, CELL index, CELL ch) +void set_string_nth_slow(F_STRING *string_, CELL index, CELL ch) { + gc_root string(string_); + F_BYTE_ARRAY *aux; - bput(SREF(string,index),(ch & 0x7f) | 0x80); + bput(SREF(string.untagged(),index),(ch & 0x7f) | 0x80); if(string->aux == F) { - REGISTER_UNTAGGED(string); /* We don't need to pre-initialize the byte array with any data, since we only ever read from the aux vector @@ -40,9 +41,8 @@ void set_string_nth_slow(F_STRING* string, CELL index, CELL ch) aux = allot_array_internal( untag_fixnum_fast(string->length) * sizeof(u16)); - UNREGISTER_UNTAGGED(F_STRING,string); - write_barrier((CELL)string); + write_barrier(string.value()); string->aux = tag_object(aux); } else @@ -60,10 +60,10 @@ void set_string_nth(F_STRING* string, CELL index, CELL ch) set_string_nth_slow(string,index,ch); } -/* untagged */ -F_STRING* allot_string_internal(CELL capacity) +/* Allocates memory */ +F_STRING *allot_string_internal(CELL capacity) { - F_STRING *string = (F_STRING *)allot_object(STRING_TYPE,string_size(capacity)); + F_STRING *string = allot(string_size(capacity)); string->length = tag_fixnum(capacity); string->hashcode = F; @@ -72,32 +72,28 @@ F_STRING* allot_string_internal(CELL capacity) return string; } -/* allocates memory */ -void fill_string(F_STRING *string, CELL start, CELL capacity, CELL fill) +/* Allocates memory */ +void fill_string(F_STRING *string_, CELL start, CELL capacity, CELL fill) { + gc_root string(string_); + if(fill <= 0x7f) - memset((void *)SREF(string,start),fill,capacity - start); + memset((void *)SREF(string.untagged(),start),fill,capacity - start); else { CELL i; for(i = start; i < capacity; i++) - { - REGISTER_UNTAGGED(string); - set_string_nth(string,i,fill); - UNREGISTER_UNTAGGED(F_STRING,string); - } + set_string_nth(string.untagged(),i,fill); } } -/* untagged */ +/* Allocates memory */ F_STRING *allot_string(CELL capacity, CELL fill) { - F_STRING* string = allot_string_internal(capacity); - REGISTER_UNTAGGED(string); - fill_string(string,0,capacity,fill); - UNREGISTER_UNTAGGED(F_STRING,string); - return string; + gc_root string(allot_string_internal(capacity)); + fill_string(string.untagged(),0,capacity,fill); + return string.untagged(); } void primitive_string(void) @@ -112,9 +108,11 @@ static bool reallot_string_in_place_p(F_STRING *string, CELL capacity) return in_zone(&nursery,(CELL)string) && capacity <= string_capacity(string); } -F_STRING* reallot_string(F_STRING* string, CELL capacity) +F_STRING* reallot_string(F_STRING *string_, CELL capacity) { - if(reallot_string_in_place_p(string,capacity)) + gc_root string(string_); + + if(reallot_string_in_place_p(string.untagged(),capacity)) { string->length = tag_fixnum(capacity); @@ -124,42 +122,31 @@ F_STRING* reallot_string(F_STRING* string, CELL capacity) aux->capacity = tag_fixnum(capacity * 2); } - return string; + return string.untagged(); } else { - CELL to_copy = string_capacity(string); + CELL to_copy = string_capacity(string.untagged()); if(capacity < to_copy) to_copy = capacity; - REGISTER_UNTAGGED(string); - F_STRING *new_string = allot_string_internal(capacity); - UNREGISTER_UNTAGGED(F_STRING,string); + gc_root new_string(allot_string_internal(capacity)); - memcpy(new_string + 1,string + 1,to_copy); + memcpy(new_string.untagged() + 1,string.untagged() + 1,to_copy); if(string->aux != F) { - REGISTER_UNTAGGED(string); - REGISTER_UNTAGGED(new_string); F_BYTE_ARRAY *new_aux = allot_byte_array(capacity * sizeof(u16)); - UNREGISTER_UNTAGGED(F_STRING,new_string); - UNREGISTER_UNTAGGED(F_STRING,string); - write_barrier((CELL)new_string); + write_barrier(new_string.value()); new_string->aux = tag_object(new_aux); F_BYTE_ARRAY *aux = untag_byte_array_fast(string->aux); memcpy(new_aux + 1,aux + 1,to_copy * sizeof(u16)); } - REGISTER_UNTAGGED(string); - REGISTER_UNTAGGED(new_string); - fill_string(new_string,to_copy,capacity,'\0'); - UNREGISTER_UNTAGGED(F_STRING,new_string); - UNREGISTER_UNTAGGED(F_STRING,string); - - return new_string; + fill_string(new_string.untagged(),to_copy,capacity,'\0'); + return new_string.untagged(); } } @@ -175,18 +162,16 @@ void primitive_resize_string(void) #define MEMORY_TO_STRING(type,utype) \ F_STRING *memory_to_##type##_string(const type *string, CELL length) \ { \ - REGISTER_C_STRING(string); \ - F_STRING *s = allot_string_internal(length); \ - UNREGISTER_C_STRING(type,string); \ + REGISTER_C_STRING(string); \ + gc_root s(allot_string_internal(length)); \ + UNREGISTER_C_STRING(type,string); \ CELL i; \ for(i = 0; i < length; i++) \ { \ - REGISTER_UNTAGGED(s); \ - set_string_nth(s,i,(utype)*string); \ - UNREGISTER_UNTAGGED(F_STRING,s); \ + set_string_nth(s.untagged(),i,(utype)*string); \ string++; \ } \ - return s; \ + return s.untagged(); \ } \ F_STRING *from_##type##_string(const type *str) \ { \ @@ -236,17 +221,16 @@ F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size) F_STRING *str = untag_string(dpop()); \ type##_string_to_memory(str,address); \ } \ - F_BYTE_ARRAY *string_to_##type##_alien(F_STRING *s, bool check) \ + F_BYTE_ARRAY *string_to_##type##_alien(F_STRING *s_, bool check) \ { \ - CELL capacity = string_capacity(s); \ + gc_root s(s_); \ + CELL capacity = string_capacity(s.untagged()); \ F_BYTE_ARRAY *_c_str; \ - if(check && !check_string(s,sizeof(type))) \ - general_error(ERROR_C_STRING,tag_object(s),F,NULL); \ - REGISTER_UNTAGGED(s); \ + if(check && !check_string(s.untagged(),sizeof(type))) \ + general_error(ERROR_C_STRING,s.value(),F,NULL); \ _c_str = allot_c_string(capacity,sizeof(type)); \ - UNREGISTER_UNTAGGED(F_STRING,s); \ type *c_str = (type*)(_c_str + 1); \ - type##_string_to_memory(s,c_str); \ + type##_string_to_memory(s.untagged(),c_str); \ c_str[capacity] = 0; \ return _c_str; \ } \ diff --git a/vmpp/tagged.hpp b/vmpp/tagged.hpp index c6ccc66cd9..86f31f8281 100644 --- a/vmpp/tagged.hpp +++ b/vmpp/tagged.hpp @@ -7,26 +7,49 @@ template CELL tag(T *value) } template -class tagged +struct tagged { - CELL value; -public: - explicit tagged(CELL tagged) : value(tagged) {} - explicit tagged(T *untagged) : value(::tag(untagged)) {} + CELL value_; - CELL tag() const { return value; } - T *untag() const { type_check(T::type_number,value); } - T *untag_fast() const { return (T *)(UNTAG(value)); } - T *operator->() const { return untag_fast(); } - CELL *operator&() const { return &value; } + T *untag_check() const { + if(T::type_number != TYPE_COUNT) + type_check(T::type_number,value_); + return untagged(); + } + + explicit tagged(CELL tagged) : value_(tagged) { +#ifdef FACTOR_DEBUG + untag_check(); +#endif + } + + explicit tagged(T *untagged) : value_(::tag(untagged)) { +#ifdef FACTOR_DEBUG + untag_check(); +#endif + } + + CELL value() const { return value_; } + T *untagged() const { return (T *)(UNTAG(value_)); } + + T *operator->() const { return untagged(); } + CELL *operator&() const { return &value_; } + + const tagged& operator=(const T *x) { value_ = tag(x); return *this; } + const tagged& operator=(const CELL &x) { value_ = x; return *this; } + + CELL type() const { return type_of(value_); } + bool isa(CELL type_) const { return type() == type_; } + + template tagged as() { return tagged(value_); } }; -template T *untag(CELL value) +template T *untag_check(CELL value) { - return tagged(value).untag(); + return tagged(value).untag_check(); } -template T *untag_fast(CELL value) +template T *untagged(CELL value) { - return tagged(value).untag_fast(); + return tagged(value).untagged(); } diff --git a/vmpp/tuples.cpp b/vmpp/tuples.cpp index 27a8cf21d9..63ea924559 100644 --- a/vmpp/tuples.cpp +++ b/vmpp/tuples.cpp @@ -1,23 +1,20 @@ #include "master.hpp" /* push a new tuple on the stack */ -F_TUPLE *allot_tuple(F_TUPLE_LAYOUT *layout) +F_TUPLE *allot_tuple(CELL layout_) { - REGISTER_UNTAGGED(layout); - F_TUPLE *tuple = (F_TUPLE *)allot_object(TUPLE_TYPE,tuple_size(layout)); - UNREGISTER_UNTAGGED(F_TUPLE_LAYOUT,layout); - tuple->layout = tag_array((F_ARRAY *)layout); - return tuple; + gc_root layout(layout_); + gc_root tuple(allot(tuple_size(layout.untagged()))); + tuple->layout = layout.value(); + return tuple.untagged(); } void primitive_tuple(void) { - F_TUPLE_LAYOUT *layout = untag_tuple_layout(dpop()); - F_FIXNUM size = untag_fixnum_fast(layout->size); - - F_TUPLE *tuple = allot_tuple(layout); + gc_root layout(dpop()); + F_TUPLE *tuple = allot_tuple(layout.value()); F_FIXNUM i; - for(i = size - 1; i >= 0; i--) + for(i = tuple_size(layout.untagged()) - 1; i >= 0; i--) put(AREF(tuple,i),F); dpush(tag_tuple(tuple)); @@ -26,10 +23,10 @@ void primitive_tuple(void) /* push a new tuple on the stack, filling its slots from the stack */ void primitive_tuple_boa(void) { - F_TUPLE_LAYOUT *layout = untag_tuple_layout(dpop()); - F_FIXNUM size = untag_fixnum_fast(layout->size); - F_TUPLE *tuple = allot_tuple(layout); - memcpy(tuple + 1,(CELL *)(ds - CELLS * (size - 1)),CELLS * size); - ds -= CELLS * size; - dpush(tag_tuple(tuple)); + gc_root layout(dpop()); + gc_root tuple(allot_tuple(layout.value())); + CELL size = untag_fixnum_fast(layout.untagged()->size) * CELLS; + memcpy(tuple.untagged() + 1,(CELL *)(ds - (size - CELLS)),size); + ds -= size; + dpush(tuple.value()); } diff --git a/vmpp/words.cpp b/vmpp/words.cpp index ed13671bab..53d6e4d795 100644 --- a/vmpp/words.cpp +++ b/vmpp/words.cpp @@ -1,16 +1,15 @@ #include "master.hpp" -F_WORD *allot_word(CELL vocab, CELL name) +F_WORD *allot_word(CELL vocab_, CELL name_) { - REGISTER_ROOT(vocab); - REGISTER_ROOT(name); - F_WORD *word = (F_WORD *)allot_object(WORD_TYPE,sizeof(F_WORD)); - UNREGISTER_ROOT(name); - UNREGISTER_ROOT(vocab); + gc_root vocab(vocab_); + gc_root name(name_); + + gc_root word(allot(sizeof(F_WORD))); word->hashcode = tag_fixnum((rand() << 16) ^ rand()); - word->vocabulary = vocab; - word->name = name; + word->vocabulary = vocab.value(); + word->name = name.value(); word->def = userenv[UNDEFINED_ENV]; word->props = F; word->counter = tag_fixnum(0); @@ -19,18 +18,13 @@ F_WORD *allot_word(CELL vocab, CELL name) word->profiling = NULL; word->code = NULL; - REGISTER_UNTAGGED(word); - jit_compile_word(word,word->def,true); - UNREGISTER_UNTAGGED(F_WORD,word); - - REGISTER_UNTAGGED(word); - update_word_xt(word); - UNREGISTER_UNTAGGED(F_WORD,word); + jit_compile_word(word.value(),word->def,true); + update_word_xt(word.value()); if(profiling_p) relocate_code_block(word->profiling); - return word; + return word.untagged(); } /* ( name vocabulary -- word ) */ @@ -51,15 +45,15 @@ void primitive_word_xt(void) } /* Allocates memory */ -void update_word_xt(F_WORD *word) +void update_word_xt(CELL word_) { + gc_root word(word_); + if(profiling_p) { if(!word->profiling) { - REGISTER_UNTAGGED(word); - F_CODE_BLOCK *profiling = compile_profiling_stub(tag_object(word)); - UNREGISTER_UNTAGGED(F_WORD,word); + F_CODE_BLOCK *profiling = compile_profiling_stub(word.value()); word->profiling = profiling; } @@ -76,7 +70,7 @@ void primitive_optimized_p(void) void primitive_wrapper(void) { - F_WRAPPER *wrapper = (F_WRAPPER *)allot_object(WRAPPER_TYPE,sizeof(F_WRAPPER)); + F_WRAPPER *wrapper = allot(sizeof(F_WRAPPER)); wrapper->object = dpeek(); drepl(tag_object(wrapper)); } diff --git a/vmpp/words.hpp b/vmpp/words.hpp index cbc0d3c0d0..94912adc97 100644 --- a/vmpp/words.hpp +++ b/vmpp/words.hpp @@ -4,7 +4,7 @@ F_WORD *allot_word(CELL vocab, CELL name); void primitive_word(void); void primitive_word_xt(void); -void update_word_xt(F_WORD *word); +void update_word_xt(CELL word); INLINE bool word_optimized_p(F_WORD *word) { From 7c12b5578fb2533e307f61c1e473ac3de0039600 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 2 May 2009 10:17:05 -0500 Subject: [PATCH 06/44] More VM fixes --- vmpp/bignum.cpp | 2 +- vmpp/code_gc.hpp | 8 ++++---- vmpp/data_gc.hpp | 4 ++-- vmpp/image.hpp | 8 ++++---- vmpp/math.cpp | 2 +- vmpp/os-windows.cpp | 1 - vmpp/run.hpp | 10 +++++----- 7 files changed, 17 insertions(+), 18 deletions(-) diff --git a/vmpp/bignum.cpp b/vmpp/bignum.cpp index e8920a5ac6..3a665f22d3 100755 --- a/vmpp/bignum.cpp +++ b/vmpp/bignum.cpp @@ -347,7 +347,7 @@ bignum_remainder(F_BIGNUM * numerator, F_BIGNUM * denominator) if (n == 1) return (BIGNUM_ONE (0)); \ if (n < (type)0 && n == (type)-1) return (BIGNUM_ONE (1)); \ { \ - utype accumulator = ((negative_p = (n < (utype)0)) ? (-n) : n); \ + utype accumulator = ((negative_p = (n < (type)0)) ? (-n) : n); \ do \ { \ (*end_digits++) = (accumulator & BIGNUM_DIGIT_MASK); \ diff --git a/vmpp/code_gc.hpp b/vmpp/code_gc.hpp index 35f8d66d90..f199e469ff 100755 --- a/vmpp/code_gc.hpp +++ b/vmpp/code_gc.hpp @@ -1,15 +1,15 @@ #define FREE_LIST_COUNT 16 #define BLOCK_SIZE_INCREMENT 32 -typedef struct { +struct F_HEAP_FREE_LIST { F_FREE_BLOCK *small_blocks[FREE_LIST_COUNT]; F_FREE_BLOCK *large_blocks; -} F_HEAP_FREE_LIST; +}; -typedef struct { +struct F_HEAP { F_SEGMENT *segment; F_HEAP_FREE_LIST free; -} F_HEAP; +}; typedef void (*HEAP_ITERATOR)(F_BLOCK *compiled); diff --git a/vmpp/data_gc.hpp b/vmpp/data_gc.hpp index 9dc3a77071..2e508c93a5 100755 --- a/vmpp/data_gc.hpp +++ b/vmpp/data_gc.hpp @@ -4,13 +4,13 @@ void gc(void); DLLEXPORT void minor_gc(void); /* statistics */ -typedef struct { +struct F_GC_STATS { CELL collections; u64 gc_time; u64 max_gc_time; CELL object_count; u64 bytes_copied; -} F_GC_STATS; +}; extern F_ZONE *newspace; diff --git a/vmpp/image.hpp b/vmpp/image.hpp index ac2123c602..f3041dc45b 100755 --- a/vmpp/image.hpp +++ b/vmpp/image.hpp @@ -1,7 +1,7 @@ #define IMAGE_MAGIC 0x0f0e0d0c #define IMAGE_VERSION 4 -typedef struct { +struct F_HEADER { CELL magic; CELL version; /* all pointers in the image file are relocated from @@ -23,9 +23,9 @@ typedef struct { CELL bignum_neg_one; /* Initial user environment */ CELL userenv[USER_ENV]; -} F_HEADER; +}; -typedef struct { +struct F_PARAMETERS { const F_CHAR *image_path; const F_CHAR *executable_path; CELL ds_size, rs_size; @@ -36,7 +36,7 @@ typedef struct { bool console; bool stack_traces; CELL max_pic_size; -} F_PARAMETERS; +}; void load_image(F_PARAMETERS *p); bool save_image(const F_CHAR *file); diff --git a/vmpp/math.cpp b/vmpp/math.cpp index eb78bf0f7c..856c9ec8b5 100644 --- a/vmpp/math.cpp +++ b/vmpp/math.cpp @@ -82,7 +82,7 @@ void primitive_fixnum_divmod(void) else { put(ds - CELLS,tag_fixnum(untag_fixnum_fast(x) / untag_fixnum_fast(y))); - put(ds,x % y); + put(ds,(F_FIXNUM)x % (F_FIXNUM)y); } } diff --git a/vmpp/os-windows.cpp b/vmpp/os-windows.cpp index e1f5c16647..6bd7dd9956 100755 --- a/vmpp/os-windows.cpp +++ b/vmpp/os-windows.cpp @@ -90,7 +90,6 @@ const F_CHAR *vm_executable_path(void) void primitive_existsp(void) { - F_CHAR *path = unbox_u16_string(); box_boolean(windows_stat(path)); } diff --git a/vmpp/run.hpp b/vmpp/run.hpp index d3bec859ef..0b54f94980 100755 --- a/vmpp/run.hpp +++ b/vmpp/run.hpp @@ -200,18 +200,18 @@ INLINE CELL type_of(CELL tagged) DEFPUSHPOP(d,ds) DEFPUSHPOP(r,rs) -typedef struct { +struct F_SEGMENT { CELL start; CELL size; CELL end; -} F_SEGMENT; +}; /* Assembly code makes assumptions about the layout of this struct: - callstack_top field is 0 - callstack_bottom field is 1 - datastack field is 2 - retainstack field is 3 */ -typedef struct _F_CONTEXT { +struct F_CONTEXT { /* C stack pointer on entry */ F_STACK_FRAME *callstack_top; F_STACK_FRAME *callstack_bottom; @@ -238,8 +238,8 @@ typedef struct _F_CONTEXT { CELL catchstack_save; CELL current_callback_save; - struct _F_CONTEXT *next; -} F_CONTEXT; + F_CONTEXT *next; +}; extern F_CONTEXT *stack_chain; From 06359c08507fc844b2857f48a818ce79c4155d9c Mon Sep 17 00:00:00 2001 From: Sam Anklesaria Date: Sat, 2 May 2009 10:32:18 -0500 Subject: [PATCH 07/44] str-fry fixes --- extra/str-fry/str-fry.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/str-fry/str-fry.factor b/extra/str-fry/str-fry.factor index 65e25e2580..bfe74f37eb 100644 --- a/extra/str-fry/str-fry.factor +++ b/extra/str-fry/str-fry.factor @@ -1,7 +1,7 @@ -USING: fry.private kernel macros math sequences splitting strings.parser ; +USING: combinators effects kernel math sequences splitting +strings.parser ; IN: str-fry : str-fry ( str -- quot ) "_" split - [ length 1 - [ncurry] [ call ] append ] - [ unclip [ [ rot glue ] reduce ] 2curry ] bi - prefix ; + [ unclip [ [ rot glue ] reduce ] 2curry ] + [ length 1 - 1 [ call-effect ] 2curry ] bi ; SYNTAX: I" parse-string rest str-fry over push-all ; \ No newline at end of file From a63ad6a7a5d321d4fdd36ecbec36046ea0c3aff9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 2 May 2009 13:45:38 -0500 Subject: [PATCH 08/44] Remove cruddy string encoding/decoding code from VM --- basis/alien/arrays/arrays.factor | 65 ++++++++++- basis/alien/c-types/c-types-docs.factor | 36 +++++- basis/alien/c-types/c-types.factor | 16 ++- basis/alien/libraries/libraries.factor | 8 +- basis/alien/strings/strings-docs.factor | 52 --------- basis/alien/strings/strings.factor | 109 ------------------ basis/alien/strings/unix/summary.txt | 1 - basis/alien/strings/unix/unix.factor | 8 -- basis/alien/strings/windows/summary.txt | 1 - basis/alien/strings/windows/tags.txt | 1 - basis/alien/strings/windows/windows.factor | 13 --- basis/bootstrap/stage2.factor | 1 - basis/command-line/command-line.factor | 6 +- basis/compiler/tests/simple.factor | 4 +- basis/debugger/debugger.factor | 24 ++-- basis/io/encodings/iana/iana.factor | 5 +- basis/json/reader/reader.factor | 2 +- basis/prettyprint/backend/backend.factor | 14 ++- .../known-words/known-words.factor | 38 +++--- core/alien/strings/strings-docs.factor | 20 ++++ .../alien/strings/strings-tests.factor | 0 core/alien/strings/strings.factor | 61 ++++++++++ {basis => core}/alien/strings/summary.txt | 0 core/bootstrap/primitives.factor | 68 +++++------ core/bootstrap/syntax.factor | 1 + .../byte-vectors/byte-vectors-docs.factor | 0 .../byte-vectors/byte-vectors-tests.factor | 0 .../byte-vectors/byte-vectors.factor | 9 +- {basis => core}/byte-vectors/summary.txt | 0 {basis => core}/byte-vectors/tags.txt | 0 core/classes/algebra/algebra-tests.factor | 9 ++ .../io/encodings/utf16/authors.txt | 0 .../io/encodings/utf16/summary.txt | 0 .../io/encodings/utf16/utf16-docs.factor | 0 .../io/encodings/utf16/utf16-tests.factor | 0 .../io/encodings/utf16/utf16.factor | 8 +- .../io/encodings/utf16n/authors.txt | 0 .../io/encodings/utf16n/summary.txt | 0 .../io/encodings/utf16n/utf16n-docs.factor | 0 .../io/encodings/utf16n/utf16n-tests.factor | 0 .../io/encodings/utf16n/utf16n.factor | 4 +- core/io/files/files.factor | 12 +- .../streams/byte-array/byte-array-docs.factor | 0 .../byte-array/byte-array-tests.factor | 0 .../io/streams/byte-array/byte-array.factor | 4 +- .../io/streams/byte-array/summary.txt | 0 core/io/streams/c/c.factor | 11 +- .../io/streams/memory/memory.factor | 8 +- {basis => core}/io/streams/memory/summary.txt | 0 core/math/parser/parser-docs.factor | 2 +- core/math/parser/parser.factor | 12 +- core/memory/memory.factor | 11 +- core/syntax/syntax.factor | 3 +- core/system/system.factor | 24 +--- vmpp/alien.cpp | 9 +- vmpp/code_block.cpp | 4 - vmpp/factor.cpp | 8 +- vmpp/image.cpp | 17 ++- vmpp/io.cpp | 14 +-- vmpp/local_roots.hpp | 27 +---- vmpp/math.cpp | 25 ++-- vmpp/os-unix.cpp | 8 +- vmpp/os-unix.hpp | 3 - vmpp/os-windows-ce.hpp | 3 - vmpp/os-windows-nt.hpp | 3 - vmpp/os-windows.cpp | 2 +- vmpp/os-windows.hpp | 2 - vmpp/strings.cpp | 89 -------------- vmpp/strings.hpp | 18 --- 69 files changed, 380 insertions(+), 523 deletions(-) delete mode 100644 basis/alien/strings/strings-docs.factor delete mode 100644 basis/alien/strings/strings.factor delete mode 100644 basis/alien/strings/unix/summary.txt delete mode 100644 basis/alien/strings/unix/unix.factor delete mode 100644 basis/alien/strings/windows/summary.txt delete mode 100644 basis/alien/strings/windows/tags.txt delete mode 100644 basis/alien/strings/windows/windows.factor create mode 100644 core/alien/strings/strings-docs.factor rename {basis => core}/alien/strings/strings-tests.factor (100%) create mode 100644 core/alien/strings/strings.factor rename {basis => core}/alien/strings/summary.txt (100%) rename {basis => core}/byte-vectors/byte-vectors-docs.factor (100%) rename {basis => core}/byte-vectors/byte-vectors-tests.factor (100%) rename {basis => core}/byte-vectors/byte-vectors.factor (80%) rename {basis => core}/byte-vectors/summary.txt (100%) rename {basis => core}/byte-vectors/tags.txt (100%) rename {basis => core}/io/encodings/utf16/authors.txt (100%) rename {basis => core}/io/encodings/utf16/summary.txt (100%) rename {basis => core}/io/encodings/utf16/utf16-docs.factor (100%) rename {basis => core}/io/encodings/utf16/utf16-tests.factor (100%) rename {basis => core}/io/encodings/utf16/utf16.factor (94%) rename {basis => core}/io/encodings/utf16n/authors.txt (100%) rename {basis => core}/io/encodings/utf16n/summary.txt (100%) rename {basis => core}/io/encodings/utf16n/utf16n-docs.factor (100%) rename {basis => core}/io/encodings/utf16n/utf16n-tests.factor (100%) rename {basis => core}/io/encodings/utf16n/utf16n.factor (67%) rename {basis => core}/io/streams/byte-array/byte-array-docs.factor (100%) rename {basis => core}/io/streams/byte-array/byte-array-tests.factor (100%) rename {basis => core}/io/streams/byte-array/byte-array.factor (90%) rename {basis => core}/io/streams/byte-array/summary.txt (100%) rename {basis => core}/io/streams/memory/memory.factor (62%) rename {basis => core}/io/streams/memory/summary.txt (100%) diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor index 6a182f8dbf..15e67bf0fe 100755 --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -1,7 +1,8 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays alien.c-types alien.structs -sequences math kernel namespaces fry libc cpu.architecture ; +USING: alien alien.strings alien.c-types alien.accessors alien.structs +arrays words sequences math kernel namespaces fry libc cpu.architecture +io.encodings.utf8 io.encodings.utf16n ; IN: alien.arrays UNION: value-type array struct-type ; @@ -38,3 +39,61 @@ M: value-type c-type-getter M: value-type c-type-setter ( type -- quot ) [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri '[ @ swap @ _ memcpy ] ; + +PREDICATE: string-type < pair + first2 [ "char*" = ] [ word? ] bi* and ; + +M: string-type c-type ; + +M: string-type c-type-class + drop object ; + +M: string-type heap-size + drop "void*" heap-size ; + +M: string-type c-type-align + drop "void*" c-type-align ; + +M: string-type c-type-stack-align? + drop "void*" c-type-stack-align? ; + +M: string-type unbox-parameter + drop "void*" unbox-parameter ; + +M: string-type unbox-return + drop "void*" unbox-return ; + +M: string-type box-parameter + drop "void*" box-parameter ; + +M: string-type box-return + drop "void*" box-return ; + +M: string-type stack-size + drop "void*" stack-size ; + +M: string-type c-type-reg-class + drop int-regs ; + +M: string-type c-type-boxer + drop "void*" c-type-boxer ; + +M: string-type c-type-unboxer + drop "void*" c-type-unboxer ; + +M: string-type c-type-boxer-quot + second '[ _ alien>string ] ; + +M: string-type c-type-unboxer-quot + second '[ _ string>alien ] ; + +M: string-type c-type-getter + drop [ alien-cell ] ; + +M: string-type c-type-setter + drop [ set-alien-cell ] ; + +{ "char*" utf8 } "char*" typedef +"char*" "uchar*" typedef +{ "char*" utf16n } "wchar_t*" typedef + diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor index 46afc05e2d..c9c1ecd0e5 100644 --- a/basis/alien/c-types/c-types-docs.factor +++ b/basis/alien/c-types/c-types-docs.factor @@ -1,7 +1,7 @@ IN: alien.c-types USING: alien help.syntax help.markup libc kernel.private -byte-arrays math strings hashtables alien.syntax -debugger destructors ; +byte-arrays math strings hashtables alien.syntax alien.strings sequences +io.encodings.string debugger destructors ; HELP: { $values { "type" hashtable } } @@ -114,6 +114,38 @@ HELP: define-out { $description "Defines a word " { $snippet "<" { $emphasis "name" } ">" } " with stack effect " { $snippet "( value -- array )" } ". This word allocates a byte array large enough to hold a value with C type " { $snippet "name" } ", and writes the value at the top of the stack to the array." } { $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ; +{ string>alien alien>string malloc-string } related-words + +HELP: malloc-string +{ $values { "string" string } { "encoding" "an encoding descriptor" } { "alien" c-ptr } } +{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated unmanaged memory block." } +{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." } +{ $errors "Throws an error if one of the following conditions occurs:" + { $list + "the string contains null code points" + "the string contains characters not representable using the encoding specified" + "memory allocation fails" + } +} ; + +ARTICLE: "c-strings" "C strings" +"C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors." +$nl +"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function." +$nl +"If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown." +$nl +"Care must be taken if the C function expects a " { $snippet "char*" } " with a length in bytes, rather than a null-terminated " { $snippet "char*" } "; passing the result of calling " { $link length } " on the string object will not suffice. This is because a Factor string of " { $emphasis "n" } " characters will not necessarily encode to " { $emphasis "n" } " bytes. The correct idiom for C functions which take a string with a length is to first encode the string using " { $link encode } ", and then pass the resulting byte array together with the length of this byte array." +$nl +"Sometimes a C function has a parameter type of " { $snippet "void*" } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:" +{ $subsection string>alien } +{ $subsection malloc-string } +"The first allocates " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches." +$nl +"A word to read strings from arbitrary addresses:" +{ $subsection alien>string } +"For example, if a C function returns a " { $snippet "char*" } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "void*" } ", and call one of the above words before passing the pointer to " { $link free } "." ; + ARTICLE: "byte-arrays-gc" "Byte arrays and the garbage collector" "The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the garbage collector will not run while C code still has a reference to the data." $nl diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index dc35f8bbb0..9cd57f61ab 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -2,9 +2,10 @@ ! See http://factorcode.org/license.txt for BSD license. USING: byte-arrays arrays assocs kernel kernel.private libc math namespaces make parser sequences strings words assocs splitting -math.parser cpu.architecture alien alien.accessors quotations -layouts system compiler.units io.files io.encodings.binary -accessors combinators effects continuations fry classes ; +math.parser cpu.architecture alien alien.accessors alien.strings +quotations layouts system compiler.units io io.files +io.encodings.binary io.streams.memory accessors combinators effects +continuations fry classes ; IN: alien.c-types DEFER: @@ -213,6 +214,15 @@ M: f byte-length drop 0 ; : memory>byte-array ( alien len -- byte-array ) [ nip (byte-array) dup ] 2keep memcpy ; +: malloc-string ( string encoding -- alien ) + string>alien malloc-byte-array ; + +M: memory-stream stream-read + [ + [ index>> ] [ alien>> ] bi + swap memory>byte-array + ] [ [ + ] change-index drop ] 2bi ; + : byte-array>memory ( byte-array base -- ) swap dup byte-length memcpy ; diff --git a/basis/alien/libraries/libraries.factor b/basis/alien/libraries/libraries.factor index 3fcc15974c..6c18065ab6 100644 --- a/basis/alien/libraries/libraries.factor +++ b/basis/alien/libraries/libraries.factor @@ -1,8 +1,12 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien assocs io.backend kernel namespaces ; +USING: accessors alien alien.strings assocs io.backend kernel namespaces ; IN: alien.libraries +: dlopen ( path -- dll ) native-string>alien (dlopen) ; + +: dlsym ( name dll -- alien ) [ native-string>alien ] dip (dlsym) ; + SYMBOL: libraries libraries [ H{ } clone ] initialize @@ -18,4 +22,4 @@ TUPLE: library path abi dll ; library dup [ dll>> ] when ; : add-library ( name path abi -- ) - swap libraries get set-at ; + swap libraries get set-at ; \ No newline at end of file diff --git a/basis/alien/strings/strings-docs.factor b/basis/alien/strings/strings-docs.factor deleted file mode 100644 index 19c29e613e..0000000000 --- a/basis/alien/strings/strings-docs.factor +++ /dev/null @@ -1,52 +0,0 @@ -USING: help.markup help.syntax strings byte-arrays alien libc -debugger io.encodings.string sequences ; -IN: alien.strings - -HELP: string>alien -{ $values { "string" string } { "encoding" "an encoding descriptor" } { "byte-array" byte-array } } -{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated byte array." } -{ $errors "Throws an error if the string contains null characters, or characters not representable in the given encoding." } ; - -{ string>alien alien>string malloc-string } related-words - -HELP: alien>string -{ $values { "c-ptr" c-ptr } { "encoding" "an encoding descriptor" } { "string/f" "a string or " { $link f } } } -{ $description "Reads a null-terminated C string from the specified address with the given encoding." } ; - -HELP: malloc-string -{ $values { "string" string } { "encoding" "an encoding descriptor" } { "alien" c-ptr } } -{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated unmanaged memory block." } -{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." } -{ $errors "Throws an error if one of the following conditions occurs:" - { $list - "the string contains null code points" - "the string contains characters not representable using the encoding specified" - "memory allocation fails" - } -} ; - -HELP: string>symbol -{ $values { "str" string } { "alien" alien } } -{ $description "Converts the string to a format which is a valid symbol name for the Factor VM's compiled code linker. By performing this conversion ahead of time, the image loader can run without allocating memory." -$nl -"On Windows CE, symbols are represented as UCS2 strings, and on all other platforms they are ASCII strings." } ; - -ARTICLE: "c-strings" "C strings" -"C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors." -$nl -"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function." -$nl -"If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown." -$nl -"Care must be taken if the C function expects a " { $snippet "char*" } " with a length in bytes, rather than a null-terminated " { $snippet "char*" } "; passing the result of calling " { $link length } " on the string object will not suffice. This is because a Factor string of " { $emphasis "n" } " characters will not necessarily encode to " { $emphasis "n" } " bytes. The correct idiom for C functions which take a string with a length is to first encode the string using " { $link encode } ", and then pass the resulting byte array together with the length of this byte array." -$nl -"Sometimes a C function has a parameter type of " { $snippet "void*" } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:" -{ $subsection string>alien } -{ $subsection malloc-string } -"The first allocates " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches." -$nl -"A word to read strings from arbitrary addresses:" -{ $subsection alien>string } -"For example, if a C function returns a " { $snippet "char*" } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "void*" } ", and call one of the above words before passing the pointer to " { $link free } "." ; - -ABOUT: "c-strings" diff --git a/basis/alien/strings/strings.factor b/basis/alien/strings/strings.factor deleted file mode 100644 index e9053cd5c1..0000000000 --- a/basis/alien/strings/strings.factor +++ /dev/null @@ -1,109 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: arrays sequences kernel accessors math alien.accessors -alien.c-types byte-arrays words io io.encodings -io.encodings.utf8 io.streams.byte-array io.streams.memory system -alien strings cpu.architecture fry vocabs.loader combinators ; -IN: alien.strings - -GENERIC# alien>string 1 ( c-ptr encoding -- string/f ) - -M: c-ptr alien>string - [ ] [ ] bi* - "\0" swap stream-read-until drop ; - -M: f alien>string - drop ; - -ERROR: invalid-c-string string ; - -: check-string ( string -- ) - 0 over memq? [ invalid-c-string ] [ drop ] if ; - -GENERIC# string>alien 1 ( string encoding -- byte-array ) - -M: c-ptr string>alien drop ; - -M: string string>alien - over check-string - - [ stream-write ] - [ 0 swap stream-write1 ] - [ stream>> >byte-array ] - tri ; - -: malloc-string ( string encoding -- alien ) - string>alien malloc-byte-array ; - -PREDICATE: string-type < pair - first2 [ "char*" = ] [ word? ] bi* and ; - -M: string-type c-type ; - -M: string-type c-type-class - drop object ; - -M: string-type heap-size - drop "void*" heap-size ; - -M: string-type c-type-align - drop "void*" c-type-align ; - -M: string-type c-type-stack-align? - drop "void*" c-type-stack-align? ; - -M: string-type unbox-parameter - drop "void*" unbox-parameter ; - -M: string-type unbox-return - drop "void*" unbox-return ; - -M: string-type box-parameter - drop "void*" box-parameter ; - -M: string-type box-return - drop "void*" box-return ; - -M: string-type stack-size - drop "void*" stack-size ; - -M: string-type c-type-reg-class - drop int-regs ; - -M: string-type c-type-boxer - drop "void*" c-type-boxer ; - -M: string-type c-type-unboxer - drop "void*" c-type-unboxer ; - -M: string-type c-type-boxer-quot - second '[ _ alien>string ] ; - -M: string-type c-type-unboxer-quot - second '[ _ string>alien ] ; - -M: string-type c-type-getter - drop [ alien-cell ] ; - -M: string-type c-type-setter - drop [ set-alien-cell ] ; - -HOOK: alien>native-string os ( alien -- string ) - -HOOK: native-string>alien os ( string -- alien ) - -: dll-path ( dll -- string ) - path>> alien>native-string ; - -: string>symbol ( str -- alien ) - dup string? - [ native-string>alien ] - [ [ native-string>alien ] map ] if ; - -{ "char*" utf8 } "char*" typedef -"char*" "uchar*" typedef - -{ - { [ os windows? ] [ "alien.strings.windows" require ] } - { [ os unix? ] [ "alien.strings.unix" require ] } -} cond diff --git a/basis/alien/strings/unix/summary.txt b/basis/alien/strings/unix/summary.txt deleted file mode 100644 index 27e7f4cfb1..0000000000 --- a/basis/alien/strings/unix/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Default string encoding on Unix diff --git a/basis/alien/strings/unix/unix.factor b/basis/alien/strings/unix/unix.factor deleted file mode 100644 index a7b1467344..0000000000 --- a/basis/alien/strings/unix/unix.factor +++ /dev/null @@ -1,8 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: alien.strings io.encodings.utf8 system ; -IN: alien.strings.unix - -M: unix alien>native-string utf8 alien>string ; - -M: unix native-string>alien utf8 string>alien ; diff --git a/basis/alien/strings/windows/summary.txt b/basis/alien/strings/windows/summary.txt deleted file mode 100644 index 42bffbb300..0000000000 --- a/basis/alien/strings/windows/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Default string encoding on Windows diff --git a/basis/alien/strings/windows/tags.txt b/basis/alien/strings/windows/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/alien/strings/windows/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/alien/strings/windows/windows.factor b/basis/alien/strings/windows/windows.factor deleted file mode 100644 index 55c69246de..0000000000 --- a/basis/alien/strings/windows/windows.factor +++ /dev/null @@ -1,13 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: alien.strings alien.c-types io.encodings.utf8 -io.encodings.utf16n system ; -IN: alien.strings.windows - -M: windows alien>native-string utf16n alien>string ; - -M: wince native-string>alien utf16n string>alien ; - -M: winnt native-string>alien utf8 string>alien ; - -{ "char*" utf16n } "wchar_t*" typedef diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index 14c08c070a..9d19e4a231 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -65,7 +65,6 @@ SYMBOL: bootstrap-time "stage2: deployment mode" print ] [ "debugger" require - "alien.prettyprint" require "inspector" require "tools.errors" require "listener" require diff --git a/basis/command-line/command-line.factor b/basis/command-line/command-line.factor index 56d7fbd207..f2da4ebdf5 100644 --- a/basis/command-line/command-line.factor +++ b/basis/command-line/command-line.factor @@ -1,14 +1,14 @@ -! Copyright (C) 2003, 2008 Slava Pestov. +! Copyright (C) 2003, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: init continuations hashtables io io.encodings.utf8 io.files io.pathnames kernel kernel.private namespaces parser -sequences strings system splitting vocabs.loader ; +sequences strings system splitting vocabs.loader alien.strings ; IN: command-line SYMBOL: script SYMBOL: command-line -: (command-line) ( -- args ) 10 getenv sift ; +: (command-line) ( -- args ) 10 getenv sift [ alien>native-string ] map ; : rc-path ( name -- path ) os windows? [ "." prepend ] unless diff --git a/basis/compiler/tests/simple.factor b/basis/compiler/tests/simple.factor index 88dc9a53b1..da021412fe 100644 --- a/basis/compiler/tests/simple.factor +++ b/basis/compiler/tests/simple.factor @@ -60,8 +60,8 @@ IN: compiler.tests.simple ! Make sure error reporting works -[ [ dup ] compile-call ] must-fail -[ [ drop ] compile-call ] must-fail +! [ [ dup ] compile-call ] must-fail +! [ [ drop ] compile-call ] must-fail ! Regression diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 2091a26133..bb0268f048 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -1,14 +1,13 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: slots arrays definitions generic hashtables summary io -kernel math namespaces make prettyprint prettyprint.config -sequences assocs sequences.private strings io.styles -io.pathnames vectors words system splitting math.parser -classes.mixin classes.tuple continuations continuations.private -combinators generic.math classes.builtin classes compiler.units -generic.standard generic.single vocabs init kernel.private io.encodings -accessors math.order destructors source-files parser -classes.tuple.parser effects.parser lexer +USING: slots arrays definitions generic hashtables summary io kernel +math namespaces make prettyprint prettyprint.config sequences assocs +sequences.private strings io.styles io.pathnames vectors words system +splitting math.parser classes.mixin classes.tuple continuations +continuations.private combinators generic.math classes.builtin classes +compiler.units generic.standard generic.single vocabs init +kernel.private io.encodings accessors math.order destructors +source-files parser classes.tuple.parser effects.parser lexer generic.parser strings.parser vocabs.loader vocabs.parser see source-files.errors ; IN: debugger @@ -17,6 +16,7 @@ GENERIC: error. ( error -- ) GENERIC: error-help ( error -- topic ) M: object error. . ; + M: object error-help drop f ; M: tuple error-help class ; @@ -77,7 +77,7 @@ M: string error. print ; "Object did not survive image save/load: " write third . ; : io-error. ( error -- ) - "I/O error: " write third print ; + "I/O error #" write third . ; : type-check-error. ( obj -- ) "Type check error" print @@ -98,9 +98,7 @@ HOOK: signal-error. os ( obj -- ) "Cannot convert to C string: " write third . ; : ffi-error. ( obj -- ) - "FFI: " write - dup third [ write ": " write ] when* - fourth print ; + "FFI error" print drop ; : heap-scan-error. ( obj -- ) "Cannot do next-object outside begin/end-scan" print drop ; diff --git a/basis/io/encodings/iana/iana.factor b/basis/io/encodings/iana/iana.factor index 899bedfbc6..594e245a9c 100644 --- a/basis/io/encodings/iana/iana.factor +++ b/basis/io/encodings/iana/iana.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel strings values io.files assocs splitting sequences io namespaces sets -io.encodings.ascii io.encodings.utf8 ; +io.encodings.ascii io.encodings.utf8 io.encodings.utf16 ; IN: io.encodings.iana n-table [ initial-e>n ] initialize ] [ swap e>n-table get-global set-at ] 2bi ; ascii "ANSI_X3.4-1968" register-encoding +utf16be "UTF-16BE" register-encoding +utf16le "UTF-16LE" register-encoding +utf16 "UTF-16" register-encoding \ No newline at end of file diff --git a/basis/json/reader/reader.factor b/basis/json/reader/reader.factor index 0014ba1eb1..887a7a50e5 100644 --- a/basis/json/reader/reader.factor +++ b/basis/json/reader/reader.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Peter Burns. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel peg peg.ebnf math.parser math.private strings math +USING: kernel peg peg.ebnf math.parser math.parser.private strings math math.functions sequences arrays vectors hashtables assocs prettyprint json ; IN: json.reader diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index 1976c84fd1..5af29bf855 100644 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -1,11 +1,10 @@ -! Copyright (C) 2003, 2008 Slava Pestov. +! Copyright (C) 2003, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays byte-arrays generic hashtables io assocs -kernel math namespaces make sequences strings sbufs vectors +USING: accessors arrays byte-arrays byte-vectors generic hashtables io +assocs kernel math namespaces make sequences strings sbufs vectors words prettyprint.config prettyprint.custom prettyprint.sections -quotations io io.pathnames io.styles math.parser effects -classes.tuple math.order classes.tuple.private classes -combinators colors ; +quotations io io.pathnames io.styles math.parser effects classes.tuple +math.order classes.tuple.private classes combinators colors ; IN: prettyprint.backend M: effect pprint* effect>string "(" ")" surround text ; @@ -165,6 +164,7 @@ M: curry pprint-delims drop \ [ \ ] ; M: compose pprint-delims drop \ [ \ ] ; M: array pprint-delims drop \ { \ } ; M: byte-array pprint-delims drop \ B{ \ } ; +M: byte-vector pprint-delims drop \ BV{ \ } ; M: vector pprint-delims drop \ V{ \ } ; M: hashtable pprint-delims drop \ H{ \ } ; M: tuple pprint-delims drop \ T{ \ } ; @@ -173,6 +173,7 @@ M: callstack pprint-delims drop \ CS{ \ } ; M: object >pprint-sequence ; M: vector >pprint-sequence ; +M: byte-vector >pprint-sequence ; M: curry >pprint-sequence ; M: compose >pprint-sequence ; M: hashtable >pprint-sequence >alist ; @@ -202,6 +203,7 @@ M: object pprint-object ( obj -- ) M: object pprint* pprint-object ; M: vector pprint* pprint-object ; +M: byte-vector pprint* pprint-object ; M: hashtable pprint* pprint-object ; M: curry pprint* pprint-object ; M: compose pprint* pprint-object ; diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 4a9ff93179..f6f94bf20d 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -1,16 +1,16 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: fry accessors alien alien.accessors arrays byte-arrays -classes sequences.private continuations.private effects generic -hashtables hashtables.private io io.backend io.files -io.files.private io.streams.c kernel kernel.private math -math.private memory namespaces namespaces.private parser -quotations quotations.private sbufs sbufs.private -sequences sequences.private slots.private strings +USING: fry accessors alien alien.accessors arrays byte-arrays classes +sequences.private continuations.private effects generic hashtables +hashtables.private io io.backend io.files io.files.private +io.streams.c kernel kernel.private math math.private +math.parser.private memory memory.private namespaces +namespaces.private parser quotations quotations.private sbufs +sbufs.private sequences sequences.private slots.private strings strings.private system threads.private classes.tuple -classes.tuple.private vectors vectors.private words definitions -assocs summary compiler.units system.private -combinators combinators.short-circuit locals locals.backend locals.types +classes.tuple.private vectors vectors.private words definitions assocs +summary compiler.units system.private combinators +combinators.short-circuit locals locals.backend locals.types quotations.private combinators.private stack-checker.values generic.single generic.single.private alien.libraries @@ -290,11 +290,11 @@ M: object infer-call* \ bignum>float { bignum } { float } define-primitive \ bignum>float make-foldable -\ string>float { string } { float } define-primitive -\ string>float make-foldable +\ (string>float) { byte-array } { float } define-primitive +\ (string>float) make-foldable -\ float>string { float } { string } define-primitive -\ float>string make-foldable +\ (float>string) { float } { byte-array } define-primitive +\ (float>string) make-foldable \ float>bits { real } { integer } define-primitive \ float>bits make-foldable @@ -465,9 +465,9 @@ M: object infer-call* \ gc-stats { } { array } define-primitive -\ save-image { string } { } define-primitive +\ (save-image) { byte-array } { } define-primitive -\ save-image-and-exit { string } { } define-primitive +\ (save-image-and-exit) { byte-array } { } define-primitive \ data-room { } { integer integer array } define-primitive \ data-room make-flushable @@ -481,9 +481,9 @@ M: object infer-call* \ tag { object } { fixnum } define-primitive \ tag make-foldable -\ dlopen { string } { dll } define-primitive +\ (dlopen) { byte-array } { dll } define-primitive -\ dlsym { string object } { c-ptr } define-primitive +\ (dlsym) { byte-array object } { c-ptr } define-primitive \ dlclose { dll } { } define-primitive @@ -598,7 +598,7 @@ M: object infer-call* \ die { } { } define-primitive -\ fopen { string string } { alien } define-primitive +\ (fopen) { byte-array byte-array } { alien } define-primitive \ fgetc { alien } { object } define-primitive diff --git a/core/alien/strings/strings-docs.factor b/core/alien/strings/strings-docs.factor new file mode 100644 index 0000000000..388b9842db --- /dev/null +++ b/core/alien/strings/strings-docs.factor @@ -0,0 +1,20 @@ +USING: help.markup help.syntax strings byte-arrays alien libc +debugger io.encodings.string sequences ; +IN: alien.strings + +HELP: string>alien +{ $values { "string" string } { "encoding" "an encoding descriptor" } { "byte-array" byte-array } } +{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated byte array." } +{ $errors "Throws an error if the string contains null characters, or characters not representable in the given encoding." } ; + +HELP: alien>string +{ $values { "c-ptr" c-ptr } { "encoding" "an encoding descriptor" } { "string/f" "a string or " { $link f } } } +{ $description "Reads a null-terminated C string from the specified address with the given encoding." } ; + +HELP: string>symbol +{ $values { "str" string } { "alien" alien } } +{ $description "Converts the string to a format which is a valid symbol name for the Factor VM's compiled code linker. By performing this conversion ahead of time, the image loader can run without allocating memory." +$nl +"On Windows CE, symbols are represented as UCS2 strings, and on all other platforms they are ASCII strings." } ; + +ABOUT: "c-strings" diff --git a/basis/alien/strings/strings-tests.factor b/core/alien/strings/strings-tests.factor similarity index 100% rename from basis/alien/strings/strings-tests.factor rename to core/alien/strings/strings-tests.factor diff --git a/core/alien/strings/strings.factor b/core/alien/strings/strings.factor new file mode 100644 index 0000000000..943530d4f2 --- /dev/null +++ b/core/alien/strings/strings.factor @@ -0,0 +1,61 @@ +! Copyright (C) 2008, 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays sequences kernel kernel.private accessors math +alien.accessors byte-arrays io io.encodings io.encodings.utf8 +io.encodings.utf16n io.streams.byte-array io.streams.memory system +system.private alien strings combinators namespaces init ; +IN: alien.strings + +GENERIC# alien>string 1 ( c-ptr encoding -- string/f ) + +M: c-ptr alien>string + [ ] [ ] bi* + "\0" swap stream-read-until drop ; + +M: f alien>string + drop ; + +ERROR: invalid-c-string string ; + +: check-string ( string -- ) + 0 over memq? [ invalid-c-string ] [ drop ] if ; + +GENERIC# string>alien 1 ( string encoding -- byte-array ) + +M: c-ptr string>alien drop ; + +M: string string>alien + over check-string + + [ stream-write ] + [ 0 swap stream-write1 ] + [ stream>> >byte-array ] + tri ; + +HOOK: alien>native-string os ( alien -- string ) + +HOOK: native-string>alien os ( string -- alien ) + +M: windows alien>native-string utf16n alien>string ; + +M: wince native-string>alien utf16n string>alien ; + +M: winnt native-string>alien utf8 string>alien ; + +M: unix alien>native-string utf8 alien>string ; + +M: unix native-string>alien utf8 string>alien ; + +: dll-path ( dll -- string ) + path>> alien>native-string ; + +: string>symbol ( str -- alien ) + dup string? + [ native-string>alien ] + [ [ native-string>alien ] map ] if ; + +[ + 8 getenv utf8 alien>string string>cpu \ cpu set-global + 9 getenv utf8 alien>string string>os \ os set-global +] "alien.strings" add-init-hook + diff --git a/basis/alien/strings/summary.txt b/core/alien/strings/summary.txt similarity index 100% rename from basis/alien/strings/summary.txt rename to core/alien/strings/summary.txt diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index c0d51477ca..1aed59503c 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -82,8 +82,10 @@ bootstrapping? on "kernel" "kernel.private" "math" + "math.parser.private" "math.private" "memory" + "memory.private" "quotations" "quotations.private" "sbufs" @@ -366,8 +368,8 @@ tuple { "float>bignum" "math.private" (( x -- y )) } { "fixnum>float" "math.private" (( x -- y )) } { "bignum>float" "math.private" (( x -- y )) } - { "string>float" "math.private" (( str -- n/f )) } - { "float>string" "math.private" (( n -- str )) } + { "(string>float)" "math.parser.private" (( str -- n/f )) } + { "(float>string)" "math.parser.private" (( n -- str )) } { "float>bits" "math" (( x -- n )) } { "double>bits" "math" (( x -- n )) } { "bits>float" "math" (( n -- x )) } @@ -414,8 +416,8 @@ tuple { "(exists?)" "io.files.private" (( path -- ? )) } { "gc" "memory" (( -- )) } { "gc-stats" "memory" f } - { "save-image" "memory" (( path -- )) } - { "save-image-and-exit" "memory" (( path -- )) } + { "(save-image)" "memory.private" (( path -- )) } + { "(save-image-and-exit)" "memory.private" (( path -- )) } { "datastack" "kernel" (( -- ds )) } { "retainstack" "kernel" (( -- rs )) } { "callstack" "kernel" (( -- cs )) } @@ -427,38 +429,38 @@ tuple { "code-room" "memory" (( -- code-free code-total )) } { "micros" "system" (( -- us )) } { "modify-code-heap" "compiler.units" (( alist -- )) } - { "dlopen" "alien.libraries" (( path -- dll )) } - { "dlsym" "alien.libraries" (( name dll -- alien )) } + { "(dlopen)" "alien.libraries" (( path -- dll )) } + { "(dlsym)" "alien.libraries" (( name dll -- alien )) } { "dlclose" "alien.libraries" (( dll -- )) } { "" "byte-arrays" (( n -- byte-array )) } { "(byte-array)" "byte-arrays" (( n -- byte-array )) } { "" "alien" (( displacement c-ptr -- alien )) } - { "alien-signed-cell" "alien.accessors" f } - { "set-alien-signed-cell" "alien.accessors" f } - { "alien-unsigned-cell" "alien.accessors" f } - { "set-alien-unsigned-cell" "alien.accessors" f } - { "alien-signed-8" "alien.accessors" f } - { "set-alien-signed-8" "alien.accessors" f } - { "alien-unsigned-8" "alien.accessors" f } - { "set-alien-unsigned-8" "alien.accessors" f } - { "alien-signed-4" "alien.accessors" f } - { "set-alien-signed-4" "alien.accessors" f } - { "alien-unsigned-4" "alien.accessors" f } - { "set-alien-unsigned-4" "alien.accessors" f } - { "alien-signed-2" "alien.accessors" f } - { "set-alien-signed-2" "alien.accessors" f } - { "alien-unsigned-2" "alien.accessors" f } - { "set-alien-unsigned-2" "alien.accessors" f } - { "alien-signed-1" "alien.accessors" f } - { "set-alien-signed-1" "alien.accessors" f } - { "alien-unsigned-1" "alien.accessors" f } - { "set-alien-unsigned-1" "alien.accessors" f } - { "alien-float" "alien.accessors" f } - { "set-alien-float" "alien.accessors" f } - { "alien-double" "alien.accessors" f } - { "set-alien-double" "alien.accessors" f } - { "alien-cell" "alien.accessors" f } - { "set-alien-cell" "alien.accessors" f } + { "alien-signed-cell" "alien.accessors" (( c-ptr n -- value )) } + { "set-alien-signed-cell" "alien.accessors" (( value c-ptr n -- )) } + { "alien-unsigned-cell" "alien.accessors" (( c-ptr n -- value )) } + { "set-alien-unsigned-cell" "alien.accessors" (( value c-ptr n -- )) } + { "alien-signed-8" "alien.accessors" (( c-ptr n -- value )) } + { "set-alien-signed-8" "alien.accessors" (( value c-ptr n -- )) } + { "alien-unsigned-8" "alien.accessors" (( c-ptr n -- value )) } + { "set-alien-unsigned-8" "alien.accessors" (( value c-ptr n -- )) } + { "alien-signed-4" "alien.accessors" (( c-ptr n -- value )) } + { "set-alien-signed-4" "alien.accessors" (( value c-ptr n -- )) } + { "alien-unsigned-4" "alien.accessors" (( c-ptr n -- value )) } + { "set-alien-unsigned-4" "alien.accessors" (( value c-ptr n -- )) } + { "alien-signed-2" "alien.accessors" (( c-ptr n -- value )) } + { "set-alien-signed-2" "alien.accessors" (( value c-ptr n -- )) } + { "alien-unsigned-2" "alien.accessors" (( c-ptr n -- value )) } + { "set-alien-unsigned-2" "alien.accessors" (( value c-ptr n -- )) } + { "alien-signed-1" "alien.accessors" (( c-ptr n -- value )) } + { "set-alien-signed-1" "alien.accessors" (( value c-ptr n -- )) } + { "alien-unsigned-1" "alien.accessors" (( c-ptr n -- value )) } + { "set-alien-unsigned-1" "alien.accessors" (( value c-ptr n -- )) } + { "alien-float" "alien.accessors" (( c-ptr n -- value )) } + { "set-alien-float" "alien.accessors" (( value c-ptr n -- )) } + { "alien-double" "alien.accessors" (( c-ptr n -- value )) } + { "set-alien-double" "alien.accessors" (( value c-ptr n -- )) } + { "alien-cell" "alien.accessors" (( c-ptr n -- value )) } + { "set-alien-cell" "alien.accessors" (( value c-ptr n -- )) } { "alien-address" "alien" (( c-ptr -- addr )) } { "set-slot" "slots.private" (( value obj n -- )) } { "string-nth" "strings.private" (( n string -- ch )) } @@ -472,7 +474,7 @@ tuple { "end-scan" "memory" (( -- )) } { "size" "memory" (( obj -- n )) } { "die" "kernel" (( -- )) } - { "fopen" "io.streams.c" (( path mode -- alien )) } + { "(fopen)" "io.streams.c" (( path mode -- alien )) } { "fgetc" "io.streams.c" (( alien -- ch/f )) } { "fread" "io.streams.c" (( n alien -- str/f )) } { "fputc" "io.streams.c" (( ch alien -- )) } diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index a0b349be51..55b92df215 100644 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -16,6 +16,7 @@ IN: bootstrap.syntax " ; -SYNTAX: BV{ \ } [ >byte-vector ] parse-literal ; - -M: byte-vector pprint* pprint-object ; -M: byte-vector pprint-delims drop \ BV{ \ } ; -M: byte-vector >pprint-sequence ; - INSTANCE: byte-vector growable diff --git a/basis/byte-vectors/summary.txt b/core/byte-vectors/summary.txt similarity index 100% rename from basis/byte-vectors/summary.txt rename to core/byte-vectors/summary.txt diff --git a/basis/byte-vectors/tags.txt b/core/byte-vectors/tags.txt similarity index 100% rename from basis/byte-vectors/tags.txt rename to core/byte-vectors/tags.txt diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index a6af5b8c29..3069c4b555 100644 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -305,7 +305,16 @@ SINGLETON: sc [ sa ] [ sa { sa sb sc } min-class ] unit-test +[ f ] [ sa sb classes-intersect? ] unit-test + [ +lt+ ] [ integer sequence class<=> ] unit-test [ +lt+ ] [ sequence object class<=> ] unit-test [ +gt+ ] [ object sequence class<=> ] unit-test [ +eq+ ] [ integer integer class<=> ] unit-test + +! Limitations: + +! UNION: u1 sa sb ; +! UNION: u2 sc ; + +! [ f ] [ u1 u2 classes-intersect? ] unit-test \ No newline at end of file diff --git a/basis/io/encodings/utf16/authors.txt b/core/io/encodings/utf16/authors.txt similarity index 100% rename from basis/io/encodings/utf16/authors.txt rename to core/io/encodings/utf16/authors.txt diff --git a/basis/io/encodings/utf16/summary.txt b/core/io/encodings/utf16/summary.txt similarity index 100% rename from basis/io/encodings/utf16/summary.txt rename to core/io/encodings/utf16/summary.txt diff --git a/basis/io/encodings/utf16/utf16-docs.factor b/core/io/encodings/utf16/utf16-docs.factor similarity index 100% rename from basis/io/encodings/utf16/utf16-docs.factor rename to core/io/encodings/utf16/utf16-docs.factor diff --git a/basis/io/encodings/utf16/utf16-tests.factor b/core/io/encodings/utf16/utf16-tests.factor similarity index 100% rename from basis/io/encodings/utf16/utf16-tests.factor rename to core/io/encodings/utf16/utf16-tests.factor diff --git a/basis/io/encodings/utf16/utf16.factor b/core/io/encodings/utf16/utf16.factor similarity index 94% rename from basis/io/encodings/utf16/utf16.factor rename to core/io/encodings/utf16/utf16.factor index d61c07f806..a6ccc95bf5 100644 --- a/basis/io/encodings/utf16/utf16.factor +++ b/core/io/encodings/utf16/utf16.factor @@ -1,21 +1,15 @@ ! Copyright (C) 2006, 2009 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: math kernel sequences sbufs vectors namespaces io.binary -io.encodings combinators splitting io byte-arrays io.encodings.iana ; +io.encodings combinators splitting io byte-arrays ; IN: io.encodings.utf16 SINGLETON: utf16be -utf16be "UTF-16BE" register-encoding - SINGLETON: utf16le -utf16le "UTF-16LE" register-encoding - SINGLETON: utf16 -utf16 "UTF-16" register-encoding - ERROR: missing-bom ; drop utf16n ; diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 1bc282e956..b2f2f87ad0 100644 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -1,7 +1,8 @@ -! Copyright (C) 2004, 2008 Slava Pestov, Daniel Ehrenberg. +! Copyright (C) 2004, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: kernel kernel.private sequences init namespaces system io -io.backend io.pathnames io.encodings io.files.private ; +io.backend io.pathnames io.encodings io.files.private +alien.strings ; IN: io.files HOOK: (file-reader) io-backend ( path -- stream ) @@ -40,7 +41,8 @@ HOOK: (file-appender) io-backend ( path -- stream ) : with-file-appender ( path encoding quot -- ) [ ] dip with-output-stream ; inline -: exists? ( path -- ? ) normalize-path (exists?) ; +: exists? ( path -- ? ) + normalize-path native-string>alien (exists?) ; ! Current directory [ cwd current-directory set-global - 13 getenv cwd prepend-path \ image set-global - 14 getenv cwd prepend-path \ vm set-global + 13 getenv alien>native-string cwd prepend-path \ image set-global + 14 getenv alien>native-string cwd prepend-path \ vm set-global image parent-directory "resource-path" set-global ] "io.files" add-init-hook diff --git a/basis/io/streams/byte-array/byte-array-docs.factor b/core/io/streams/byte-array/byte-array-docs.factor similarity index 100% rename from basis/io/streams/byte-array/byte-array-docs.factor rename to core/io/streams/byte-array/byte-array-docs.factor diff --git a/basis/io/streams/byte-array/byte-array-tests.factor b/core/io/streams/byte-array/byte-array-tests.factor similarity index 100% rename from basis/io/streams/byte-array/byte-array-tests.factor rename to core/io/streams/byte-array/byte-array-tests.factor diff --git a/basis/io/streams/byte-array/byte-array.factor b/core/io/streams/byte-array/byte-array.factor similarity index 90% rename from basis/io/streams/byte-array/byte-array.factor rename to core/io/streams/byte-array/byte-array.factor index 2ffb9b9a63..4cb50dfbc1 100644 --- a/basis/io/streams/byte-array/byte-array.factor +++ b/core/io/streams/byte-array/byte-array.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: byte-arrays byte-vectors kernel io.encodings io.streams.string -sequences io namespaces io.encodings.private accessors sequences.private +USING: byte-arrays byte-vectors kernel io.encodings sequences io +namespaces io.encodings.private accessors sequences.private io.streams.sequence destructors math combinators ; IN: io.streams.byte-array diff --git a/basis/io/streams/byte-array/summary.txt b/core/io/streams/byte-array/summary.txt similarity index 100% rename from basis/io/streams/byte-array/summary.txt rename to core/io/streams/byte-array/summary.txt diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor index bec3bdc6bf..e25db47cdf 100755 --- a/core/io/streams/c/c.factor +++ b/core/io/streams/c/c.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel kernel.private namespaces make io io.encodings -sequences math generic threads.private classes io.backend -io.files continuations destructors byte-arrays accessors -combinators ; +USING: kernel kernel.private namespaces make io io.encodings sequences +math generic threads.private classes io.backend io.files +io.encodings.utf8 alien.strings continuations destructors byte-arrays +accessors combinators ; IN: io.streams.c TUPLE: c-stream handle disposed ; @@ -69,6 +69,9 @@ M: c-io-backend (init-stdio) init-c-stdio t ; M: c-io-backend io-multiplex 60 60 * 1000 * 1000 * or (sleep) ; +: fopen ( path mode -- handle ) + [ utf8 string>alien ] bi@ (fopen) ; + M: c-io-backend (file-reader) "rb" fopen ; diff --git a/basis/io/streams/memory/memory.factor b/core/io/streams/memory/memory.factor similarity index 62% rename from basis/io/streams/memory/memory.factor rename to core/io/streams/memory/memory.factor index 52169de6f8..ad5453af61 100644 --- a/basis/io/streams/memory/memory.factor +++ b/core/io/streams/memory/memory.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors alien alien.c-types alien.accessors math io ; +USING: kernel accessors alien alien.accessors math io ; IN: io.streams.memory TUPLE: memory-stream alien index ; @@ -13,9 +13,3 @@ M: memory-stream stream-element-type drop +byte+ ; M: memory-stream stream-read1 [ [ alien>> ] [ index>> ] bi alien-unsigned-1 ] [ [ 1+ ] change-index drop ] bi ; - -M: memory-stream stream-read - [ - [ index>> ] [ alien>> ] bi - swap memory>byte-array - ] [ [ + ] change-index drop ] 2bi ; diff --git a/basis/io/streams/memory/summary.txt b/core/io/streams/memory/summary.txt similarity index 100% rename from basis/io/streams/memory/summary.txt rename to core/io/streams/memory/summary.txt diff --git a/core/math/parser/parser-docs.factor b/core/math/parser/parser-docs.factor index ba0df3e357..beb2312f2a 100644 --- a/core/math/parser/parser-docs.factor +++ b/core/math/parser/parser-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax math math.private prettyprint +USING: help.markup help.syntax math math.parser.private prettyprint namespaces make strings ; IN: math.parser diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index 3fd62e69a0..1736a00be4 100644 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math.private namespaces sequences sequences.private -strings arrays combinators splitting math assocs make ; +strings arrays combinators splitting math assocs byte-arrays make ; IN: math.parser : digit> ( ch -- n ) @@ -79,6 +79,9 @@ SYMBOL: negative? string>natural ] if ; inline +: string>float ( str -- n/f ) + >byte-array 0 suffix (string>float) ; + PRIVATE> : base> ( str radix -- n/f ) @@ -149,13 +152,18 @@ M: ratio >base [ ".0" append ] } cond ; +: float>string ( x -- str ) + (float>string) + [ 0 = ] trim-tail >string + fix-float ; + M: float >base drop { { [ dup fp-nan? ] [ drop "0/0." ] } { [ dup 1/0. = ] [ drop "1/0." ] } { [ dup -1/0. = ] [ drop "-1/0." ] } { [ dup double>bits HEX: 8000000000000000 = ] [ drop "-0.0" ] } - [ float>string fix-float ] + [ float>string ] } cond ; : number>string ( n -- str ) 10 >base ; diff --git a/core/memory/memory.factor b/core/memory/memory.factor index 4b873ef6ec..c748f71c8e 100644 --- a/core/memory/memory.factor +++ b/core/memory/memory.factor @@ -1,6 +1,7 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel continuations sequences vectors arrays system math ; +USING: kernel continuations sequences vectors arrays system math +io.backend alien.strings memory.private ; IN: memory : (each-object) ( quot: ( obj -- ) -- ) @@ -21,4 +22,10 @@ IN: memory [ count-instances 100 + ] keep swap [ [ push-if ] 2curry each-object ] keep >array ; inline +: save-image ( path -- ) + normalize-path native-string>alien (save-image) ; + +: save-image-and-exit ( path -- ) + normalize-path native-string>alien (save-image) ; + : save ( -- ) image save-image ; diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 3512b92e4c..7d710717aa 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien arrays byte-arrays definitions generic +USING: accessors alien arrays byte-arrays byte-vectors definitions generic hashtables kernel math namespaces parser lexer sequences strings strings.parser sbufs vectors words words.symbol words.constant words.alias quotations io assocs splitting classes.tuple @@ -98,6 +98,7 @@ IN: bootstrap.syntax "{" [ \ } [ >array ] parse-literal ] define-core-syntax "V{" [ \ } [ >vector ] parse-literal ] define-core-syntax "B{" [ \ } [ >byte-array ] parse-literal ] define-core-syntax + "BV{" [ \ } [ >byte-vector ] parse-literal ] define-core-syntax "H{" [ \ } [ >hashtable ] parse-literal ] define-core-syntax "T{" [ parse-tuple-literal parsed ] define-core-syntax "W{" [ \ } [ first ] parse-literal ] define-core-syntax diff --git a/core/system/system.factor b/core/system/system.factor index 8f587d28c2..38b4a5fd9b 100644 --- a/core/system/system.factor +++ b/core/system/system.factor @@ -1,29 +1,20 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: system USING: kernel kernel.private sequences math namespaces init splitting assocs system.private layouts words ; +IN: system -SINGLETON: x86.32 -SINGLETON: x86.64 -SINGLETON: arm -SINGLETON: ppc +SINGLETONS: x86.32 x86.64 arm ppc ; UNION: x86 x86.32 x86.64 ; : cpu ( -- class ) \ cpu get-global ; foldable -SINGLETON: winnt -SINGLETON: wince +SINGLETONS: winnt wince ; UNION: windows winnt wince ; -SINGLETON: freebsd -SINGLETON: netbsd -SINGLETON: openbsd -SINGLETON: solaris -SINGLETON: macosx -SINGLETON: linux +SINGLETONS: freebsd netbsd openbsd solaris macosx linux ; SINGLETON: haiku @@ -62,11 +53,6 @@ PRIVATE> : vm ( -- path ) \ vm get-global ; -[ - 8 getenv string>cpu \ cpu set-global - 9 getenv string>os \ os set-global -] "system" add-init-hook - : embedded? ( -- ? ) 15 getenv ; : millis ( -- ms ) micros 1000 /i ; diff --git a/vmpp/alien.cpp b/vmpp/alien.cpp index f7c1d8919a..755d53346e 100755 --- a/vmpp/alien.cpp +++ b/vmpp/alien.cpp @@ -183,7 +183,8 @@ void box_medium_struct(CELL x1, CELL x2, CELL x3, CELL x4, CELL size) /* open a native library and push a handle */ void primitive_dlopen(void) { - gc_root path(tag_object(string_to_native_alien(untag_string(dpop())))); + gc_root path(dpop()); + path.untag_check(); gc_root dll(allot(sizeof(F_DLL))); dll->path = path.value(); ffi_dlopen(dll.untagged()); @@ -194,7 +195,11 @@ void primitive_dlopen(void) void primitive_dlsym(void) { gc_root dll(dpop()); - F_SYMBOL *sym = unbox_symbol_string(); + gc_root name(dpop()); + dll.untag_check(); + name.untag_check(); + + F_CHAR *sym = (F_CHAR *)(name.untagged() + 1); if(dll.value() == F) box_alien(ffi_dlsym(NULL,sym)); diff --git a/vmpp/code_block.cpp b/vmpp/code_block.cpp index 4e42a2be84..0d696ce430 100644 --- a/vmpp/code_block.cpp +++ b/vmpp/code_block.cpp @@ -340,10 +340,6 @@ void *get_rel_symbol(F_ARRAY *literals, CELL index) } } -#ifdef FACTOR_DEBUG - print_obj(symbol); nl(); fflush(stdout); -#endif - return (void *)undefined_symbol; } diff --git a/vmpp/factor.cpp b/vmpp/factor.cpp index 147dff913b..d7512e807a 100755 --- a/vmpp/factor.cpp +++ b/vmpp/factor.cpp @@ -132,10 +132,10 @@ void init_factor(F_PARAMETERS *p) init_profiler(); - userenv[CPU_ENV] = tag_object(from_char_string(FACTOR_CPU_STRING)); - userenv[OS_ENV] = tag_object(from_char_string(FACTOR_OS_STRING)); + userenv[CPU_ENV] = allot_alien(F,(CELL)FACTOR_CPU_STRING); + userenv[OS_ENV] = allot_alien(F,(CELL)FACTOR_OS_STRING); userenv[CELL_SIZE_ENV] = tag_fixnum(sizeof(CELL)); - userenv[EXECUTABLE_ENV] = (p->executable_path ? tag_object(from_native_string(p->executable_path)) : F); + userenv[EXECUTABLE_ENV] = allot_alien(F,(CELL)p->executable_path); userenv[ARGS_ENV] = F; userenv[EMBEDDED_ENV] = F; @@ -156,7 +156,7 @@ void pass_args_to_factor(int argc, F_CHAR **argv) int i; for(i = 1; i < argc; i++) - args.add(tag_object(from_native_string(argv[i]))); + args.add(allot_alien(F,(CELL)argv[i])); args.trim(); userenv[ARGS_ENV] = args.array.value(); diff --git a/vmpp/image.cpp b/vmpp/image.cpp index 83a48c8f24..b6c12fafc7 100755 --- a/vmpp/image.cpp +++ b/vmpp/image.cpp @@ -132,17 +132,18 @@ void primitive_save_image(void) /* do a full GC to push everything into tenured space */ gc(); - save_image(unbox_native_string()); + gc_root path(dpop()); + path.untag_check(); + save_image((F_CHAR *)(path.untagged() + 1)); } void primitive_save_image_and_exit(void) -{ +{ /* We unbox this before doing anything else. This is the only point where we might throw an error, so we have to throw an error here since later steps destroy the current image. */ - F_CHAR *path = unbox_native_string(); - - REGISTER_C_STRING(path); + gc_root path(dpop()); + path.untag_check(); /* strip out userenv data which is set on startup anyway */ CELL i; @@ -157,10 +158,8 @@ void primitive_save_image_and_exit(void) compact_code_heap(); performing_compaction = false; - UNREGISTER_C_STRING(F_CHAR,path); - /* Save the image */ - if(save_image(path)) + if(save_image((F_CHAR *)(path.untagged() + 1))) exit(0); else exit(1); @@ -335,5 +334,5 @@ void load_image(F_PARAMETERS *p) relocate_code(); /* Store image path name */ - userenv[IMAGE_ENV] = tag_object(from_native_string(p->image_path)); + userenv[IMAGE_ENV] = allot_alien(F,(CELL)p->image_path); } diff --git a/vmpp/io.cpp b/vmpp/io.cpp index 4a61a317c2..d32f5b7290 100755 --- a/vmpp/io.cpp +++ b/vmpp/io.cpp @@ -25,20 +25,20 @@ void io_error(void) return; #endif - CELL error = tag_object(from_char_string(strerror(errno))); - general_error(ERROR_IO,error,F,NULL); + general_error(ERROR_IO,tag_fixnum(errno),F,NULL); } void primitive_fopen(void) { - char *mode = unbox_char_string(); - REGISTER_C_STRING(mode); - char *path = unbox_char_string(); - UNREGISTER_C_STRING(char,mode); + gc_root mode(dpop()); + gc_root path(dpop()); + mode.untag_check(); + path.untag_check(); for(;;) { - FILE *file = fopen(path,mode); + FILE *file = fopen((char *)(path.untagged() + 1), + (char *)(mode.untagged() + 1)); if(file == NULL) io_error(); else diff --git a/vmpp/local_roots.hpp b/vmpp/local_roots.hpp index 6dee443f78..34b51222f3 100644 --- a/vmpp/local_roots.hpp +++ b/vmpp/local_roots.hpp @@ -1,6 +1,6 @@ /* If a runtime function needs to call another function which potentially -allocates memory, it must store any local variable references to Factor -objects on the root stack */ +allocates memory, it must wrap any local variable references to Factor +objects in gc_root instances */ extern F_SEGMENT *gc_locals_region; extern CELL gc_locals; @@ -27,28 +27,5 @@ extern CELL extra_roots; DEFPUSHPOP(root_,extra_roots) -/* We ignore strings which point outside the data heap, but we might be given -a char* which points inside the data heap, in which case it is a root, for -example if we call unbox_char_string() the result is placed in a byte array */ -INLINE bool root_push_alien(const void *ptr) -{ - if(in_data_heap_p((CELL)ptr)) - { - F_BYTE_ARRAY *objptr = ((F_BYTE_ARRAY *)ptr) - 1; - if(objptr->header == tag_header(BYTE_ARRAY_TYPE)) - { - root_push(tag_object(objptr)); - return true; - } - } - - return false; -} - -#define REGISTER_C_STRING(obj) \ - bool obj##_root = root_push_alien((const char *)obj) -#define UNREGISTER_C_STRING(type,obj) \ - if(obj##_root) obj = (type *)alien_offset(root_pop()) - #define REGISTER_BIGNUM(obj) if(obj) root_push(tag_bignum(obj)) #define UNREGISTER_BIGNUM(obj) if(obj) obj = (untag_bignum_fast(root_pop())) diff --git a/vmpp/math.cpp b/vmpp/math.cpp index 856c9ec8b5..435270d21b 100644 --- a/vmpp/math.cpp +++ b/vmpp/math.cpp @@ -392,26 +392,23 @@ void primitive_bignum_to_float(void) void primitive_str_to_float(void) { - char *c_str, *end; - double f; - F_STRING *str = untag_string(dpeek()); - CELL capacity = string_capacity(str); + F_BYTE_ARRAY *bytes = untag_byte_array(dpeek()); + CELL capacity = array_capacity(bytes); - c_str = to_char_string(str,false); - end = c_str; - f = strtod(c_str,&end); - if(end != c_str + capacity) - drepl(F); - else + char *c_str = (char *)(bytes + 1); + char *end = c_str; + double f = strtod(c_str,&end); + if(end == c_str + capacity - 1) drepl(allot_float(f)); + else + drepl(F); } void primitive_float_to_str(void) { - char tmp[33]; - snprintf(tmp,32,"%.16g",untag_float(dpop())); - tmp[32] = '\0'; - box_char_string(tmp); + F_BYTE_ARRAY *array = allot_byte_array(33); + snprintf((char *)(array + 1),32,"%.16g",untag_float(dpop())); + dpush(tag_object(array)); } #define POP_FLOATS(x,y) \ diff --git a/vmpp/os-unix.cpp b/vmpp/os-unix.cpp index 19fc5cc4a4..d22b23c854 100755 --- a/vmpp/os-unix.cpp +++ b/vmpp/os-unix.cpp @@ -48,17 +48,15 @@ void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol) void ffi_dlclose(F_DLL *dll) { if(dlclose(dll->dll)) - { - general_error(ERROR_FFI,tag_object( - from_char_string(dlerror())),F,NULL); - } + general_error(ERROR_FFI,F,F,NULL); dll->dll = NULL; } void primitive_existsp(void) { struct stat sb; - box_boolean(stat(unbox_char_string(),&sb) >= 0); + char *path = (char *)(untag_byte_array(dpop()) + 1); + box_boolean(stat(path,&sb) >= 0); } F_SEGMENT *alloc_segment(CELL size) diff --git a/vmpp/os-unix.hpp b/vmpp/os-unix.hpp index 35abfee41c..6ea11cbf14 100755 --- a/vmpp/os-unix.hpp +++ b/vmpp/os-unix.hpp @@ -11,10 +11,7 @@ typedef char F_CHAR; typedef char F_SYMBOL; -#define from_native_string from_char_string -#define unbox_native_string unbox_char_string #define string_to_native_alien(string) string_to_char_alien(string,true) -#define unbox_symbol_string unbox_char_string #define STRING_LITERAL(string) string diff --git a/vmpp/os-windows-ce.hpp b/vmpp/os-windows-ce.hpp index a2be5fe475..bc10017262 100755 --- a/vmpp/os-windows-ce.hpp +++ b/vmpp/os-windows-ce.hpp @@ -7,9 +7,6 @@ typedef wchar_t F_SYMBOL; -#define unbox_symbol_string unbox_u16_string -#define from_symbol_string from_u16_string - #define FACTOR_OS_STRING "wince" #define FACTOR_DLL L"factor-ce.dll" #define FACTOR_DLL_NAME "factor-ce.dll" diff --git a/vmpp/os-windows-nt.hpp b/vmpp/os-windows-nt.hpp index 4e047b497c..8ae4121ae6 100755 --- a/vmpp/os-windows-nt.hpp +++ b/vmpp/os-windows-nt.hpp @@ -9,9 +9,6 @@ typedef char F_SYMBOL; -#define unbox_symbol_string unbox_char_string -#define from_symbol_string from_char_string - #define FACTOR_OS_STRING "winnt" #define FACTOR_DLL L"factor.dll" #define FACTOR_DLL_NAME "factor.dll" diff --git a/vmpp/os-windows.cpp b/vmpp/os-windows.cpp index 6bd7dd9956..0c1d3b3593 100755 --- a/vmpp/os-windows.cpp +++ b/vmpp/os-windows.cpp @@ -90,7 +90,7 @@ const F_CHAR *vm_executable_path(void) void primitive_existsp(void) { - F_CHAR *path = unbox_u16_string(); + F_CHAR *path = (F_CHAR *)(untag_byte_array(dpop()) + 1); box_boolean(windows_stat(path)); } diff --git a/vmpp/os-windows.hpp b/vmpp/os-windows.hpp index 9e00a6afa7..d1af660603 100755 --- a/vmpp/os-windows.hpp +++ b/vmpp/os-windows.hpp @@ -7,8 +7,6 @@ typedef wchar_t F_CHAR; -#define from_native_string from_u16_string -#define unbox_native_string unbox_u16_string #define string_to_native_alien(string) string_to_u16_alien(string,true) #define STRING_LITERAL(string) L##string diff --git a/vmpp/strings.cpp b/vmpp/strings.cpp index a69e7dd3c7..a01e9ea4d9 100644 --- a/vmpp/strings.cpp +++ b/vmpp/strings.cpp @@ -157,95 +157,6 @@ void primitive_resize_string(void) dpush(tag_object(reallot_string(string,capacity))); } -/* Some ugly macros to prevent a 2x code duplication */ - -#define MEMORY_TO_STRING(type,utype) \ - F_STRING *memory_to_##type##_string(const type *string, CELL length) \ - { \ - REGISTER_C_STRING(string); \ - gc_root s(allot_string_internal(length)); \ - UNREGISTER_C_STRING(type,string); \ - CELL i; \ - for(i = 0; i < length; i++) \ - { \ - set_string_nth(s.untagged(),i,(utype)*string); \ - string++; \ - } \ - return s.untagged(); \ - } \ - F_STRING *from_##type##_string(const type *str) \ - { \ - CELL length = 0; \ - const type *scan = str; \ - while(*scan++) length++; \ - return memory_to_##type##_string(str,length); \ - } \ - void box_##type##_string(const type *str) \ - { \ - dpush(str ? tag_object(from_##type##_string(str)) : F); \ - } - -MEMORY_TO_STRING(char,u8) -MEMORY_TO_STRING(u16,u16) -MEMORY_TO_STRING(u32,u32) - -bool check_string(F_STRING *s, CELL max) -{ - CELL capacity = string_capacity(s); - CELL i; - for(i = 0; i < capacity; i++) - { - CELL ch = string_nth(s,i); - if(ch == 0 || ch >= ((CELL)1 << (max * 8))) - return false; - } - return true; -} - -F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size) -{ - return allot_byte_array((capacity + 1) * size); -} - -#define STRING_TO_MEMORY(type) \ - void type##_string_to_memory(F_STRING *s, type *string) \ - { \ - CELL i; \ - CELL capacity = string_capacity(s); \ - for(i = 0; i < capacity; i++) \ - string[i] = string_nth(s,i); \ - } \ - void primitive_##type##_string_to_memory(void) \ - { \ - type *address = (type *)unbox_alien(); \ - F_STRING *str = untag_string(dpop()); \ - type##_string_to_memory(str,address); \ - } \ - F_BYTE_ARRAY *string_to_##type##_alien(F_STRING *s_, bool check) \ - { \ - gc_root s(s_); \ - CELL capacity = string_capacity(s.untagged()); \ - F_BYTE_ARRAY *_c_str; \ - if(check && !check_string(s.untagged(),sizeof(type))) \ - general_error(ERROR_C_STRING,s.value(),F,NULL); \ - _c_str = allot_c_string(capacity,sizeof(type)); \ - type *c_str = (type*)(_c_str + 1); \ - type##_string_to_memory(s.untagged(),c_str); \ - c_str[capacity] = 0; \ - return _c_str; \ - } \ - type *to_##type##_string(F_STRING *s, bool check) \ - { \ - return (type*)(string_to_##type##_alien(s,check) + 1); \ - } \ - type *unbox_##type##_string(void) \ - { \ - return to_##type##_string(untag_string(dpop()),true); \ - } - -STRING_TO_MEMORY(char); -STRING_TO_MEMORY(u16); - void primitive_string_nth(void) { F_STRING *string = untag_string_fast(dpop()); diff --git a/vmpp/strings.hpp b/vmpp/strings.hpp index 3248df3625..5545e7e3b4 100644 --- a/vmpp/strings.hpp +++ b/vmpp/strings.hpp @@ -19,24 +19,6 @@ void primitive_string(void); F_STRING *reallot_string(F_STRING *string, CELL capacity); void primitive_resize_string(void); -F_STRING *memory_to_char_string(const char *string, CELL length); -F_STRING *from_char_string(const char *c_string); -DLLEXPORT void box_char_string(const char *c_string); - -F_STRING *memory_to_u16_string(const u16 *string, CELL length); -F_STRING *from_u16_string(const u16 *c_string); -DLLEXPORT void box_u16_string(const u16 *c_string); - -void char_string_to_memory(F_STRING *s, char *string); -F_BYTE_ARRAY *string_to_char_alien(F_STRING *s, bool check); -char* to_char_string(F_STRING *s, bool check); -DLLEXPORT char *unbox_char_string(void); - -void u16_string_to_memory(F_STRING *s, u16 *string); -F_BYTE_ARRAY *string_to_u16_alien(F_STRING *s, bool check); -u16* to_u16_string(F_STRING *s, bool check); -DLLEXPORT u16 *unbox_u16_string(void); - /* String getters and setters */ CELL string_nth(F_STRING* string, CELL index); void set_string_nth(F_STRING* string, CELL index, CELL value); From 0614f54ba370ff892d0b06ba9f266a7b4cf1fb94 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 2 May 2009 20:01:54 -0500 Subject: [PATCH 09/44] Fix various issues from C++ port --- vmpp/callstack.cpp | 12 ++++++++++-- vmpp/data_heap.hpp | 6 ------ vmpp/errors.cpp | 20 ++++++++++---------- vmpp/errors.hpp | 4 ++-- vmpp/factor.cpp | 3 --- vmpp/mach_signal.cpp | 1 + vmpp/mach_signal.hpp | 4 ++++ vmpp/math.cpp | 6 ++---- 8 files changed, 29 insertions(+), 27 deletions(-) diff --git a/vmpp/callstack.cpp b/vmpp/callstack.cpp index ff50186a7d..1bbcdff9c5 100755 --- a/vmpp/callstack.cpp +++ b/vmpp/callstack.cpp @@ -1,5 +1,13 @@ #include "master.hpp" +static void check_frame(F_STACK_FRAME *frame) +{ +#ifdef FACTOR_DEBUG + check_code_pointer(frame->xt); + assert(frame->size != 0); +#endif +} + /* called before entry into Factor code. */ F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom) { @@ -90,6 +98,7 @@ void primitive_set_callstack(void) F_CODE_BLOCK *frame_code(F_STACK_FRAME *frame) { + check_frame(frame); return (F_CODE_BLOCK *)frame->xt - 1; } @@ -112,8 +121,7 @@ CELL frame_executing(F_STACK_FRAME *frame) F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame) { - if(frame->size == 0) - critical_error("Stack frame has zero size",(CELL)frame); + check_frame(frame); return (F_STACK_FRAME *)((CELL)frame - frame->size); } diff --git a/vmpp/data_heap.hpp b/vmpp/data_heap.hpp index 3b4231d98f..db3cbd52f8 100644 --- a/vmpp/data_heap.hpp +++ b/vmpp/data_heap.hpp @@ -99,12 +99,6 @@ void primitive_end_scan(void); /* GC is off during heap walking */ extern bool gc_off; -INLINE bool in_data_heap_p(CELL ptr) -{ - return (ptr >= data_heap->segment->start - && ptr <= data_heap->segment->end); -} - INLINE void *allot_zone(F_ZONE *z, CELL a) { CELL h = z->here; diff --git a/vmpp/errors.cpp b/vmpp/errors.cpp index 9ffc22d454..260f4e04c3 100755 --- a/vmpp/errors.cpp +++ b/vmpp/errors.cpp @@ -135,16 +135,6 @@ void divide_by_zero_error(void) general_error(ERROR_DIVIDE_BY_ZERO,F,F,NULL); } -void memory_signal_handler_impl(void) -{ - memory_protection_error(signal_fault_addr,signal_callstack_top); -} - -void misc_signal_handler_impl(void) -{ - signal_error(signal_number,signal_callstack_top); -} - void primitive_call_clear(void) { throw_impl(dpop(),stack_chain->callstack_bottom); @@ -155,3 +145,13 @@ void primitive_unimplemented(void) { not_implemented_error(); } + +void memory_signal_handler_impl(void) +{ + memory_protection_error(signal_fault_addr,signal_callstack_top); +} + +void misc_signal_handler_impl(void) +{ + signal_error(signal_number,signal_callstack_top); +} diff --git a/vmpp/errors.hpp b/vmpp/errors.hpp index 8a202da48b..0fc024de5e 100755 --- a/vmpp/errors.hpp +++ b/vmpp/errors.hpp @@ -50,6 +50,8 @@ INLINE void type_check(CELL type, CELL tagged) return untag_##name##_fast(obj); \ } \ +void primitive_unimplemented(void); + /* Global variables used to pass fault handler state from signal handler to user-space */ extern CELL signal_number; @@ -58,5 +60,3 @@ extern F_STACK_FRAME *signal_callstack_top; void memory_signal_handler_impl(void); void misc_signal_handler_impl(void); - -void primitive_unimplemented(void); diff --git a/vmpp/factor.cpp b/vmpp/factor.cpp index d7512e807a..59263e1da8 100755 --- a/vmpp/factor.cpp +++ b/vmpp/factor.cpp @@ -122,10 +122,7 @@ void init_factor(F_PARAMETERS *p) load_image(p); init_c_io(); init_inline_caching(p->max_pic_size); - -#ifndef FACTOR_DEBUG init_signals(); -#endif if(p->console) open_console(); diff --git a/vmpp/mach_signal.cpp b/vmpp/mach_signal.cpp index 3230c944d1..74f2e724ca 100644 --- a/vmpp/mach_signal.cpp +++ b/vmpp/mach_signal.cpp @@ -60,6 +60,7 @@ static void call_fault_handler(exception_type_t exception, /* Handle an exception by invoking the user's fault handler and/or forwarding the duty to the previously installed handlers. */ +extern "C" kern_return_t catch_exception_raise (mach_port_t exception_port, mach_port_t thread, diff --git a/vmpp/mach_signal.hpp b/vmpp/mach_signal.hpp index ee58a3acee..fdeef7b2a5 100644 --- a/vmpp/mach_signal.hpp +++ b/vmpp/mach_signal.hpp @@ -42,6 +42,7 @@ extern "C" boolean_t exc_server (mach_msg_header_t *request_msg, mach_msg_header /* http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/catch_exception_raise.html These functions are defined in this file, and called by exc_server. FIXME: What needs to be done when this code is put into a shared library? */ +extern "C" kern_return_t catch_exception_raise (mach_port_t exception_port, mach_port_t thread, @@ -49,6 +50,7 @@ catch_exception_raise (mach_port_t exception_port, exception_type_t exception, exception_data_t code, mach_msg_type_number_t code_count); +extern "C" kern_return_t catch_exception_raise_state (mach_port_t exception_port, exception_type_t exception, @@ -59,6 +61,8 @@ catch_exception_raise_state (mach_port_t exception_port, mach_msg_type_number_t in_state_count, thread_state_t out_state, mach_msg_type_number_t *out_state_count); + +extern "C" kern_return_t catch_exception_raise_state_identity (mach_port_t exception_port, mach_port_t thread, diff --git a/vmpp/math.cpp b/vmpp/math.cpp index 435270d21b..928f7dab7e 100644 --- a/vmpp/math.cpp +++ b/vmpp/math.cpp @@ -255,10 +255,8 @@ unsigned int bignum_producer(unsigned int digit) void primitive_byte_array_to_bignum(void) { - type_check(BYTE_ARRAY_TYPE,dpeek()); - CELL n_digits = array_capacity(untag_byte_array_fast(dpeek())) / CELLS; - F_BIGNUM * bignum = digit_stream_to_bignum( - n_digits,bignum_producer,0x100,0); + CELL n_digits = array_capacity(untag_byte_array(dpeek())); + F_BIGNUM * bignum = digit_stream_to_bignum(n_digits,bignum_producer,0x100,0); drepl(tag_bignum(bignum)); } From b923d548cf581df589f1d3e1e9c381e61e4dcb28 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 2 May 2009 20:37:18 -0500 Subject: [PATCH 10/44] Move vmpp to vm --- Makefile | 112 +- vm/Config.arm | 2 +- vm/Config.freebsd | 4 +- vm/Config.macosx | 2 +- vm/alien.c | 234 ---- {vmpp => vm}/alien.cpp | 10 +- vm/alien.h | 50 - {vmpp => vm}/alien.hpp | 4 - vm/arrays.c | 159 --- {vmpp => vm}/arrays.cpp | 6 +- vm/arrays.h | 95 -- {vmpp => vm}/arrays.hpp | 0 vm/bignum.c | 1878 ---------------------------- {vmpp => vm}/bignum.cpp | 0 vm/bignum.h | 127 -- {vmpp => vm}/bignum.hpp | 0 vm/bignumint.h | 100 -- {vmpp => vm}/bignumint.hpp | 0 vm/booleans.c | 13 - {vmpp => vm}/booleans.cpp | 0 vm/booleans.h | 7 - {vmpp => vm}/booleans.hpp | 0 vm/byte_arrays.c | 85 -- {vmpp => vm}/byte_arrays.cpp | 0 vm/byte_arrays.h | 40 - {vmpp => vm}/byte_arrays.hpp | 0 vm/callstack.c | 230 ---- {vmpp => vm}/callstack.cpp | 0 vm/callstack.h | 28 - {vmpp => vm}/callstack.hpp | 0 vm/code_block.c | 506 -------- {vmpp => vm}/code_block.cpp | 0 vm/code_block.h | 92 -- {vmpp => vm}/code_block.hpp | 0 vm/code_gc.c | 336 ----- {vmpp => vm}/code_gc.cpp | 0 vm/code_gc.h | 45 - {vmpp => vm}/code_gc.hpp | 0 vm/code_heap.c | 226 ---- {vmpp => vm}/code_heap.cpp | 0 vm/code_heap.h | 27 - {vmpp => vm}/code_heap.hpp | 0 vm/cpu-arm.h | 13 - {vmpp => vm}/cpu-arm.hpp | 0 vm/cpu-ppc.h | 12 - {vmpp => vm}/cpu-ppc.hpp | 0 vm/cpu-x86.32.h | 6 - {vmpp => vm}/cpu-x86.32.hpp | 0 vm/cpu-x86.64.h | 6 - {vmpp => vm}/cpu-x86.64.hpp | 0 vm/cpu-x86.h | 35 - {vmpp => vm}/cpu-x86.hpp | 0 vm/data_gc.c | 618 --------- {vmpp => vm}/data_gc.cpp | 0 vm/data_gc.h | 17 +- {vmpp => vm}/data_gc.hpp | 0 vm/data_heap.c | 366 ------ {vmpp => vm}/data_heap.cpp | 0 vm/data_heap.h | 138 -- {vmpp => vm}/data_heap.hpp | 0 vm/debug.c | 501 -------- {vmpp => vm}/debug.cpp | 0 vm/debug.h | 9 - {vmpp => vm}/debug.hpp | 0 vm/dispatch.c | 202 --- {vmpp => vm}/dispatch.cpp | 0 vm/dispatch.h | 16 - {vmpp => vm}/dispatch.hpp | 0 vm/errors.c | 151 --- {vmpp => vm}/errors.cpp | 0 vm/errors.h | 58 - {vmpp => vm}/errors.hpp | 0 vm/factor.c | 219 ---- {vmpp => vm}/factor.cpp | 0 vm/factor.h | 11 - {vmpp => vm}/factor.hpp | 0 vm/ffi_test.c | 6 +- vm/ffi_test.h | 2 + vm/float_bits.h | 40 - {vmpp => vm}/float_bits.hpp | 0 {vmpp => vm}/generic_arrays.hpp | 0 vm/image.c | 323 ----- {vmpp => vm}/image.cpp | 0 vm/image.h | 69 - {vmpp => vm}/image.hpp | 0 vm/inline_cache.c | 248 ---- {vmpp => vm}/inline_cache.cpp | 0 vm/inline_cache.h | 17 - {vmpp => vm}/inline_cache.hpp | 0 vm/io.c | 226 ---- {vmpp => vm}/io.cpp | 0 vm/io.h | 18 - {vmpp => vm}/io.hpp | 0 vm/jit.c | 119 -- {vmpp => vm}/jit.cpp | 0 vm/jit.h | 87 -- {vmpp => vm}/jit.hpp | 0 vm/layouts.h | 259 ---- {vmpp => vm}/layouts.hpp | 0 {vmpp => vm}/local_roots.cpp | 0 vm/local_roots.h | 68 - {vmpp => vm}/local_roots.hpp | 0 vm/mach_signal.c | 199 --- {vmpp => vm}/mach_signal.cpp | 0 vm/mach_signal.h | 80 -- {vmpp => vm}/mach_signal.hpp | 0 vm/main-unix.c | 7 - {vmpp => vm}/main-unix.cpp | 0 vm/main-windows-ce.c | 134 -- {vmpp => vm}/main-windows-ce.cpp | 0 vm/main-windows-nt.c | 27 - {vmpp => vm}/main-windows-nt.cpp | 0 vm/master.h | 59 - {vmpp => vm}/master.hpp | 0 vm/math.c | 515 -------- {vmpp => vm}/math.cpp | 0 vm/math.h | 151 --- {vmpp => vm}/math.hpp | 0 vm/os-freebsd-x86.32.h | 9 - {vmpp => vm}/os-freebsd-x86.32.hpp | 0 vm/os-freebsd-x86.64.h | 9 - {vmpp => vm}/os-freebsd-x86.64.hpp | 0 vm/os-freebsd.c | 34 - {vmpp => vm}/os-freebsd.cpp | 0 vm/os-freebsd.h | 9 - {vmpp => vm}/os-freebsd.hpp | 0 vm/os-genunix.c | 35 - {vmpp => vm}/os-genunix.cpp | 0 vm/os-genunix.h | 8 - {vmpp => vm}/os-genunix.hpp | 0 vm/os-linux-arm.c | 26 - {vmpp => vm}/os-linux-arm.cpp | 0 vm/os-linux-arm.h | 14 - {vmpp => vm}/os-linux-arm.hpp | 0 vm/os-linux-ppc.h | 12 - {vmpp => vm}/os-linux-ppc.hpp | 0 vm/os-linux-x86.32.h | 10 - {vmpp => vm}/os-linux-x86.32.hpp | 0 vm/os-linux-x86.64.h | 10 - {vmpp => vm}/os-linux-x86.64.hpp | 0 vm/os-linux.c | 58 - {vmpp => vm}/os-linux.cpp | 0 vm/os-linux.h | 5 - {vmpp => vm}/os-linux.hpp | 0 vm/os-macosx-ppc.h | 39 - {vmpp => vm}/os-macosx-ppc.hpp | 0 vm/os-macosx-x86.32.h | 37 - {vmpp => vm}/os-macosx-x86.32.hpp | 0 vm/os-macosx-x86.64.h | 37 - {vmpp => vm}/os-macosx-x86.64.hpp | 0 vm/os-macosx.h | 17 - {vmpp => vm}/os-macosx.hpp | 0 vm/os-macosx.m | 82 -- {vmpp => vm}/os-macosx.mm | 0 vm/os-netbsd-x86.32.h | 3 - {vmpp => vm}/os-netbsd-x86.32.hpp | 0 vm/os-netbsd-x86.64.h | 4 - {vmpp => vm}/os-netbsd-x86.64.hpp | 0 vm/os-netbsd.c | 11 - {vmpp => vm}/os-netbsd.cpp | 0 vm/os-netbsd.h | 5 - {vmpp => vm}/os-netbsd.hpp | 0 vm/os-openbsd-x86.32.h | 10 - {vmpp => vm}/os-openbsd-x86.32.hpp | 0 vm/os-openbsd-x86.64.h | 10 - {vmpp => vm}/os-openbsd-x86.64.hpp | 0 vm/os-openbsd.c | 6 - {vmpp => vm}/os-openbsd.cpp | 0 vm/os-solaris-x86.32.h | 10 - {vmpp => vm}/os-solaris-x86.32.hpp | 0 vm/os-solaris-x86.64.h | 10 - {vmpp => vm}/os-solaris-x86.64.hpp | 0 vm/os-solaris.c | 6 - {vmpp => vm}/os-solaris.cpp | 0 vm/os-unix.c | 313 ----- {vmpp => vm}/os-unix.cpp | 0 vm/os-unix.h | 59 - {vmpp => vm}/os-unix.hpp | 0 vm/os-windows-ce.c | 40 - {vmpp => vm}/os-windows-ce.cpp | 0 vm/os-windows-ce.h | 27 - {vmpp => vm}/os-windows-ce.hpp | 0 vm/os-windows-nt.32.h | 2 - {vmpp => vm}/os-windows-nt.32.hpp | 0 vm/os-windows-nt.64.h | 2 - {vmpp => vm}/os-windows-nt.64.hpp | 0 vm/os-windows-nt.c | 51 - {vmpp => vm}/os-windows-nt.cpp | 0 vm/os-windows-nt.h | 21 - {vmpp => vm}/os-windows-nt.hpp | 0 vm/os-windows.c | 147 --- {vmpp => vm}/os-windows.cpp | 0 vm/os-windows.h | 59 - {vmpp => vm}/os-windows.hpp | 0 vm/platform.h | 122 -- {vmpp => vm}/platform.hpp | 0 vm/primitives.c | 154 --- {vmpp => vm}/primitives.cpp | 0 vm/primitives.h | 1 - {vmpp => vm}/primitives.hpp | 0 vm/profiler.c | 51 - {vmpp => vm}/profiler.cpp | 0 vm/profiler.h | 3 - {vmpp => vm}/profiler.hpp | 0 vm/quotations.c | 374 ------ {vmpp => vm}/quotations.cpp | 0 vm/quotations.h | 15 - {vmpp => vm}/quotations.hpp | 0 vm/run.c | 248 ---- {vmpp => vm}/run.cpp | 0 vm/run.h | 277 ---- {vmpp => vm}/run.hpp | 0 vm/strings.c | 294 ----- {vmpp => vm}/strings.cpp | 0 vm/strings.h | 50 - {vmpp => vm}/strings.hpp | 0 {vmpp => vm}/tagged.hpp | 0 vm/test.cpp | 16 + vm/tuples.c | 35 - {vmpp => vm}/tuples.cpp | 0 vm/tuples.h | 25 - {vmpp => vm}/tuples.hpp | 0 vm/utilities.c | 55 - {vmpp => vm}/utilities.cpp | 0 vm/utilities.h | 10 - {vmpp => vm}/utilities.hpp | 0 vm/words.c | 82 -- {vmpp => vm}/words.cpp | 0 vm/words.h | 16 - {vmpp => vm}/words.hpp | 0 {vmpp => vm}/write_barrier.cpp | 0 vm/write_barrier.h | 66 - {vmpp => vm}/write_barrier.hpp | 0 vmpp/Config.arm | 1 - vmpp/Config.freebsd | 4 - vmpp/Config.freebsd.x86.32 | 2 - vmpp/Config.freebsd.x86.64 | 3 - vmpp/Config.linux | 4 - vmpp/Config.linux.arm | 3 - vmpp/Config.linux.ppc | 3 - vmpp/Config.linux.x86.32 | 2 - vmpp/Config.linux.x86.64 | 3 - vmpp/Config.macosx | 23 - vmpp/Config.macosx.ppc | 3 - vmpp/Config.macosx.x86.32 | 2 - vmpp/Config.macosx.x86.64 | 3 - vmpp/Config.netbsd | 5 - vmpp/Config.netbsd.x86.32 | 2 - vmpp/Config.netbsd.x86.64 | 2 - vmpp/Config.openbsd | 5 - vmpp/Config.openbsd.x86.32 | 2 - vmpp/Config.openbsd.x86.64 | 2 - vmpp/Config.ppc | 1 - vmpp/Config.solaris | 6 - vmpp/Config.solaris.x86.32 | 2 - vmpp/Config.solaris.x86.64 | 2 - vmpp/Config.unix | 27 - vmpp/Config.windows | 10 - vmpp/Config.windows.ce | 5 - vmpp/Config.windows.ce.arm | 4 - vmpp/Config.windows.nt | 10 - vmpp/Config.windows.nt.x86.32 | 4 - vmpp/Config.windows.nt.x86.64 | 6 - vmpp/Config.x86.32 | 5 - vmpp/Config.x86.64 | 2 - vmpp/asm.h | 16 - vmpp/cpu-arm.S | 127 -- vmpp/cpu-ppc.S | 236 ---- vmpp/cpu-x86.32.S | 76 -- vmpp/cpu-x86.64.S | 83 -- vmpp/cpu-x86.S | 74 -- vmpp/data_gc.h | 159 --- vmpp/factor.rs | 2 - vmpp/ffi_test.c | 321 ----- vmpp/ffi_test.h | 98 -- 275 files changed, 95 insertions(+), 13846 deletions(-) delete mode 100755 vm/alien.c rename {vmpp => vm}/alien.cpp (96%) delete mode 100755 vm/alien.h rename {vmpp => vm}/alien.hpp (95%) delete mode 100644 vm/arrays.c rename {vmpp => vm}/arrays.cpp (93%) delete mode 100644 vm/arrays.h rename {vmpp => vm}/arrays.hpp (100%) delete mode 100755 vm/bignum.c rename {vmpp => vm}/bignum.cpp (100%) delete mode 100644 vm/bignum.h rename {vmpp => vm}/bignum.hpp (100%) delete mode 100644 vm/bignumint.h rename {vmpp => vm}/bignumint.hpp (100%) delete mode 100644 vm/booleans.c rename {vmpp => vm}/booleans.cpp (100%) delete mode 100644 vm/booleans.h rename {vmpp => vm}/booleans.hpp (100%) delete mode 100644 vm/byte_arrays.c rename {vmpp => vm}/byte_arrays.cpp (100%) delete mode 100644 vm/byte_arrays.h rename {vmpp => vm}/byte_arrays.hpp (100%) delete mode 100755 vm/callstack.c rename {vmpp => vm}/callstack.cpp (100%) delete mode 100755 vm/callstack.h rename {vmpp => vm}/callstack.hpp (100%) delete mode 100644 vm/code_block.c rename {vmpp => vm}/code_block.cpp (100%) delete mode 100644 vm/code_block.h rename {vmpp => vm}/code_block.hpp (100%) delete mode 100755 vm/code_gc.c rename {vmpp => vm}/code_gc.cpp (100%) delete mode 100755 vm/code_gc.h rename {vmpp => vm}/code_gc.hpp (100%) delete mode 100755 vm/code_heap.c rename {vmpp => vm}/code_heap.cpp (100%) delete mode 100755 vm/code_heap.h rename {vmpp => vm}/code_heap.hpp (100%) delete mode 100755 vm/cpu-arm.h rename {vmpp => vm}/cpu-arm.hpp (100%) delete mode 100755 vm/cpu-ppc.h rename {vmpp => vm}/cpu-ppc.hpp (100%) delete mode 100755 vm/cpu-x86.32.h rename {vmpp => vm}/cpu-x86.32.hpp (100%) delete mode 100644 vm/cpu-x86.64.h rename {vmpp => vm}/cpu-x86.64.hpp (100%) delete mode 100755 vm/cpu-x86.h rename {vmpp => vm}/cpu-x86.hpp (100%) delete mode 100755 vm/data_gc.c rename {vmpp => vm}/data_gc.cpp (100%) mode change 100755 => 100644 vm/data_gc.h rename {vmpp => vm}/data_gc.hpp (100%) delete mode 100644 vm/data_heap.c rename {vmpp => vm}/data_heap.cpp (100%) delete mode 100644 vm/data_heap.h rename {vmpp => vm}/data_heap.hpp (100%) delete mode 100755 vm/debug.c rename {vmpp => vm}/debug.cpp (100%) delete mode 100755 vm/debug.h rename {vmpp => vm}/debug.hpp (100%) delete mode 100644 vm/dispatch.c rename {vmpp => vm}/dispatch.cpp (100%) delete mode 100644 vm/dispatch.h rename {vmpp => vm}/dispatch.hpp (100%) delete mode 100755 vm/errors.c rename {vmpp => vm}/errors.cpp (100%) delete mode 100755 vm/errors.h rename {vmpp => vm}/errors.hpp (100%) delete mode 100755 vm/factor.c rename {vmpp => vm}/factor.cpp (100%) delete mode 100644 vm/factor.h rename {vmpp => vm}/factor.hpp (100%) delete mode 100644 vm/float_bits.h rename {vmpp => vm}/float_bits.hpp (100%) rename {vmpp => vm}/generic_arrays.hpp (100%) delete mode 100755 vm/image.c rename {vmpp => vm}/image.cpp (100%) delete mode 100755 vm/image.h rename {vmpp => vm}/image.hpp (100%) delete mode 100644 vm/inline_cache.c rename {vmpp => vm}/inline_cache.cpp (100%) delete mode 100644 vm/inline_cache.h rename {vmpp => vm}/inline_cache.hpp (100%) delete mode 100755 vm/io.c rename {vmpp => vm}/io.cpp (100%) delete mode 100755 vm/io.h rename {vmpp => vm}/io.hpp (100%) delete mode 100644 vm/jit.c rename {vmpp => vm}/jit.cpp (100%) delete mode 100644 vm/jit.h rename {vmpp => vm}/jit.hpp (100%) delete mode 100755 vm/layouts.h rename {vmpp => vm}/layouts.hpp (100%) rename {vmpp => vm}/local_roots.cpp (100%) delete mode 100644 vm/local_roots.h rename {vmpp => vm}/local_roots.hpp (100%) delete mode 100644 vm/mach_signal.c rename {vmpp => vm}/mach_signal.cpp (100%) delete mode 100644 vm/mach_signal.h rename {vmpp => vm}/mach_signal.hpp (100%) delete mode 100644 vm/main-unix.c rename {vmpp => vm}/main-unix.cpp (100%) delete mode 100644 vm/main-windows-ce.c rename {vmpp => vm}/main-windows-ce.cpp (100%) delete mode 100755 vm/main-windows-nt.c rename {vmpp => vm}/main-windows-nt.cpp (100%) delete mode 100644 vm/master.h rename {vmpp => vm}/master.hpp (100%) delete mode 100644 vm/math.c rename {vmpp => vm}/math.cpp (100%) delete mode 100644 vm/math.h rename {vmpp => vm}/math.hpp (100%) delete mode 100644 vm/os-freebsd-x86.32.h rename {vmpp => vm}/os-freebsd-x86.32.hpp (100%) delete mode 100644 vm/os-freebsd-x86.64.h rename {vmpp => vm}/os-freebsd-x86.64.hpp (100%) delete mode 100644 vm/os-freebsd.c rename {vmpp => vm}/os-freebsd.cpp (100%) delete mode 100644 vm/os-freebsd.h rename {vmpp => vm}/os-freebsd.hpp (100%) delete mode 100755 vm/os-genunix.c rename {vmpp => vm}/os-genunix.cpp (100%) delete mode 100644 vm/os-genunix.h rename {vmpp => vm}/os-genunix.hpp (100%) delete mode 100644 vm/os-linux-arm.c rename {vmpp => vm}/os-linux-arm.cpp (100%) delete mode 100644 vm/os-linux-arm.h rename {vmpp => vm}/os-linux-arm.hpp (100%) delete mode 100644 vm/os-linux-ppc.h rename {vmpp => vm}/os-linux-ppc.hpp (100%) delete mode 100644 vm/os-linux-x86.32.h rename {vmpp => vm}/os-linux-x86.32.hpp (100%) delete mode 100644 vm/os-linux-x86.64.h rename {vmpp => vm}/os-linux-x86.64.hpp (100%) delete mode 100644 vm/os-linux.c rename {vmpp => vm}/os-linux.cpp (100%) delete mode 100644 vm/os-linux.h rename {vmpp => vm}/os-linux.hpp (100%) delete mode 100644 vm/os-macosx-ppc.h rename {vmpp => vm}/os-macosx-ppc.hpp (100%) delete mode 100644 vm/os-macosx-x86.32.h rename {vmpp => vm}/os-macosx-x86.32.hpp (100%) delete mode 100644 vm/os-macosx-x86.64.h rename {vmpp => vm}/os-macosx-x86.64.hpp (100%) delete mode 100644 vm/os-macosx.h rename {vmpp => vm}/os-macosx.hpp (100%) delete mode 100644 vm/os-macosx.m rename {vmpp => vm}/os-macosx.mm (100%) delete mode 100644 vm/os-netbsd-x86.32.h rename {vmpp => vm}/os-netbsd-x86.32.hpp (100%) delete mode 100644 vm/os-netbsd-x86.64.h rename {vmpp => vm}/os-netbsd-x86.64.hpp (100%) delete mode 100755 vm/os-netbsd.c rename {vmpp => vm}/os-netbsd.cpp (100%) delete mode 100644 vm/os-netbsd.h rename {vmpp => vm}/os-netbsd.hpp (100%) delete mode 100644 vm/os-openbsd-x86.32.h rename {vmpp => vm}/os-openbsd-x86.32.hpp (100%) delete mode 100644 vm/os-openbsd-x86.64.h rename {vmpp => vm}/os-openbsd-x86.64.hpp (100%) delete mode 100644 vm/os-openbsd.c rename {vmpp => vm}/os-openbsd.cpp (100%) delete mode 100644 vm/os-solaris-x86.32.h rename {vmpp => vm}/os-solaris-x86.32.hpp (100%) delete mode 100644 vm/os-solaris-x86.64.h rename {vmpp => vm}/os-solaris-x86.64.hpp (100%) delete mode 100644 vm/os-solaris.c rename {vmpp => vm}/os-solaris.cpp (100%) delete mode 100755 vm/os-unix.c rename {vmpp => vm}/os-unix.cpp (100%) delete mode 100755 vm/os-unix.h rename {vmpp => vm}/os-unix.hpp (100%) delete mode 100755 vm/os-windows-ce.c rename {vmpp => vm}/os-windows-ce.cpp (100%) delete mode 100755 vm/os-windows-ce.h rename {vmpp => vm}/os-windows-ce.hpp (100%) delete mode 100644 vm/os-windows-nt.32.h rename {vmpp => vm}/os-windows-nt.32.hpp (100%) delete mode 100644 vm/os-windows-nt.64.h rename {vmpp => vm}/os-windows-nt.64.hpp (100%) delete mode 100755 vm/os-windows-nt.c rename {vmpp => vm}/os-windows-nt.cpp (100%) delete mode 100755 vm/os-windows-nt.h rename {vmpp => vm}/os-windows-nt.hpp (100%) delete mode 100755 vm/os-windows.c rename {vmpp => vm}/os-windows.cpp (100%) delete mode 100755 vm/os-windows.h rename {vmpp => vm}/os-windows.hpp (100%) delete mode 100644 vm/platform.h rename {vmpp => vm}/platform.hpp (100%) delete mode 100755 vm/primitives.c rename {vmpp => vm}/primitives.cpp (100%) delete mode 100644 vm/primitives.h rename {vmpp => vm}/primitives.hpp (100%) delete mode 100755 vm/profiler.c rename {vmpp => vm}/profiler.cpp (100%) delete mode 100755 vm/profiler.h rename {vmpp => vm}/profiler.hpp (100%) delete mode 100755 vm/quotations.c rename {vmpp => vm}/quotations.cpp (100%) delete mode 100755 vm/quotations.h rename {vmpp => vm}/quotations.hpp (100%) delete mode 100755 vm/run.c rename {vmpp => vm}/run.cpp (100%) delete mode 100755 vm/run.h rename {vmpp => vm}/run.hpp (100%) delete mode 100644 vm/strings.c rename {vmpp => vm}/strings.cpp (100%) delete mode 100644 vm/strings.h rename {vmpp => vm}/strings.hpp (100%) rename {vmpp => vm}/tagged.hpp (100%) create mode 100644 vm/test.cpp delete mode 100644 vm/tuples.c rename {vmpp => vm}/tuples.cpp (100%) delete mode 100644 vm/tuples.h rename {vmpp => vm}/tuples.hpp (100%) delete mode 100755 vm/utilities.c rename {vmpp => vm}/utilities.cpp (100%) delete mode 100755 vm/utilities.h rename {vmpp => vm}/utilities.hpp (100%) delete mode 100644 vm/words.c rename {vmpp => vm}/words.cpp (100%) delete mode 100644 vm/words.h rename {vmpp => vm}/words.hpp (100%) rename {vmpp => vm}/write_barrier.cpp (100%) delete mode 100644 vm/write_barrier.h rename {vmpp => vm}/write_barrier.hpp (100%) delete mode 100644 vmpp/Config.arm delete mode 100644 vmpp/Config.freebsd delete mode 100644 vmpp/Config.freebsd.x86.32 delete mode 100644 vmpp/Config.freebsd.x86.64 delete mode 100644 vmpp/Config.linux delete mode 100644 vmpp/Config.linux.arm delete mode 100644 vmpp/Config.linux.ppc delete mode 100644 vmpp/Config.linux.x86.32 delete mode 100644 vmpp/Config.linux.x86.64 delete mode 100644 vmpp/Config.macosx delete mode 100644 vmpp/Config.macosx.ppc delete mode 100644 vmpp/Config.macosx.x86.32 delete mode 100644 vmpp/Config.macosx.x86.64 delete mode 100644 vmpp/Config.netbsd delete mode 100644 vmpp/Config.netbsd.x86.32 delete mode 100644 vmpp/Config.netbsd.x86.64 delete mode 100644 vmpp/Config.openbsd delete mode 100644 vmpp/Config.openbsd.x86.32 delete mode 100644 vmpp/Config.openbsd.x86.64 delete mode 100644 vmpp/Config.ppc delete mode 100644 vmpp/Config.solaris delete mode 100644 vmpp/Config.solaris.x86.32 delete mode 100644 vmpp/Config.solaris.x86.64 delete mode 100755 vmpp/Config.unix delete mode 100644 vmpp/Config.windows delete mode 100644 vmpp/Config.windows.ce delete mode 100755 vmpp/Config.windows.ce.arm delete mode 100644 vmpp/Config.windows.nt delete mode 100644 vmpp/Config.windows.nt.x86.32 delete mode 100644 vmpp/Config.windows.nt.x86.64 delete mode 100644 vmpp/Config.x86.32 delete mode 100644 vmpp/Config.x86.64 delete mode 100644 vmpp/asm.h delete mode 100755 vmpp/cpu-arm.S delete mode 100755 vmpp/cpu-ppc.S delete mode 100755 vmpp/cpu-x86.32.S delete mode 100644 vmpp/cpu-x86.64.S delete mode 100755 vmpp/cpu-x86.S delete mode 100644 vmpp/data_gc.h delete mode 100644 vmpp/factor.rs delete mode 100755 vmpp/ffi_test.c delete mode 100755 vmpp/ffi_test.h diff --git a/Makefile b/Makefile index 8549325056..a21711b916 100755 --- a/Makefile +++ b/Makefile @@ -27,40 +27,40 @@ ifdef CONFIG endif DLL_OBJS = $(PLAF_DLL_OBJS) \ - vmpp/alien.o \ - vmpp/arrays.o \ - vmpp/bignum.o \ - vmpp/booleans.o \ - vmpp/byte_arrays.o \ - vmpp/callstack.o \ - vmpp/code_block.o \ - vmpp/code_gc.o \ - vmpp/code_heap.o \ - vmpp/data_gc.o \ - vmpp/data_heap.o \ - vmpp/debug.o \ - vmpp/dispatch.o \ - vmpp/errors.o \ - vmpp/factor.o \ - vmpp/image.o \ - vmpp/inline_cache.o \ - vmpp/io.o \ - vmpp/jit.o \ - vmpp/local_roots.o \ - vmpp/math.o \ - vmpp/primitives.o \ - vmpp/profiler.o \ - vmpp/quotations.o \ - vmpp/run.o \ - vmpp/strings.o \ - vmpp/tuples.o \ - vmpp/utilities.o \ - vmpp/words.o \ - vmpp/write_barrier.o + vm/alien.o \ + vm/arrays.o \ + vm/bignum.o \ + vm/booleans.o \ + vm/byte_arrays.o \ + vm/callstack.o \ + vm/code_block.o \ + vm/code_gc.o \ + vm/code_heap.o \ + vm/data_gc.o \ + vm/data_heap.o \ + vm/debug.o \ + vm/dispatch.o \ + vm/errors.o \ + vm/factor.o \ + vm/image.o \ + vm/inline_cache.o \ + vm/io.o \ + vm/jit.o \ + vm/local_roots.o \ + vm/math.o \ + vm/primitives.o \ + vm/profiler.o \ + vm/quotations.o \ + vm/run.o \ + vm/strings.o \ + vm/tuples.o \ + vm/utilities.o \ + vm/words.o \ + vm/write_barrier.o EXE_OBJS = $(PLAF_EXE_OBJS) -TEST_OBJS = vmpp/ffi_test.o +TEST_OBJS = vm/ffi_test.o default: $(MAKE) `./build-support/factor.sh make-target` @@ -95,60 +95,60 @@ help: @echo "X11=1 force link with X11 libraries instead of Cocoa (only on Mac OS X)" openbsd-x86-32: - $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.openbsd.x86.32 + $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.openbsd.x86.32 openbsd-x86-64: - $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.openbsd.x86.64 + $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.openbsd.x86.64 freebsd-x86-32: - $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.freebsd.x86.32 + $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.freebsd.x86.32 freebsd-x86-64: - $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.freebsd.x86.64 + $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.freebsd.x86.64 netbsd-x86-32: - $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.netbsd.x86.32 + $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.netbsd.x86.32 netbsd-x86-64: - $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.netbsd.x86.64 + $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.netbsd.x86.64 macosx-ppc: - $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) macosx.app CONFIG=vmpp/Config.macosx.ppc + $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) macosx.app CONFIG=vm/Config.macosx.ppc macosx-x86-32: - $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) macosx.app CONFIG=vmpp/Config.macosx.x86.32 + $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) macosx.app CONFIG=vm/Config.macosx.x86.32 macosx-x86-64: - $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) macosx.app CONFIG=vmpp/Config.macosx.x86.64 + $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) macosx.app CONFIG=vm/Config.macosx.x86.64 linux-x86-32: - $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.linux.x86.32 + $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.linux.x86.32 linux-x86-64: - $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.linux.x86.64 + $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.linux.x86.64 linux-ppc: - $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.linux.ppc + $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.linux.ppc linux-arm: - $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.linux.arm + $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.linux.arm solaris-x86-32: - $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.solaris.x86.32 + $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.solaris.x86.32 solaris-x86-64: - $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.solaris.x86.64 + $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.solaris.x86.64 winnt-x86-32: - $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.windows.nt.x86.32 - $(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vmpp/Config.windows.nt.x86.32 + $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.windows.nt.x86.32 + $(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32 winnt-x86-64: - $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.windows.nt.x86.64 - $(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vmpp/Config.windows.nt.x86.64 + $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.windows.nt.x86.64 + $(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64 wince-arm: - $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vmpp/Config.windows.ce.arm + $(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.windows.ce.arm macosx.app: factor mkdir -p $(BUNDLE)/Contents/MacOS @@ -172,17 +172,17 @@ $(CONSOLE_EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS) $(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \ $(CFLAGS) $(CFLAGS_CONSOLE) -o factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION) $(EXE_OBJS) -$(TEST_LIBRARY): vmpp/ffi_test.o +$(TEST_LIBRARY): vm/ffi_test.o $(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o libfactor-ffi-test$(SHARED_DLL_EXTENSION) $(TEST_OBJS) clean: - rm -f vmpp/*.o + rm -f vm/*.o rm -f factor*.dll libfactor.{a,so,dylib} libfactor-ffi-test.{a,so,dylib} Factor.app/Contents/Frameworks/libfactor.dylib -vmpp/resources.o: - $(WINDRES) vmpp/factor.rs vmpp/resources.o +vm/resources.o: + $(WINDRES) vm/factor.rs vm/resources.o -vmpp/ffi_test.o: vmpp/ffi_test.c +vm/ffi_test.o: vm/ffi_test.c $(CC) -c $(CFLAGS) $(FFI_TEST_CFLAGS) -o $@ $< .c.o: diff --git a/vm/Config.arm b/vm/Config.arm index 2273d61caf..1d7e6f9cc6 100644 --- a/vm/Config.arm +++ b/vm/Config.arm @@ -1 +1 @@ -PLAF_DLL_OBJS += vm/cpu-arm.o +PLAF_DLL_OBJS += vmpp/cpu-arm.o diff --git a/vm/Config.freebsd b/vm/Config.freebsd index 384b2fd57a..f2387286da 100644 --- a/vm/Config.freebsd +++ b/vm/Config.freebsd @@ -1,4 +1,4 @@ -include vm/Config.unix -PLAF_DLL_OBJS += vm/os-genunix.o vm/os-freebsd.o +include vmpp/Config.unix +PLAF_DLL_OBJS += vmpp/os-genunix.o vmpp/os-freebsd.o CFLAGS += -export-dynamic LIBS = -L/usr/local/lib/ -lm $(X11_UI_LIBS) diff --git a/vm/Config.macosx b/vm/Config.macosx index 98d14cfdf4..07629f72bb 100644 --- a/vm/Config.macosx +++ b/vm/Config.macosx @@ -14,7 +14,7 @@ else LIBS = -lm -framework Cocoa -framework AppKit endif -LINKER = gcc $(CFLAGS) -dynamiclib -single_module -std=gnu99 \ +LINKER = $(CPP) $(CFLAGS) -dynamiclib -single_module -std=gnu99 \ -current_version $(VERSION) \ -compatibility_version $(VERSION) \ -fvisibility=hidden \ diff --git a/vm/alien.c b/vm/alien.c deleted file mode 100755 index 2681579c5d..0000000000 --- a/vm/alien.c +++ /dev/null @@ -1,234 +0,0 @@ -#include "master.h" - -/* gets the address of an object representing a C pointer */ -void *alien_offset(CELL object) -{ - F_ALIEN *alien; - F_BYTE_ARRAY *byte_array; - - switch(type_of(object)) - { - case BYTE_ARRAY_TYPE: - byte_array = untag_object(object); - return byte_array + 1; - case ALIEN_TYPE: - alien = untag_object(object); - if(alien->expired != F) - general_error(ERROR_EXPIRED,object,F,NULL); - return alien_offset(alien->alien) + alien->displacement; - case F_TYPE: - return NULL; - default: - type_error(ALIEN_TYPE,object); - return NULL; /* can't happen */ - } -} - -/* gets the address of an object representing a C pointer, with the -intention of storing the pointer across code which may potentially GC. */ -void *pinned_alien_offset(CELL object) -{ - F_ALIEN *alien; - - switch(type_of(object)) - { - case ALIEN_TYPE: - alien = untag_object(object); - if(alien->expired != F) - general_error(ERROR_EXPIRED,object,F,NULL); - return pinned_alien_offset(alien->alien) + alien->displacement; - case F_TYPE: - return NULL; - default: - type_error(ALIEN_TYPE,object); - return NULL; /* can't happen */ - } -} - -/* pop an object representing a C pointer */ -void *unbox_alien(void) -{ - return alien_offset(dpop()); -} - -/* make an alien */ -CELL allot_alien(CELL delegate, CELL displacement) -{ - REGISTER_ROOT(delegate); - F_ALIEN *alien = allot_object(ALIEN_TYPE,sizeof(F_ALIEN)); - UNREGISTER_ROOT(delegate); - - if(type_of(delegate) == ALIEN_TYPE) - { - F_ALIEN *delegate_alien = untag_object(delegate); - displacement += delegate_alien->displacement; - alien->alien = delegate_alien->alien; - } - else - alien->alien = delegate; - - alien->displacement = displacement; - alien->expired = F; - return tag_object(alien); -} - -/* make an alien and push */ -void box_alien(void *ptr) -{ - if(ptr == NULL) - dpush(F); - else - dpush(allot_alien(F,(CELL)ptr)); -} - -/* make an alien pointing at an offset of another alien */ -void primitive_displaced_alien(void) -{ - CELL alien = dpop(); - CELL displacement = to_cell(dpop()); - - if(alien == F && displacement == 0) - dpush(F); - else - { - switch(type_of(alien)) - { - case BYTE_ARRAY_TYPE: - case ALIEN_TYPE: - case F_TYPE: - dpush(allot_alien(alien,displacement)); - break; - default: - type_error(ALIEN_TYPE,alien); - break; - } - } -} - -/* address of an object representing a C pointer. Explicitly throw an error -if the object is a byte array, as a sanity check. */ -void primitive_alien_address(void) -{ - box_unsigned_cell((CELL)pinned_alien_offset(dpop())); -} - -/* pop ( alien n ) from datastack, return alien's address plus n */ -INLINE void *alien_pointer(void) -{ - F_FIXNUM offset = to_fixnum(dpop()); - return unbox_alien() + offset; -} - -/* define words to read/write values at an alien address */ -#define DEFINE_ALIEN_ACCESSOR(name,type,boxer,to) \ - void primitive_alien_##name(void) \ - { \ - boxer(*(type*)alien_pointer()); \ - } \ - void primitive_set_alien_##name(void) \ - { \ - type* ptr = alien_pointer(); \ - type value = to(dpop()); \ - *ptr = value; \ - } - -DEFINE_ALIEN_ACCESSOR(signed_cell,F_FIXNUM,box_signed_cell,to_fixnum) -DEFINE_ALIEN_ACCESSOR(unsigned_cell,CELL,box_unsigned_cell,to_cell) -DEFINE_ALIEN_ACCESSOR(signed_8,s64,box_signed_8,to_signed_8) -DEFINE_ALIEN_ACCESSOR(unsigned_8,u64,box_unsigned_8,to_unsigned_8) -DEFINE_ALIEN_ACCESSOR(signed_4,s32,box_signed_4,to_fixnum) -DEFINE_ALIEN_ACCESSOR(unsigned_4,u32,box_unsigned_4,to_cell) -DEFINE_ALIEN_ACCESSOR(signed_2,s16,box_signed_2,to_fixnum) -DEFINE_ALIEN_ACCESSOR(unsigned_2,u16,box_unsigned_2,to_cell) -DEFINE_ALIEN_ACCESSOR(signed_1,s8,box_signed_1,to_fixnum) -DEFINE_ALIEN_ACCESSOR(unsigned_1,u8,box_unsigned_1,to_cell) -DEFINE_ALIEN_ACCESSOR(float,float,box_float,to_float) -DEFINE_ALIEN_ACCESSOR(double,double,box_double,to_double) -DEFINE_ALIEN_ACCESSOR(cell,void *,box_alien,pinned_alien_offset) - -/* for FFI calls passing structs by value */ -void to_value_struct(CELL src, void *dest, CELL size) -{ - memcpy(dest,alien_offset(src),size); -} - -/* for FFI callbacks receiving structs by value */ -void box_value_struct(void *src, CELL size) -{ - F_BYTE_ARRAY *array = allot_byte_array(size); - memcpy(array + 1,src,size); - dpush(tag_object(array)); -} - -/* On some x86 OSes, structs <= 8 bytes are returned in registers. */ -void box_small_struct(CELL x, CELL y, CELL size) -{ - CELL data[2]; - data[0] = x; - data[1] = y; - box_value_struct(data,size); -} - -/* On OS X/PPC, complex numbers are returned in registers. */ -void box_medium_struct(CELL x1, CELL x2, CELL x3, CELL x4, CELL size) -{ - CELL data[4]; - data[0] = x1; - data[1] = x2; - data[2] = x3; - data[3] = x4; - box_value_struct(data,size); -} - -/* open a native library and push a handle */ -void primitive_dlopen(void) -{ - CELL path = tag_object(string_to_native_alien( - untag_string(dpop()))); - REGISTER_ROOT(path); - F_DLL* dll = allot_object(DLL_TYPE,sizeof(F_DLL)); - UNREGISTER_ROOT(path); - dll->path = path; - ffi_dlopen(dll); - dpush(tag_object(dll)); -} - -/* look up a symbol in a native library */ -void primitive_dlsym(void) -{ - CELL dll = dpop(); - REGISTER_ROOT(dll); - F_SYMBOL *sym = unbox_symbol_string(); - UNREGISTER_ROOT(dll); - - F_DLL *d; - - if(dll == F) - box_alien(ffi_dlsym(NULL,sym)); - else - { - d = untag_dll(dll); - if(d->dll == NULL) - dpush(F); - else - box_alien(ffi_dlsym(d,sym)); - } -} - -/* close a native library handle */ -void primitive_dlclose(void) -{ - ffi_dlclose(untag_dll(dpop())); -} - -void primitive_dll_validp(void) -{ - CELL dll = dpop(); - if(dll == F) - dpush(T); - else - { - F_DLL *d = untag_dll(dll); - dpush(d->dll == NULL ? F : T); - } -} diff --git a/vmpp/alien.cpp b/vm/alien.cpp similarity index 96% rename from vmpp/alien.cpp rename to vm/alien.cpp index 755d53346e..f3613d518b 100755 --- a/vmpp/alien.cpp +++ b/vm/alien.cpp @@ -9,10 +9,10 @@ char *alien_offset(CELL object) switch(type_of(object)) { case BYTE_ARRAY_TYPE: - byte_array = untagged(object); + byte_array = untag(object); return (char *)(byte_array + 1); case ALIEN_TYPE: - alien = untagged(object); + alien = untag(object); if(alien->expired != F) general_error(ERROR_EXPIRED,object,F,NULL); return alien_offset(alien->alien) + alien->displacement; @@ -33,7 +33,7 @@ char *pinned_alien_offset(CELL object) switch(type_of(object)) { case ALIEN_TYPE: - alien = untagged(object); + alien = untag(object); if(alien->expired != F) general_error(ERROR_EXPIRED,object,F,NULL); return pinned_alien_offset(alien->alien) + alien->displacement; @@ -157,7 +157,7 @@ void box_value_struct(void *src, CELL size) { F_BYTE_ARRAY *array = allot_byte_array(size); memcpy(array + 1,src,size); - dpush(tag_object(array)); + dpush(tag(array)); } /* On some x86 OSes, structs <= 8 bytes are returned in registers. */ @@ -216,7 +216,7 @@ void primitive_dlsym(void) /* close a native library handle */ void primitive_dlclose(void) { - ffi_dlclose(untag_dll(dpop())); + ffi_dlclose(untag_check(dpop())); } void primitive_dll_validp(void) diff --git a/vm/alien.h b/vm/alien.h deleted file mode 100755 index dc76d49810..0000000000 --- a/vm/alien.h +++ /dev/null @@ -1,50 +0,0 @@ -CELL allot_alien(CELL delegate, CELL displacement); - -void primitive_displaced_alien(void); -void primitive_alien_address(void); - -DLLEXPORT void *alien_offset(CELL object); - -void fixup_alien(F_ALIEN* d); - -DLLEXPORT void *unbox_alien(void); -DLLEXPORT void box_alien(void *ptr); - -void primitive_alien_signed_cell(void); -void primitive_set_alien_signed_cell(void); -void primitive_alien_unsigned_cell(void); -void primitive_set_alien_unsigned_cell(void); -void primitive_alien_signed_8(void); -void primitive_set_alien_signed_8(void); -void primitive_alien_unsigned_8(void); -void primitive_set_alien_unsigned_8(void); -void primitive_alien_signed_4(void); -void primitive_set_alien_signed_4(void); -void primitive_alien_unsigned_4(void); -void primitive_set_alien_unsigned_4(void); -void primitive_alien_signed_2(void); -void primitive_set_alien_signed_2(void); -void primitive_alien_unsigned_2(void); -void primitive_set_alien_unsigned_2(void); -void primitive_alien_signed_1(void); -void primitive_set_alien_signed_1(void); -void primitive_alien_unsigned_1(void); -void primitive_set_alien_unsigned_1(void); -void primitive_alien_float(void); -void primitive_set_alien_float(void); -void primitive_alien_double(void); -void primitive_set_alien_double(void); -void primitive_alien_cell(void); -void primitive_set_alien_cell(void); - -DLLEXPORT void to_value_struct(CELL src, void *dest, CELL size); -DLLEXPORT void box_value_struct(void *src, CELL size); -DLLEXPORT void box_small_struct(CELL x, CELL y, CELL size); -void box_medium_struct(CELL x1, CELL x2, CELL x3, CELL x4, CELL size); - -DEFINE_UNTAG(F_DLL,DLL_TYPE,dll) - -void primitive_dlopen(void); -void primitive_dlsym(void); -void primitive_dlclose(void); -void primitive_dll_validp(void); diff --git a/vmpp/alien.hpp b/vm/alien.hpp similarity index 95% rename from vmpp/alien.hpp rename to vm/alien.hpp index 6f822aea83..301cfaad14 100755 --- a/vmpp/alien.hpp +++ b/vm/alien.hpp @@ -1,5 +1,3 @@ -DEFINE_UNTAG(F_ALIEN,ALIEN_TYPE,alien) - CELL allot_alien(CELL delegate, CELL displacement); void primitive_displaced_alien(void); @@ -42,8 +40,6 @@ DLLEXPORT void box_value_struct(void *src, CELL size); DLLEXPORT void box_small_struct(CELL x, CELL y, CELL size); void box_medium_struct(CELL x1, CELL x2, CELL x3, CELL x4, CELL size); -DEFINE_UNTAG(F_DLL,DLL_TYPE,dll) - void primitive_dlopen(void); void primitive_dlsym(void); void primitive_dlclose(void); diff --git a/vm/arrays.c b/vm/arrays.c deleted file mode 100644 index 4d5dc67818..0000000000 --- a/vm/arrays.c +++ /dev/null @@ -1,159 +0,0 @@ -#include "master.h" - -/* the array is full of undefined data, and must be correctly filled before the -next GC. size is in cells */ -F_ARRAY *allot_array_internal(CELL type, CELL capacity) -{ - F_ARRAY *array = allot_object(type,array_size(capacity)); - array->capacity = tag_fixnum(capacity); - return array; -} - -/* make a new array with an initial element */ -F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill) -{ - int i; - REGISTER_ROOT(fill); - F_ARRAY* array = allot_array_internal(type, capacity); - UNREGISTER_ROOT(fill); - if(fill == 0) - memset((void*)AREF(array,0),'\0',capacity * CELLS); - else - { - /* No need for write barrier here. Either the object is in - the nursery, or it was allocated directly in tenured space - and the write barrier is already hit for us in that case. */ - for(i = 0; i < capacity; i++) - put(AREF(array,i),fill); - } - return array; -} - -/* push a new array on the stack */ -void primitive_array(void) -{ - CELL initial = dpop(); - CELL size = unbox_array_size(); - dpush(tag_array(allot_array(ARRAY_TYPE,size,initial))); -} - -CELL allot_array_1(CELL obj) -{ - REGISTER_ROOT(obj); - F_ARRAY *a = allot_array_internal(ARRAY_TYPE,1); - UNREGISTER_ROOT(obj); - set_array_nth(a,0,obj); - return tag_array(a); -} - -CELL allot_array_2(CELL v1, CELL v2) -{ - REGISTER_ROOT(v1); - REGISTER_ROOT(v2); - F_ARRAY *a = allot_array_internal(ARRAY_TYPE,2); - UNREGISTER_ROOT(v2); - UNREGISTER_ROOT(v1); - set_array_nth(a,0,v1); - set_array_nth(a,1,v2); - return tag_array(a); -} - -CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4) -{ - REGISTER_ROOT(v1); - REGISTER_ROOT(v2); - REGISTER_ROOT(v3); - REGISTER_ROOT(v4); - F_ARRAY *a = allot_array_internal(ARRAY_TYPE,4); - UNREGISTER_ROOT(v4); - UNREGISTER_ROOT(v3); - UNREGISTER_ROOT(v2); - UNREGISTER_ROOT(v1); - set_array_nth(a,0,v1); - set_array_nth(a,1,v2); - set_array_nth(a,2,v3); - set_array_nth(a,3,v4); - return tag_array(a); -} - -static bool reallot_array_in_place_p(F_ARRAY *array, CELL capacity) -{ - return in_zone(&nursery,(CELL)array) && capacity <= array_capacity(array); -} - -F_ARRAY *reallot_array(F_ARRAY *array, CELL capacity) -{ -#ifdef FACTOR_DEBUG - CELL header = untag_header(array->header); - assert(header == ARRAY_TYPE || header == BIGNUM_TYPE); -#endif - - if(reallot_array_in_place_p(array,capacity)) - { - array->capacity = tag_fixnum(capacity); - return array; - } - else - { - CELL to_copy = array_capacity(array); - if(capacity < to_copy) - to_copy = capacity; - - REGISTER_UNTAGGED(array); - F_ARRAY* new_array = allot_array_internal(untag_header(array->header),capacity); - UNREGISTER_UNTAGGED(array); - - memcpy(new_array + 1,array + 1,to_copy * CELLS); - memset((char *)AREF(new_array,to_copy),'\0',(capacity - to_copy) * CELLS); - - return new_array; - } -} - -void primitive_resize_array(void) -{ - F_ARRAY* array = untag_array(dpop()); - CELL capacity = unbox_array_size(); - dpush(tag_array(reallot_array(array,capacity))); -} - -void growable_array_add(F_GROWABLE_ARRAY *array, CELL elt) -{ - F_ARRAY *underlying = untag_object(array->array); - REGISTER_ROOT(elt); - - if(array->count == array_capacity(underlying)) - { - underlying = reallot_array(underlying,array->count * 2); - array->array = tag_array(underlying); - } - - UNREGISTER_ROOT(elt); - set_array_nth(underlying,array->count++,elt); -} - -void growable_array_append(F_GROWABLE_ARRAY *array, F_ARRAY *elts) -{ - REGISTER_UNTAGGED(elts); - - F_ARRAY *underlying = untag_object(array->array); - - CELL elts_size = array_capacity(elts); - CELL new_size = array->count + elts_size; - - if(new_size >= array_capacity(underlying)) - { - underlying = reallot_array(underlying,new_size * 2); - array->array = tag_array(underlying); - } - - UNREGISTER_UNTAGGED(elts); - - write_barrier(array->array); - - memcpy((void *)AREF(underlying,array->count), - (void *)AREF(elts,0), - elts_size * CELLS); - - array->count += elts_size; -} diff --git a/vmpp/arrays.cpp b/vm/arrays.cpp similarity index 93% rename from vmpp/arrays.cpp rename to vm/arrays.cpp index 83953d20bc..ec592fae4f 100644 --- a/vmpp/arrays.cpp +++ b/vm/arrays.cpp @@ -25,7 +25,7 @@ void primitive_array(void) { CELL initial = dpop(); CELL size = unbox_array_size(); - dpush(tag_array(allot_array(size,initial))); + dpush(tag(allot_array(size,initial))); } CELL allot_array_1(CELL obj_) @@ -62,9 +62,9 @@ CELL allot_array_4(CELL v1_, CELL v2_, CELL v3_, CELL v4_) void primitive_resize_array(void) { - F_ARRAY* array = untag_array(dpop()); + F_ARRAY* array = untag_check(dpop()); CELL capacity = unbox_array_size(); - dpush(tag_array(reallot_array(array,capacity))); + dpush(tag(reallot_array(array,capacity))); } void growable_array::add(CELL elt_) diff --git a/vm/arrays.h b/vm/arrays.h deleted file mode 100644 index 3b2a065aba..0000000000 --- a/vm/arrays.h +++ /dev/null @@ -1,95 +0,0 @@ -DEFINE_UNTAG(F_ARRAY,ARRAY_TYPE,array) - -INLINE CELL tag_array(F_ARRAY *array) -{ - return RETAG(array,ARRAY_TYPE); -} - -/* Inline functions */ -INLINE CELL array_size(CELL size) -{ - return sizeof(F_ARRAY) + size * CELLS; -} - -INLINE CELL array_capacity(F_ARRAY* array) -{ -#ifdef FACTOR_DEBUG - CELL header = untag_header(array->header); - assert(header == ARRAY_TYPE || header == BIGNUM_TYPE || header == BYTE_ARRAY_TYPE); -#endif - return array->capacity >> TAG_BITS; -} - -#define AREF(array,index) ((CELL)(array) + sizeof(F_ARRAY) + (index) * CELLS) -#define UNAREF(array,ptr) (((CELL)(ptr)-(CELL)(array)-sizeof(F_ARRAY)) / CELLS) - -INLINE CELL array_nth(F_ARRAY *array, CELL slot) -{ -#ifdef FACTOR_DEBUG - assert(slot < array_capacity(array)); - assert(untag_header(array->header) == ARRAY_TYPE); -#endif - return get(AREF(array,slot)); -} - -INLINE void set_array_nth(F_ARRAY *array, CELL slot, CELL value) -{ -#ifdef FACTOR_DEBUG - assert(slot < array_capacity(array)); - assert(untag_header(array->header) == ARRAY_TYPE); -#endif - put(AREF(array,slot),value); - write_barrier((CELL)array); -} - -F_ARRAY *allot_array_internal(CELL type, CELL capacity); -F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill); -F_BYTE_ARRAY *allot_byte_array(CELL size); - -CELL allot_array_1(CELL obj); -CELL allot_array_2(CELL v1, CELL v2); -CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4); - -void primitive_array(void); - -F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity); -void primitive_resize_array(void); - -/* Macros to simulate a vector in C */ -typedef struct { - CELL count; - CELL array; -} F_GROWABLE_ARRAY; - -/* Allocates memory */ -INLINE F_GROWABLE_ARRAY make_growable_array(void) -{ - F_GROWABLE_ARRAY result; - result.count = 0; - result.array = tag_array(allot_array(ARRAY_TYPE,100,F)); - return result; -} - -#define GROWABLE_ARRAY(result) F_GROWABLE_ARRAY result##_g = make_growable_array(); \ - REGISTER_ROOT(result##_g.array) - -void growable_array_add(F_GROWABLE_ARRAY *result, CELL elt); - -#define GROWABLE_ARRAY_ADD(result,elt) \ - growable_array_add(&result##_g,elt) - -void growable_array_append(F_GROWABLE_ARRAY *result, F_ARRAY *elts); - -#define GROWABLE_ARRAY_APPEND(result,elts) \ - growable_array_append(&result##_g,elts) - -INLINE void growable_array_trim(F_GROWABLE_ARRAY *array) -{ - array->array = tag_array(reallot_array(untag_object(array->array),array->count)); -} - -#define GROWABLE_ARRAY_TRIM(result) growable_array_trim(&result##_g) - -#define GROWABLE_ARRAY_DONE(result) \ - UNREGISTER_ROOT(result##_g.array); \ - CELL result = result##_g.array; diff --git a/vmpp/arrays.hpp b/vm/arrays.hpp similarity index 100% rename from vmpp/arrays.hpp rename to vm/arrays.hpp diff --git a/vm/bignum.c b/vm/bignum.c deleted file mode 100755 index c799691f36..0000000000 --- a/vm/bignum.c +++ /dev/null @@ -1,1878 +0,0 @@ -/* :tabSize=2:indentSize=2:noTabs=true: - -Copyright (C) 1989-94 Massachusetts Institute of Technology -Portions copyright (C) 2004-2008 Slava Pestov - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy and modify this software, to -redistribute either the original software or a modified version, and -to use this software for any purpose is granted, subject to the -following restrictions and understandings. - -1. Any copy made of this software must include this copyright notice -in full. - -2. Users of this software agree to make their best efforts (a) to -return to the MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. All materials developed as a consequence of the use of this -software shall duly acknowledge such use, in accordance with the usual -standards of acknowledging credit in academic research. - -4. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* Changes for Scheme 48: - * - Converted to ANSI. - * - Added bitwise operations. - * - Added s48 to the beginning of all externally visible names. - * - Cached the bignum representations of -1, 0, and 1. - */ - -/* Changes for Factor: - * - Adapt bignumint.h for Factor memory manager - * - Add more bignum <-> C type conversions - * - Remove unused functions - * - Add local variable GC root recording - * - Remove s48 prefix from function names - * - Various fixes for Win64 - */ - -#include "master.h" -#include -#include -#include /* abort */ -#include - -/* Exports */ - -int -bignum_equal_p(bignum_type x, bignum_type y) -{ - return - ((BIGNUM_ZERO_P (x)) - ? (BIGNUM_ZERO_P (y)) - : ((! (BIGNUM_ZERO_P (y))) - && ((BIGNUM_NEGATIVE_P (x)) - ? (BIGNUM_NEGATIVE_P (y)) - : (! (BIGNUM_NEGATIVE_P (y)))) - && (bignum_equal_p_unsigned (x, y)))); -} - -enum bignum_comparison -bignum_compare(bignum_type x, bignum_type y) -{ - return - ((BIGNUM_ZERO_P (x)) - ? ((BIGNUM_ZERO_P (y)) - ? bignum_comparison_equal - : (BIGNUM_NEGATIVE_P (y)) - ? bignum_comparison_greater - : bignum_comparison_less) - : (BIGNUM_ZERO_P (y)) - ? ((BIGNUM_NEGATIVE_P (x)) - ? bignum_comparison_less - : bignum_comparison_greater) - : (BIGNUM_NEGATIVE_P (x)) - ? ((BIGNUM_NEGATIVE_P (y)) - ? (bignum_compare_unsigned (y, x)) - : (bignum_comparison_less)) - : ((BIGNUM_NEGATIVE_P (y)) - ? (bignum_comparison_greater) - : (bignum_compare_unsigned (x, y)))); -} - -/* allocates memory */ -bignum_type -bignum_add(bignum_type x, bignum_type y) -{ - return - ((BIGNUM_ZERO_P (x)) - ? (y) - : (BIGNUM_ZERO_P (y)) - ? (x) - : ((BIGNUM_NEGATIVE_P (x)) - ? ((BIGNUM_NEGATIVE_P (y)) - ? (bignum_add_unsigned (x, y, 1)) - : (bignum_subtract_unsigned (y, x))) - : ((BIGNUM_NEGATIVE_P (y)) - ? (bignum_subtract_unsigned (x, y)) - : (bignum_add_unsigned (x, y, 0))))); -} - -/* allocates memory */ -bignum_type -bignum_subtract(bignum_type x, bignum_type y) -{ - return - ((BIGNUM_ZERO_P (x)) - ? ((BIGNUM_ZERO_P (y)) - ? (y) - : (bignum_new_sign (y, (! (BIGNUM_NEGATIVE_P (y)))))) - : ((BIGNUM_ZERO_P (y)) - ? (x) - : ((BIGNUM_NEGATIVE_P (x)) - ? ((BIGNUM_NEGATIVE_P (y)) - ? (bignum_subtract_unsigned (y, x)) - : (bignum_add_unsigned (x, y, 1))) - : ((BIGNUM_NEGATIVE_P (y)) - ? (bignum_add_unsigned (x, y, 0)) - : (bignum_subtract_unsigned (x, y)))))); -} - -/* allocates memory */ -bignum_type -bignum_multiply(bignum_type x, bignum_type y) -{ - bignum_length_type x_length = (BIGNUM_LENGTH (x)); - bignum_length_type y_length = (BIGNUM_LENGTH (y)); - int negative_p = - ((BIGNUM_NEGATIVE_P (x)) - ? (! (BIGNUM_NEGATIVE_P (y))) - : (BIGNUM_NEGATIVE_P (y))); - if (BIGNUM_ZERO_P (x)) - return (x); - if (BIGNUM_ZERO_P (y)) - return (y); - if (x_length == 1) - { - bignum_digit_type digit = (BIGNUM_REF (x, 0)); - if (digit == 1) - return (bignum_maybe_new_sign (y, negative_p)); - if (digit < BIGNUM_RADIX_ROOT) - return (bignum_multiply_unsigned_small_factor (y, digit, negative_p)); - } - if (y_length == 1) - { - bignum_digit_type digit = (BIGNUM_REF (y, 0)); - if (digit == 1) - return (bignum_maybe_new_sign (x, negative_p)); - if (digit < BIGNUM_RADIX_ROOT) - return (bignum_multiply_unsigned_small_factor (x, digit, negative_p)); - } - return (bignum_multiply_unsigned (x, y, negative_p)); -} - -/* allocates memory */ -void -bignum_divide(bignum_type numerator, bignum_type denominator, - bignum_type * quotient, bignum_type * remainder) -{ - if (BIGNUM_ZERO_P (denominator)) - { - divide_by_zero_error(); - return; - } - if (BIGNUM_ZERO_P (numerator)) - { - (*quotient) = numerator; - (*remainder) = numerator; - } - else - { - int r_negative_p = (BIGNUM_NEGATIVE_P (numerator)); - int q_negative_p = - ((BIGNUM_NEGATIVE_P (denominator)) ? (! r_negative_p) : r_negative_p); - switch (bignum_compare_unsigned (numerator, denominator)) - { - case bignum_comparison_equal: - { - (*quotient) = (BIGNUM_ONE (q_negative_p)); - (*remainder) = (BIGNUM_ZERO ()); - break; - } - case bignum_comparison_less: - { - (*quotient) = (BIGNUM_ZERO ()); - (*remainder) = numerator; - break; - } - case bignum_comparison_greater: - { - if ((BIGNUM_LENGTH (denominator)) == 1) - { - bignum_digit_type digit = (BIGNUM_REF (denominator, 0)); - if (digit == 1) - { - (*quotient) = - (bignum_maybe_new_sign (numerator, q_negative_p)); - (*remainder) = (BIGNUM_ZERO ()); - break; - } - else if (digit < BIGNUM_RADIX_ROOT) - { - bignum_divide_unsigned_small_denominator - (numerator, digit, - quotient, remainder, - q_negative_p, r_negative_p); - break; - } - else - { - bignum_divide_unsigned_medium_denominator - (numerator, digit, - quotient, remainder, - q_negative_p, r_negative_p); - break; - } - } - bignum_divide_unsigned_large_denominator - (numerator, denominator, - quotient, remainder, - q_negative_p, r_negative_p); - break; - } - } - } -} - -/* allocates memory */ -bignum_type -bignum_quotient(bignum_type numerator, bignum_type denominator) -{ - if (BIGNUM_ZERO_P (denominator)) - { - divide_by_zero_error(); - return (BIGNUM_OUT_OF_BAND); - } - if (BIGNUM_ZERO_P (numerator)) - return numerator; - { - int q_negative_p = - ((BIGNUM_NEGATIVE_P (denominator)) - ? (! (BIGNUM_NEGATIVE_P (numerator))) - : (BIGNUM_NEGATIVE_P (numerator))); - switch (bignum_compare_unsigned (numerator, denominator)) - { - case bignum_comparison_equal: - return (BIGNUM_ONE (q_negative_p)); - case bignum_comparison_less: - return (BIGNUM_ZERO ()); - case bignum_comparison_greater: - default: /* to appease gcc -Wall */ - { - bignum_type quotient; - if ((BIGNUM_LENGTH (denominator)) == 1) - { - bignum_digit_type digit = (BIGNUM_REF (denominator, 0)); - if (digit == 1) - return (bignum_maybe_new_sign (numerator, q_negative_p)); - if (digit < BIGNUM_RADIX_ROOT) - bignum_divide_unsigned_small_denominator - (numerator, digit, - ("ient), ((bignum_type *) 0), - q_negative_p, 0); - else - bignum_divide_unsigned_medium_denominator - (numerator, digit, - ("ient), ((bignum_type *) 0), - q_negative_p, 0); - } - else - bignum_divide_unsigned_large_denominator - (numerator, denominator, - ("ient), ((bignum_type *) 0), - q_negative_p, 0); - return (quotient); - } - } - } -} - -/* allocates memory */ -bignum_type -bignum_remainder(bignum_type numerator, bignum_type denominator) -{ - if (BIGNUM_ZERO_P (denominator)) - { - divide_by_zero_error(); - return (BIGNUM_OUT_OF_BAND); - } - if (BIGNUM_ZERO_P (numerator)) - return numerator; - switch (bignum_compare_unsigned (numerator, denominator)) - { - case bignum_comparison_equal: - return (BIGNUM_ZERO ()); - case bignum_comparison_less: - return numerator; - case bignum_comparison_greater: - default: /* to appease gcc -Wall */ - { - bignum_type remainder; - if ((BIGNUM_LENGTH (denominator)) == 1) - { - bignum_digit_type digit = (BIGNUM_REF (denominator, 0)); - if (digit == 1) - return (BIGNUM_ZERO ()); - if (digit < BIGNUM_RADIX_ROOT) - return - (bignum_remainder_unsigned_small_denominator - (numerator, digit, (BIGNUM_NEGATIVE_P (numerator)))); - bignum_divide_unsigned_medium_denominator - (numerator, digit, - ((bignum_type *) 0), (&remainder), - 0, (BIGNUM_NEGATIVE_P (numerator))); - } - else - bignum_divide_unsigned_large_denominator - (numerator, denominator, - ((bignum_type *) 0), (&remainder), - 0, (BIGNUM_NEGATIVE_P (numerator))); - return (remainder); - } - } -} - -#define FOO_TO_BIGNUM(name,type,utype) \ - bignum_type name##_to_bignum(type n) \ - { \ - int negative_p; \ - bignum_digit_type result_digits [BIGNUM_DIGITS_FOR(type)]; \ - bignum_digit_type * end_digits = result_digits; \ - /* Special cases win when these small constants are cached. */ \ - if (n == 0) return (BIGNUM_ZERO ()); \ - if (n == 1) return (BIGNUM_ONE (0)); \ - if (n < 0 && 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 = \ - (allot_bignum ((end_digits - result_digits), negative_p)); \ - bignum_digit_type * scan_digits = result_digits; \ - bignum_digit_type * scan_result = (BIGNUM_START_PTR (result)); \ - while (scan_digits < end_digits) \ - (*scan_result++) = (*scan_digits++); \ - return (result); \ - } \ - } - -/* all below allocate memory */ -FOO_TO_BIGNUM(cell,CELL,CELL) -FOO_TO_BIGNUM(fixnum,F_FIXNUM,CELL) -FOO_TO_BIGNUM(long_long,s64,u64) -FOO_TO_BIGNUM(ulong_long,u64,u64) - -#define BIGNUM_TO_FOO(name,type,utype) \ - type bignum_to_##name(bignum_type bignum) \ - { \ - if (BIGNUM_ZERO_P (bignum)) \ - return (0); \ - { \ - utype accumulator = 0; \ - bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); \ - bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); \ - while (start < scan) \ - accumulator = ((accumulator << BIGNUM_DIGIT_LENGTH) + (*--scan)); \ - return ((BIGNUM_NEGATIVE_P (bignum)) ? (-((type)accumulator)) : accumulator); \ - } \ - } - -/* all of the below allocate memory */ -BIGNUM_TO_FOO(cell,CELL,CELL); -BIGNUM_TO_FOO(fixnum,F_FIXNUM,CELL); -BIGNUM_TO_FOO(long_long,s64,u64) -BIGNUM_TO_FOO(ulong_long,u64,u64) - -double -bignum_to_double(bignum_type bignum) -{ - if (BIGNUM_ZERO_P (bignum)) - return (0); - { - double accumulator = 0; - bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); - bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); - while (start < scan) - accumulator = ((accumulator * BIGNUM_RADIX) + (*--scan)); - return ((BIGNUM_NEGATIVE_P (bignum)) ? (-accumulator) : accumulator); - } -} - -#define DTB_WRITE_DIGIT(factor) \ -{ \ - significand *= (factor); \ - digit = ((bignum_digit_type) significand); \ - (*--scan) = digit; \ - significand -= ((double) digit); \ -} - -/* allocates memory */ -bignum_type -double_to_bignum(double x) -{ - if (x == 1.0/0.0 || x == -1.0/0.0 || x != x) return (BIGNUM_ZERO ()); - int exponent; - double significand = (frexp (x, (&exponent))); - if (exponent <= 0) return (BIGNUM_ZERO ()); - if (exponent == 1) return (BIGNUM_ONE (x < 0)); - if (significand < 0) significand = (-significand); - { - bignum_length_type length = (BIGNUM_BITS_TO_DIGITS (exponent)); - bignum_type result = (allot_bignum (length, (x < 0))); - bignum_digit_type * start = (BIGNUM_START_PTR (result)); - bignum_digit_type * scan = (start + length); - bignum_digit_type digit; - int odd_bits = (exponent % BIGNUM_DIGIT_LENGTH); - if (odd_bits > 0) - DTB_WRITE_DIGIT ((F_FIXNUM)1 << odd_bits); - while (start < scan) - { - if (significand == 0) - { - while (start < scan) - (*--scan) = 0; - break; - } - DTB_WRITE_DIGIT (BIGNUM_RADIX); - } - return (result); - } -} - -#undef DTB_WRITE_DIGIT - -/* Comparisons */ - -int -bignum_equal_p_unsigned(bignum_type x, bignum_type y) -{ - bignum_length_type length = (BIGNUM_LENGTH (x)); - if (length != (BIGNUM_LENGTH (y))) - return (0); - else - { - bignum_digit_type * scan_x = (BIGNUM_START_PTR (x)); - bignum_digit_type * scan_y = (BIGNUM_START_PTR (y)); - bignum_digit_type * end_x = (scan_x + length); - while (scan_x < end_x) - if ((*scan_x++) != (*scan_y++)) - return (0); - return (1); - } -} - -enum bignum_comparison -bignum_compare_unsigned(bignum_type x, bignum_type y) -{ - bignum_length_type x_length = (BIGNUM_LENGTH (x)); - bignum_length_type y_length = (BIGNUM_LENGTH (y)); - if (x_length < y_length) - return (bignum_comparison_less); - if (x_length > y_length) - return (bignum_comparison_greater); - { - bignum_digit_type * start_x = (BIGNUM_START_PTR (x)); - bignum_digit_type * scan_x = (start_x + x_length); - bignum_digit_type * scan_y = ((BIGNUM_START_PTR (y)) + y_length); - while (start_x < scan_x) - { - bignum_digit_type digit_x = (*--scan_x); - bignum_digit_type digit_y = (*--scan_y); - if (digit_x < digit_y) - return (bignum_comparison_less); - if (digit_x > digit_y) - return (bignum_comparison_greater); - } - } - return (bignum_comparison_equal); -} - -/* Addition */ - -/* allocates memory */ -bignum_type -bignum_add_unsigned(bignum_type x, bignum_type y, int negative_p) -{ - if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x))) - { - bignum_type z = x; - x = y; - y = z; - } - { - bignum_length_type x_length = (BIGNUM_LENGTH (x)); - - REGISTER_BIGNUM(x); - REGISTER_BIGNUM(y); - bignum_type r = (allot_bignum ((x_length + 1), negative_p)); - UNREGISTER_BIGNUM(y); - UNREGISTER_BIGNUM(x); - - bignum_digit_type sum; - bignum_digit_type carry = 0; - bignum_digit_type * scan_x = (BIGNUM_START_PTR (x)); - bignum_digit_type * scan_r = (BIGNUM_START_PTR (r)); - { - bignum_digit_type * scan_y = (BIGNUM_START_PTR (y)); - bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y))); - while (scan_y < end_y) - { - sum = ((*scan_x++) + (*scan_y++) + carry); - if (sum < BIGNUM_RADIX) - { - (*scan_r++) = sum; - carry = 0; - } - else - { - (*scan_r++) = (sum - BIGNUM_RADIX); - carry = 1; - } - } - } - { - bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length); - if (carry != 0) - while (scan_x < end_x) - { - sum = ((*scan_x++) + 1); - if (sum < BIGNUM_RADIX) - { - (*scan_r++) = sum; - carry = 0; - break; - } - else - (*scan_r++) = (sum - BIGNUM_RADIX); - } - while (scan_x < end_x) - (*scan_r++) = (*scan_x++); - } - if (carry != 0) - { - (*scan_r) = 1; - return (r); - } - return (bignum_shorten_length (r, x_length)); - } -} - -/* Subtraction */ - -/* allocates memory */ -bignum_type -bignum_subtract_unsigned(bignum_type x, bignum_type y) -{ - int negative_p = 0; - switch (bignum_compare_unsigned (x, y)) - { - case bignum_comparison_equal: - return (BIGNUM_ZERO ()); - case bignum_comparison_less: - { - bignum_type z = x; - x = y; - y = z; - } - negative_p = 1; - break; - case bignum_comparison_greater: - negative_p = 0; - break; - } - { - bignum_length_type x_length = (BIGNUM_LENGTH (x)); - - REGISTER_BIGNUM(x); - REGISTER_BIGNUM(y); - bignum_type r = (allot_bignum (x_length, negative_p)); - UNREGISTER_BIGNUM(y); - UNREGISTER_BIGNUM(x); - - bignum_digit_type difference; - bignum_digit_type borrow = 0; - bignum_digit_type * scan_x = (BIGNUM_START_PTR (x)); - bignum_digit_type * scan_r = (BIGNUM_START_PTR (r)); - { - bignum_digit_type * scan_y = (BIGNUM_START_PTR (y)); - bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y))); - while (scan_y < end_y) - { - difference = (((*scan_x++) - (*scan_y++)) - borrow); - if (difference < 0) - { - (*scan_r++) = (difference + BIGNUM_RADIX); - borrow = 1; - } - else - { - (*scan_r++) = difference; - borrow = 0; - } - } - } - { - bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length); - if (borrow != 0) - while (scan_x < end_x) - { - difference = ((*scan_x++) - borrow); - if (difference < 0) - (*scan_r++) = (difference + BIGNUM_RADIX); - else - { - (*scan_r++) = difference; - borrow = 0; - break; - } - } - BIGNUM_ASSERT (borrow == 0); - while (scan_x < end_x) - (*scan_r++) = (*scan_x++); - } - return (bignum_trim (r)); - } -} - -/* Multiplication - Maximum value for product_low or product_high: - ((R * R) + (R * (R - 2)) + (R - 1)) - Maximum value for carry: ((R * (R - 1)) + (R - 1)) - where R == BIGNUM_RADIX_ROOT */ - -/* allocates memory */ -bignum_type -bignum_multiply_unsigned(bignum_type x, bignum_type y, int negative_p) -{ - if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x))) - { - bignum_type z = x; - x = y; - y = z; - } - { - bignum_digit_type carry; - bignum_digit_type y_digit_low; - bignum_digit_type y_digit_high; - bignum_digit_type x_digit_low; - bignum_digit_type x_digit_high; - bignum_digit_type product_low; - bignum_digit_type * scan_r; - bignum_digit_type * scan_y; - bignum_length_type x_length = (BIGNUM_LENGTH (x)); - bignum_length_type y_length = (BIGNUM_LENGTH (y)); - - REGISTER_BIGNUM(x); - REGISTER_BIGNUM(y); - bignum_type r = - (allot_bignum_zeroed ((x_length + y_length), negative_p)); - UNREGISTER_BIGNUM(y); - UNREGISTER_BIGNUM(x); - - bignum_digit_type * scan_x = (BIGNUM_START_PTR (x)); - bignum_digit_type * end_x = (scan_x + x_length); - bignum_digit_type * start_y = (BIGNUM_START_PTR (y)); - bignum_digit_type * end_y = (start_y + y_length); - bignum_digit_type * start_r = (BIGNUM_START_PTR (r)); -#define x_digit x_digit_high -#define y_digit y_digit_high -#define product_high carry - while (scan_x < end_x) - { - x_digit = (*scan_x++); - x_digit_low = (HD_LOW (x_digit)); - x_digit_high = (HD_HIGH (x_digit)); - carry = 0; - scan_y = start_y; - scan_r = (start_r++); - while (scan_y < end_y) - { - y_digit = (*scan_y++); - y_digit_low = (HD_LOW (y_digit)); - y_digit_high = (HD_HIGH (y_digit)); - product_low = - ((*scan_r) + - (x_digit_low * y_digit_low) + - (HD_LOW (carry))); - product_high = - ((x_digit_high * y_digit_low) + - (x_digit_low * y_digit_high) + - (HD_HIGH (product_low)) + - (HD_HIGH (carry))); - (*scan_r++) = - (HD_CONS ((HD_LOW (product_high)), (HD_LOW (product_low)))); - carry = - ((x_digit_high * y_digit_high) + - (HD_HIGH (product_high))); - } - (*scan_r) += carry; - } - return (bignum_trim (r)); -#undef x_digit -#undef y_digit -#undef product_high - } -} - -/* allocates memory */ -bignum_type -bignum_multiply_unsigned_small_factor(bignum_type x, bignum_digit_type y, - int negative_p) -{ - bignum_length_type length_x = (BIGNUM_LENGTH (x)); - - REGISTER_BIGNUM(x); - bignum_type p = (allot_bignum ((length_x + 1), negative_p)); - UNREGISTER_BIGNUM(x); - - bignum_destructive_copy (x, p); - (BIGNUM_REF (p, length_x)) = 0; - bignum_destructive_scale_up (p, y); - return (bignum_trim (p)); -} - -void -bignum_destructive_add(bignum_type bignum, bignum_digit_type n) -{ - bignum_digit_type * scan = (BIGNUM_START_PTR (bignum)); - bignum_digit_type digit; - digit = ((*scan) + n); - if (digit < BIGNUM_RADIX) - { - (*scan) = digit; - return; - } - (*scan++) = (digit - BIGNUM_RADIX); - while (1) - { - digit = ((*scan) + 1); - if (digit < BIGNUM_RADIX) - { - (*scan) = digit; - return; - } - (*scan++) = (digit - BIGNUM_RADIX); - } -} - -void -bignum_destructive_scale_up(bignum_type bignum, bignum_digit_type factor) -{ - bignum_digit_type carry = 0; - bignum_digit_type * scan = (BIGNUM_START_PTR (bignum)); - bignum_digit_type two_digits; - bignum_digit_type product_low; -#define product_high carry - bignum_digit_type * end = (scan + (BIGNUM_LENGTH (bignum))); - BIGNUM_ASSERT ((factor > 1) && (factor < BIGNUM_RADIX_ROOT)); - while (scan < end) - { - two_digits = (*scan); - product_low = ((factor * (HD_LOW (two_digits))) + (HD_LOW (carry))); - product_high = - ((factor * (HD_HIGH (two_digits))) + - (HD_HIGH (product_low)) + - (HD_HIGH (carry))); - (*scan++) = (HD_CONS ((HD_LOW (product_high)), (HD_LOW (product_low)))); - carry = (HD_HIGH (product_high)); - } - /* A carry here would be an overflow, i.e. it would not fit. - Hopefully the callers allocate enough space that this will - never happen. - */ - BIGNUM_ASSERT (carry == 0); - return; -#undef product_high -} - -/* Division */ - -/* For help understanding this algorithm, see: - Knuth, Donald E., "The Art of Computer Programming", - volume 2, "Seminumerical Algorithms" - section 4.3.1, "Multiple-Precision Arithmetic". */ - -/* allocates memory */ -void -bignum_divide_unsigned_large_denominator(bignum_type numerator, - bignum_type denominator, - bignum_type * quotient, - bignum_type * remainder, - int q_negative_p, - int r_negative_p) -{ - bignum_length_type length_n = ((BIGNUM_LENGTH (numerator)) + 1); - bignum_length_type length_d = (BIGNUM_LENGTH (denominator)); - - REGISTER_BIGNUM(numerator); - REGISTER_BIGNUM(denominator); - - bignum_type q = - ((quotient != ((bignum_type *) 0)) - ? (allot_bignum ((length_n - length_d), q_negative_p)) - : BIGNUM_OUT_OF_BAND); - - REGISTER_BIGNUM(q); - bignum_type u = (allot_bignum (length_n, r_negative_p)); - UNREGISTER_BIGNUM(q); - - UNREGISTER_BIGNUM(denominator); - UNREGISTER_BIGNUM(numerator); - - int shift = 0; - BIGNUM_ASSERT (length_d > 1); - { - bignum_digit_type v1 = (BIGNUM_REF ((denominator), (length_d - 1))); - while (v1 < (BIGNUM_RADIX / 2)) - { - v1 <<= 1; - shift += 1; - } - } - if (shift == 0) - { - bignum_destructive_copy (numerator, u); - (BIGNUM_REF (u, (length_n - 1))) = 0; - bignum_divide_unsigned_normalized (u, denominator, q); - } - else - { - REGISTER_BIGNUM(numerator); - REGISTER_BIGNUM(denominator); - REGISTER_BIGNUM(u); - REGISTER_BIGNUM(q); - bignum_type v = (allot_bignum (length_d, 0)); - UNREGISTER_BIGNUM(q); - UNREGISTER_BIGNUM(u); - UNREGISTER_BIGNUM(denominator); - UNREGISTER_BIGNUM(numerator); - - bignum_destructive_normalization (numerator, u, shift); - bignum_destructive_normalization (denominator, v, shift); - bignum_divide_unsigned_normalized (u, v, q); - if (remainder != ((bignum_type *) 0)) - bignum_destructive_unnormalization (u, shift); - } - - REGISTER_BIGNUM(u); - if(q) - q = bignum_trim (q); - UNREGISTER_BIGNUM(u); - - REGISTER_BIGNUM(q); - u = bignum_trim (u); - UNREGISTER_BIGNUM(q); - - if (quotient != ((bignum_type *) 0)) - (*quotient) = q; - - if (remainder != ((bignum_type *) 0)) - (*remainder) = u; - - return; -} - -void -bignum_divide_unsigned_normalized(bignum_type u, bignum_type v, bignum_type q) -{ - bignum_length_type u_length = (BIGNUM_LENGTH (u)); - bignum_length_type v_length = (BIGNUM_LENGTH (v)); - bignum_digit_type * u_start = (BIGNUM_START_PTR (u)); - bignum_digit_type * u_scan = (u_start + u_length); - bignum_digit_type * u_scan_limit = (u_start + v_length); - bignum_digit_type * u_scan_start = (u_scan - v_length); - bignum_digit_type * v_start = (BIGNUM_START_PTR (v)); - bignum_digit_type * v_end = (v_start + v_length); - bignum_digit_type * q_scan = NULL; - bignum_digit_type v1 = (v_end[-1]); - bignum_digit_type v2 = (v_end[-2]); - bignum_digit_type ph; /* high half of double-digit product */ - bignum_digit_type pl; /* low half of double-digit product */ - bignum_digit_type guess; - bignum_digit_type gh; /* high half-digit of guess */ - bignum_digit_type ch; /* high half of double-digit comparand */ - bignum_digit_type v2l = (HD_LOW (v2)); - bignum_digit_type v2h = (HD_HIGH (v2)); - bignum_digit_type cl; /* low half of double-digit comparand */ -#define gl ph /* low half-digit of guess */ -#define uj pl -#define qj ph - bignum_digit_type gm; /* memory loc for reference parameter */ - if (q != BIGNUM_OUT_OF_BAND) - q_scan = ((BIGNUM_START_PTR (q)) + (BIGNUM_LENGTH (q))); - while (u_scan_limit < u_scan) - { - uj = (*--u_scan); - if (uj != v1) - { - /* comparand = - (((((uj * BIGNUM_RADIX) + uj1) % v1) * BIGNUM_RADIX) + uj2); - guess = (((uj * BIGNUM_RADIX) + uj1) / v1); */ - cl = (u_scan[-2]); - ch = (bignum_digit_divide (uj, (u_scan[-1]), v1, (&gm))); - guess = gm; - } - else - { - cl = (u_scan[-2]); - ch = ((u_scan[-1]) + v1); - guess = (BIGNUM_RADIX - 1); - } - while (1) - { - /* product = (guess * v2); */ - gl = (HD_LOW (guess)); - gh = (HD_HIGH (guess)); - pl = (v2l * gl); - ph = ((v2l * gh) + (v2h * gl) + (HD_HIGH (pl))); - pl = (HD_CONS ((HD_LOW (ph)), (HD_LOW (pl)))); - ph = ((v2h * gh) + (HD_HIGH (ph))); - /* if (comparand >= product) */ - if ((ch > ph) || ((ch == ph) && (cl >= pl))) - break; - guess -= 1; - /* comparand += (v1 << BIGNUM_DIGIT_LENGTH) */ - ch += v1; - /* if (comparand >= (BIGNUM_RADIX * BIGNUM_RADIX)) */ - if (ch >= BIGNUM_RADIX) - break; - } - qj = (bignum_divide_subtract (v_start, v_end, guess, (--u_scan_start))); - if (q != BIGNUM_OUT_OF_BAND) - (*--q_scan) = qj; - } - return; -#undef gl -#undef uj -#undef qj -} - -bignum_digit_type -bignum_divide_subtract(bignum_digit_type * v_start, - bignum_digit_type * v_end, - bignum_digit_type guess, - bignum_digit_type * u_start) -{ - bignum_digit_type * v_scan = v_start; - bignum_digit_type * u_scan = u_start; - bignum_digit_type carry = 0; - if (guess == 0) return (0); - { - bignum_digit_type gl = (HD_LOW (guess)); - bignum_digit_type gh = (HD_HIGH (guess)); - bignum_digit_type v; - bignum_digit_type pl; - bignum_digit_type vl; -#define vh v -#define ph carry -#define diff pl - while (v_scan < v_end) - { - v = (*v_scan++); - vl = (HD_LOW (v)); - vh = (HD_HIGH (v)); - pl = ((vl * gl) + (HD_LOW (carry))); - ph = ((vl * gh) + (vh * gl) + (HD_HIGH (pl)) + (HD_HIGH (carry))); - diff = ((*u_scan) - (HD_CONS ((HD_LOW (ph)), (HD_LOW (pl))))); - if (diff < 0) - { - (*u_scan++) = (diff + BIGNUM_RADIX); - carry = ((vh * gh) + (HD_HIGH (ph)) + 1); - } - else - { - (*u_scan++) = diff; - carry = ((vh * gh) + (HD_HIGH (ph))); - } - } - if (carry == 0) - return (guess); - diff = ((*u_scan) - carry); - if (diff < 0) - (*u_scan) = (diff + BIGNUM_RADIX); - else - { - (*u_scan) = diff; - return (guess); - } -#undef vh -#undef ph -#undef diff - } - /* Subtraction generated carry, implying guess is one too large. - Add v back in to bring it back down. */ - v_scan = v_start; - u_scan = u_start; - carry = 0; - while (v_scan < v_end) - { - bignum_digit_type sum = ((*v_scan++) + (*u_scan) + carry); - if (sum < BIGNUM_RADIX) - { - (*u_scan++) = sum; - carry = 0; - } - else - { - (*u_scan++) = (sum - BIGNUM_RADIX); - carry = 1; - } - } - if (carry == 1) - { - bignum_digit_type sum = ((*u_scan) + carry); - (*u_scan) = ((sum < BIGNUM_RADIX) ? sum : (sum - BIGNUM_RADIX)); - } - return (guess - 1); -} - -/* allocates memory */ -void -bignum_divide_unsigned_medium_denominator(bignum_type numerator, - bignum_digit_type denominator, - bignum_type * quotient, - bignum_type * remainder, - int q_negative_p, - int r_negative_p) -{ - bignum_length_type length_n = (BIGNUM_LENGTH (numerator)); - bignum_length_type length_q; - bignum_type q; - int shift = 0; - /* Because `bignum_digit_divide' requires a normalized denominator. */ - while (denominator < (BIGNUM_RADIX / 2)) - { - denominator <<= 1; - shift += 1; - } - if (shift == 0) - { - length_q = length_n; - - REGISTER_BIGNUM(numerator); - q = (allot_bignum (length_q, q_negative_p)); - UNREGISTER_BIGNUM(numerator); - - bignum_destructive_copy (numerator, q); - } - else - { - length_q = (length_n + 1); - - REGISTER_BIGNUM(numerator); - q = (allot_bignum (length_q, q_negative_p)); - UNREGISTER_BIGNUM(numerator); - - bignum_destructive_normalization (numerator, q, shift); - } - { - bignum_digit_type r = 0; - bignum_digit_type * start = (BIGNUM_START_PTR (q)); - bignum_digit_type * scan = (start + length_q); - bignum_digit_type qj; - - while (start < scan) - { - r = (bignum_digit_divide (r, (*--scan), denominator, (&qj))); - (*scan) = qj; - } - - q = bignum_trim (q); - - if (remainder != ((bignum_type *) 0)) - { - if (shift != 0) - r >>= shift; - - REGISTER_BIGNUM(q); - (*remainder) = (bignum_digit_to_bignum (r, r_negative_p)); - UNREGISTER_BIGNUM(q); - } - - if (quotient != ((bignum_type *) 0)) - (*quotient) = q; - } - return; -} - -void -bignum_destructive_normalization(bignum_type source, bignum_type target, - int shift_left) -{ - bignum_digit_type digit; - bignum_digit_type * scan_source = (BIGNUM_START_PTR (source)); - bignum_digit_type carry = 0; - bignum_digit_type * scan_target = (BIGNUM_START_PTR (target)); - bignum_digit_type * end_source = (scan_source + (BIGNUM_LENGTH (source))); - bignum_digit_type * end_target = (scan_target + (BIGNUM_LENGTH (target))); - int shift_right = (BIGNUM_DIGIT_LENGTH - shift_left); - bignum_digit_type mask = (((CELL)1 << shift_right) - 1); - while (scan_source < end_source) - { - digit = (*scan_source++); - (*scan_target++) = (((digit & mask) << shift_left) | carry); - carry = (digit >> shift_right); - } - if (scan_target < end_target) - (*scan_target) = carry; - else - BIGNUM_ASSERT (carry == 0); - return; -} - -void -bignum_destructive_unnormalization(bignum_type bignum, int shift_right) -{ - bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); - bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); - bignum_digit_type digit; - bignum_digit_type carry = 0; - int shift_left = (BIGNUM_DIGIT_LENGTH - shift_right); - bignum_digit_type mask = (((F_FIXNUM)1 << shift_right) - 1); - while (start < scan) - { - digit = (*--scan); - (*scan) = ((digit >> shift_right) | carry); - carry = ((digit & mask) << shift_left); - } - BIGNUM_ASSERT (carry == 0); - return; -} - -/* This is a reduced version of the division algorithm, applied to the - case of dividing two bignum digits by one bignum digit. It is - assumed that the numerator, denominator are normalized. */ - -#define BDD_STEP(qn, j) \ -{ \ - uj = (u[j]); \ - if (uj != v1) \ - { \ - uj_uj1 = (HD_CONS (uj, (u[j + 1]))); \ - guess = (uj_uj1 / v1); \ - comparand = (HD_CONS ((uj_uj1 % v1), (u[j + 2]))); \ - } \ - else \ - { \ - guess = (BIGNUM_RADIX_ROOT - 1); \ - comparand = (HD_CONS (((u[j + 1]) + v1), (u[j + 2]))); \ - } \ - while ((guess * v2) > comparand) \ - { \ - guess -= 1; \ - comparand += (v1 << BIGNUM_HALF_DIGIT_LENGTH); \ - if (comparand >= BIGNUM_RADIX) \ - break; \ - } \ - qn = (bignum_digit_divide_subtract (v1, v2, guess, (&u[j]))); \ -} - -bignum_digit_type -bignum_digit_divide(bignum_digit_type uh, bignum_digit_type ul, - bignum_digit_type v, - bignum_digit_type * q) /* return value */ -{ - bignum_digit_type guess; - bignum_digit_type comparand; - bignum_digit_type v1 = (HD_HIGH (v)); - bignum_digit_type v2 = (HD_LOW (v)); - bignum_digit_type uj; - bignum_digit_type uj_uj1; - bignum_digit_type q1; - bignum_digit_type q2; - bignum_digit_type u [4]; - if (uh == 0) - { - if (ul < v) - { - (*q) = 0; - return (ul); - } - else if (ul == v) - { - (*q) = 1; - return (0); - } - } - (u[0]) = (HD_HIGH (uh)); - (u[1]) = (HD_LOW (uh)); - (u[2]) = (HD_HIGH (ul)); - (u[3]) = (HD_LOW (ul)); - v1 = (HD_HIGH (v)); - v2 = (HD_LOW (v)); - BDD_STEP (q1, 0); - BDD_STEP (q2, 1); - (*q) = (HD_CONS (q1, q2)); - return (HD_CONS ((u[2]), (u[3]))); -} - -#undef BDD_STEP - -#define BDDS_MULSUB(vn, un, carry_in) \ -{ \ - product = ((vn * guess) + carry_in); \ - diff = (un - (HD_LOW (product))); \ - if (diff < 0) \ - { \ - un = (diff + BIGNUM_RADIX_ROOT); \ - carry = ((HD_HIGH (product)) + 1); \ - } \ - else \ - { \ - un = diff; \ - carry = (HD_HIGH (product)); \ - } \ -} - -#define BDDS_ADD(vn, un, carry_in) \ -{ \ - sum = (vn + un + carry_in); \ - if (sum < BIGNUM_RADIX_ROOT) \ - { \ - un = sum; \ - carry = 0; \ - } \ - else \ - { \ - un = (sum - BIGNUM_RADIX_ROOT); \ - carry = 1; \ - } \ -} - -bignum_digit_type -bignum_digit_divide_subtract(bignum_digit_type v1, bignum_digit_type v2, - bignum_digit_type guess, bignum_digit_type * u) -{ - { - bignum_digit_type product; - bignum_digit_type diff; - bignum_digit_type carry; - BDDS_MULSUB (v2, (u[2]), 0); - BDDS_MULSUB (v1, (u[1]), carry); - if (carry == 0) - return (guess); - diff = ((u[0]) - carry); - if (diff < 0) - (u[0]) = (diff + BIGNUM_RADIX); - else - { - (u[0]) = diff; - return (guess); - } - } - { - bignum_digit_type sum; - bignum_digit_type carry; - BDDS_ADD(v2, (u[2]), 0); - BDDS_ADD(v1, (u[1]), carry); - if (carry == 1) - (u[0]) += 1; - } - return (guess - 1); -} - -#undef BDDS_MULSUB -#undef BDDS_ADD - -/* allocates memory */ -void -bignum_divide_unsigned_small_denominator(bignum_type numerator, - bignum_digit_type denominator, - bignum_type * quotient, - bignum_type * remainder, - int q_negative_p, - int r_negative_p) -{ - REGISTER_BIGNUM(numerator); - bignum_type q = (bignum_new_sign (numerator, q_negative_p)); - UNREGISTER_BIGNUM(numerator); - - bignum_digit_type r = (bignum_destructive_scale_down (q, denominator)); - - q = (bignum_trim (q)); - - if (remainder != ((bignum_type *) 0)) - { - REGISTER_BIGNUM(q); - (*remainder) = (bignum_digit_to_bignum (r, r_negative_p)); - UNREGISTER_BIGNUM(q); - } - - (*quotient) = q; - - return; -} - -/* Given (denominator > 1), it is fairly easy to show that - (quotient_high < BIGNUM_RADIX_ROOT), after which it is easy to see - that all digits are < BIGNUM_RADIX. */ - -bignum_digit_type -bignum_destructive_scale_down(bignum_type bignum, bignum_digit_type denominator) -{ - bignum_digit_type numerator; - bignum_digit_type remainder = 0; - bignum_digit_type two_digits; -#define quotient_high remainder - bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); - bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); - BIGNUM_ASSERT ((denominator > 1) && (denominator < BIGNUM_RADIX_ROOT)); - while (start < scan) - { - two_digits = (*--scan); - numerator = (HD_CONS (remainder, (HD_HIGH (two_digits)))); - quotient_high = (numerator / denominator); - numerator = (HD_CONS ((numerator % denominator), (HD_LOW (two_digits)))); - (*scan) = (HD_CONS (quotient_high, (numerator / denominator))); - remainder = (numerator % denominator); - } - return (remainder); -#undef quotient_high -} - -/* allocates memory */ -bignum_type -bignum_remainder_unsigned_small_denominator( - bignum_type n, bignum_digit_type d, int negative_p) -{ - bignum_digit_type two_digits; - bignum_digit_type * start = (BIGNUM_START_PTR (n)); - bignum_digit_type * scan = (start + (BIGNUM_LENGTH (n))); - bignum_digit_type r = 0; - BIGNUM_ASSERT ((d > 1) && (d < BIGNUM_RADIX_ROOT)); - while (start < scan) - { - two_digits = (*--scan); - r = - ((HD_CONS (((HD_CONS (r, (HD_HIGH (two_digits)))) % d), - (HD_LOW (two_digits)))) - % d); - } - return (bignum_digit_to_bignum (r, negative_p)); -} - -/* allocates memory */ -bignum_type -bignum_digit_to_bignum(bignum_digit_type digit, int negative_p) -{ - if (digit == 0) - return (BIGNUM_ZERO ()); - else - { - bignum_type result = (allot_bignum (1, negative_p)); - (BIGNUM_REF (result, 0)) = digit; - return (result); - } -} - -/* allocates memory */ -bignum_type -allot_bignum(bignum_length_type length, int negative_p) -{ - BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX)); - bignum_type result = allot_array_internal(BIGNUM_TYPE,length + 1); - BIGNUM_SET_NEGATIVE_P (result, negative_p); - return (result); -} - -/* allocates memory */ -bignum_type -allot_bignum_zeroed(bignum_length_type length, int negative_p) -{ - bignum_type result = allot_bignum(length,negative_p); - bignum_digit_type * scan = (BIGNUM_START_PTR (result)); - bignum_digit_type * end = (scan + length); - while (scan < end) - (*scan++) = 0; - return (result); -} - -#define BIGNUM_REDUCE_LENGTH(source, length) \ - source = reallot_array(source,length + 1) - -/* allocates memory */ -bignum_type -bignum_shorten_length(bignum_type bignum, bignum_length_type length) -{ - bignum_length_type current_length = (BIGNUM_LENGTH (bignum)); - BIGNUM_ASSERT ((length >= 0) || (length <= current_length)); - if (length < current_length) - { - BIGNUM_REDUCE_LENGTH (bignum, length); - BIGNUM_SET_NEGATIVE_P (bignum, (length != 0) && (BIGNUM_NEGATIVE_P (bignum))); - } - return (bignum); -} - -/* allocates memory */ -bignum_type -bignum_trim(bignum_type bignum) -{ - bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); - bignum_digit_type * end = (start + (BIGNUM_LENGTH (bignum))); - bignum_digit_type * scan = end; - while ((start <= scan) && ((*--scan) == 0)) - ; - scan += 1; - if (scan < end) - { - bignum_length_type length = (scan - start); - BIGNUM_REDUCE_LENGTH (bignum, length); - BIGNUM_SET_NEGATIVE_P (bignum, (length != 0) && (BIGNUM_NEGATIVE_P (bignum))); - } - return (bignum); -} - -/* Copying */ - -/* allocates memory */ -bignum_type -bignum_new_sign(bignum_type bignum, int negative_p) -{ - REGISTER_BIGNUM(bignum); - bignum_type result = - (allot_bignum ((BIGNUM_LENGTH (bignum)), negative_p)); - UNREGISTER_BIGNUM(bignum); - - bignum_destructive_copy (bignum, result); - return (result); -} - -/* allocates memory */ -bignum_type -bignum_maybe_new_sign(bignum_type bignum, int negative_p) -{ - if ((BIGNUM_NEGATIVE_P (bignum)) ? negative_p : (! negative_p)) - return (bignum); - else - { - bignum_type result = - (allot_bignum ((BIGNUM_LENGTH (bignum)), negative_p)); - bignum_destructive_copy (bignum, result); - return (result); - } -} - -void -bignum_destructive_copy(bignum_type source, bignum_type target) -{ - bignum_digit_type * scan_source = (BIGNUM_START_PTR (source)); - bignum_digit_type * end_source = - (scan_source + (BIGNUM_LENGTH (source))); - bignum_digit_type * scan_target = (BIGNUM_START_PTR (target)); - while (scan_source < end_source) - (*scan_target++) = (*scan_source++); - return; -} - -/* - * Added bitwise operations (and oddp). - */ - -/* allocates memory */ -bignum_type -bignum_bitwise_not(bignum_type x) -{ - return bignum_subtract(BIGNUM_ONE(1), x); -} - -/* allocates memory */ -bignum_type -bignum_arithmetic_shift(bignum_type arg1, F_FIXNUM n) -{ - if (BIGNUM_NEGATIVE_P(arg1) && n < 0) - return bignum_bitwise_not(bignum_magnitude_ash(bignum_bitwise_not(arg1), n)); - else - return bignum_magnitude_ash(arg1, n); -} - -#define AND_OP 0 -#define IOR_OP 1 -#define XOR_OP 2 - -/* allocates memory */ -bignum_type -bignum_bitwise_and(bignum_type arg1, bignum_type arg2) -{ - return( - (BIGNUM_NEGATIVE_P (arg1)) - ? (BIGNUM_NEGATIVE_P (arg2)) - ? bignum_negneg_bitwise_op(AND_OP, arg1, arg2) - : bignum_posneg_bitwise_op(AND_OP, arg2, arg1) - : (BIGNUM_NEGATIVE_P (arg2)) - ? bignum_posneg_bitwise_op(AND_OP, arg1, arg2) - : bignum_pospos_bitwise_op(AND_OP, arg1, arg2) - ); -} - -/* allocates memory */ -bignum_type -bignum_bitwise_ior(bignum_type arg1, bignum_type arg2) -{ - return( - (BIGNUM_NEGATIVE_P (arg1)) - ? (BIGNUM_NEGATIVE_P (arg2)) - ? bignum_negneg_bitwise_op(IOR_OP, arg1, arg2) - : bignum_posneg_bitwise_op(IOR_OP, arg2, arg1) - : (BIGNUM_NEGATIVE_P (arg2)) - ? bignum_posneg_bitwise_op(IOR_OP, arg1, arg2) - : bignum_pospos_bitwise_op(IOR_OP, arg1, arg2) - ); -} - -/* allocates memory */ -bignum_type -bignum_bitwise_xor(bignum_type arg1, bignum_type arg2) -{ - return( - (BIGNUM_NEGATIVE_P (arg1)) - ? (BIGNUM_NEGATIVE_P (arg2)) - ? bignum_negneg_bitwise_op(XOR_OP, arg1, arg2) - : bignum_posneg_bitwise_op(XOR_OP, arg2, arg1) - : (BIGNUM_NEGATIVE_P (arg2)) - ? bignum_posneg_bitwise_op(XOR_OP, arg1, arg2) - : bignum_pospos_bitwise_op(XOR_OP, arg1, arg2) - ); -} - -/* allocates memory */ -/* ash for the magnitude */ -/* assume arg1 is a big number, n is a long */ -bignum_type -bignum_magnitude_ash(bignum_type arg1, F_FIXNUM n) -{ - bignum_type result = NULL; - bignum_digit_type *scan1; - bignum_digit_type *scanr; - bignum_digit_type *end; - - F_FIXNUM digit_offset,bit_offset; - - if (BIGNUM_ZERO_P (arg1)) return (arg1); - - if (n > 0) { - digit_offset = n / BIGNUM_DIGIT_LENGTH; - bit_offset = n % BIGNUM_DIGIT_LENGTH; - - REGISTER_BIGNUM(arg1); - result = allot_bignum_zeroed (BIGNUM_LENGTH (arg1) + digit_offset + 1, - BIGNUM_NEGATIVE_P(arg1)); - UNREGISTER_BIGNUM(arg1); - - scanr = BIGNUM_START_PTR (result) + digit_offset; - scan1 = BIGNUM_START_PTR (arg1); - end = scan1 + BIGNUM_LENGTH (arg1); - - while (scan1 < end) { - *scanr = *scanr | (*scan1 & BIGNUM_DIGIT_MASK) << bit_offset; - *scanr = *scanr & BIGNUM_DIGIT_MASK; - scanr++; - *scanr = *scan1++ >> (BIGNUM_DIGIT_LENGTH - bit_offset); - *scanr = *scanr & BIGNUM_DIGIT_MASK; - } - } - else if (n < 0 - && (-n >= (BIGNUM_LENGTH (arg1) * (bignum_length_type) BIGNUM_DIGIT_LENGTH))) - result = BIGNUM_ZERO (); - - else if (n < 0) { - digit_offset = -n / BIGNUM_DIGIT_LENGTH; - bit_offset = -n % BIGNUM_DIGIT_LENGTH; - - REGISTER_BIGNUM(arg1); - result = allot_bignum_zeroed (BIGNUM_LENGTH (arg1) - digit_offset, - BIGNUM_NEGATIVE_P(arg1)); - UNREGISTER_BIGNUM(arg1); - - scanr = BIGNUM_START_PTR (result); - scan1 = BIGNUM_START_PTR (arg1) + digit_offset; - end = scanr + BIGNUM_LENGTH (result) - 1; - - while (scanr < end) { - *scanr = (*scan1++ & BIGNUM_DIGIT_MASK) >> bit_offset ; - *scanr = (*scanr | - *scan1 << (BIGNUM_DIGIT_LENGTH - bit_offset)) & BIGNUM_DIGIT_MASK; - scanr++; - } - *scanr = (*scan1++ & BIGNUM_DIGIT_MASK) >> bit_offset ; - } - else if (n == 0) result = arg1; - - return (bignum_trim (result)); -} - -/* allocates memory */ -bignum_type -bignum_pospos_bitwise_op(int op, bignum_type arg1, bignum_type arg2) -{ - bignum_type result; - bignum_length_type max_length; - - bignum_digit_type *scan1, *end1, digit1; - bignum_digit_type *scan2, *end2, digit2; - bignum_digit_type *scanr, *endr; - - max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2)) - ? BIGNUM_LENGTH(arg1) : BIGNUM_LENGTH(arg2); - - REGISTER_BIGNUM(arg1); - REGISTER_BIGNUM(arg2); - result = allot_bignum(max_length, 0); - UNREGISTER_BIGNUM(arg2); - UNREGISTER_BIGNUM(arg1); - - scanr = BIGNUM_START_PTR(result); - scan1 = BIGNUM_START_PTR(arg1); - scan2 = BIGNUM_START_PTR(arg2); - endr = scanr + max_length; - end1 = scan1 + BIGNUM_LENGTH(arg1); - end2 = scan2 + BIGNUM_LENGTH(arg2); - - while (scanr < endr) { - digit1 = (scan1 < end1) ? *scan1++ : 0; - digit2 = (scan2 < end2) ? *scan2++ : 0; - *scanr++ = (op == AND_OP) ? digit1 & digit2 : - (op == IOR_OP) ? digit1 | digit2 : - digit1 ^ digit2; - } - return bignum_trim(result); -} - -/* allocates memory */ -bignum_type -bignum_posneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2) -{ - bignum_type result; - bignum_length_type max_length; - - bignum_digit_type *scan1, *end1, digit1; - bignum_digit_type *scan2, *end2, digit2, carry2; - bignum_digit_type *scanr, *endr; - - char neg_p = op == IOR_OP || op == XOR_OP; - - max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2) + 1) - ? BIGNUM_LENGTH(arg1) : BIGNUM_LENGTH(arg2) + 1; - - REGISTER_BIGNUM(arg1); - REGISTER_BIGNUM(arg2); - result = allot_bignum(max_length, neg_p); - UNREGISTER_BIGNUM(arg2); - UNREGISTER_BIGNUM(arg1); - - scanr = BIGNUM_START_PTR(result); - scan1 = BIGNUM_START_PTR(arg1); - scan2 = BIGNUM_START_PTR(arg2); - endr = scanr + max_length; - end1 = scan1 + BIGNUM_LENGTH(arg1); - end2 = scan2 + BIGNUM_LENGTH(arg2); - - carry2 = 1; - - while (scanr < endr) { - digit1 = (scan1 < end1) ? *scan1++ : 0; - digit2 = (~((scan2 < end2) ? *scan2++ : 0) & BIGNUM_DIGIT_MASK) - + carry2; - - if (digit2 < BIGNUM_RADIX) - carry2 = 0; - else - { - digit2 = (digit2 - BIGNUM_RADIX); - carry2 = 1; - } - - *scanr++ = (op == AND_OP) ? digit1 & digit2 : - (op == IOR_OP) ? digit1 | digit2 : - digit1 ^ digit2; - } - - if (neg_p) - bignum_negate_magnitude(result); - - return bignum_trim(result); -} - -/* allocates memory */ -bignum_type -bignum_negneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2) -{ - bignum_type result; - bignum_length_type max_length; - - bignum_digit_type *scan1, *end1, digit1, carry1; - bignum_digit_type *scan2, *end2, digit2, carry2; - bignum_digit_type *scanr, *endr; - - char neg_p = op == AND_OP || op == IOR_OP; - - max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2)) - ? BIGNUM_LENGTH(arg1) + 1 : BIGNUM_LENGTH(arg2) + 1; - - REGISTER_BIGNUM(arg1); - REGISTER_BIGNUM(arg2); - result = allot_bignum(max_length, neg_p); - UNREGISTER_BIGNUM(arg2); - UNREGISTER_BIGNUM(arg1); - - scanr = BIGNUM_START_PTR(result); - scan1 = BIGNUM_START_PTR(arg1); - scan2 = BIGNUM_START_PTR(arg2); - endr = scanr + max_length; - end1 = scan1 + BIGNUM_LENGTH(arg1); - end2 = scan2 + BIGNUM_LENGTH(arg2); - - carry1 = 1; - carry2 = 1; - - while (scanr < endr) { - digit1 = (~((scan1 < end1) ? *scan1++ : 0) & BIGNUM_DIGIT_MASK) + carry1; - digit2 = (~((scan2 < end2) ? *scan2++ : 0) & BIGNUM_DIGIT_MASK) + carry2; - - if (digit1 < BIGNUM_RADIX) - carry1 = 0; - else - { - digit1 = (digit1 - BIGNUM_RADIX); - carry1 = 1; - } - - if (digit2 < BIGNUM_RADIX) - carry2 = 0; - else - { - digit2 = (digit2 - BIGNUM_RADIX); - carry2 = 1; - } - - *scanr++ = (op == AND_OP) ? digit1 & digit2 : - (op == IOR_OP) ? digit1 | digit2 : - digit1 ^ digit2; - } - - if (neg_p) - bignum_negate_magnitude(result); - - return bignum_trim(result); -} - -void -bignum_negate_magnitude(bignum_type arg) -{ - bignum_digit_type *scan; - bignum_digit_type *end; - bignum_digit_type digit; - bignum_digit_type carry; - - scan = BIGNUM_START_PTR(arg); - end = scan + BIGNUM_LENGTH(arg); - - carry = 1; - - while (scan < end) { - digit = (~*scan & BIGNUM_DIGIT_MASK) + carry; - - if (digit < BIGNUM_RADIX) - carry = 0; - else - { - digit = (digit - BIGNUM_RADIX); - carry = 1; - } - - *scan++ = digit; - } -} - -/* Allocates memory */ -bignum_type -bignum_integer_length(bignum_type bignum) -{ - bignum_length_type index = ((BIGNUM_LENGTH (bignum)) - 1); - bignum_digit_type digit = (BIGNUM_REF (bignum, index)); - - REGISTER_BIGNUM(bignum); - bignum_type result = (allot_bignum (2, 0)); - UNREGISTER_BIGNUM(bignum); - - (BIGNUM_REF (result, 0)) = index; - (BIGNUM_REF (result, 1)) = 0; - bignum_destructive_scale_up (result, BIGNUM_DIGIT_LENGTH); - while (digit > 1) - { - bignum_destructive_add (result, ((bignum_digit_type) 1)); - digit >>= 1; - } - return (bignum_trim (result)); -} - -/* Allocates memory */ -int -bignum_logbitp(int shift, bignum_type arg) -{ - return((BIGNUM_NEGATIVE_P (arg)) - ? !bignum_unsigned_logbitp (shift, bignum_bitwise_not (arg)) - : bignum_unsigned_logbitp (shift,arg)); -} - -int -bignum_unsigned_logbitp(int shift, bignum_type bignum) -{ - bignum_length_type len = (BIGNUM_LENGTH (bignum)); - int index = shift / BIGNUM_DIGIT_LENGTH; - if (index >= len) - return 0; - bignum_digit_type digit = (BIGNUM_REF (bignum, index)); - int p = shift % BIGNUM_DIGIT_LENGTH; - bignum_digit_type mask = ((F_FIXNUM)1) << p; - return (digit & mask) ? 1 : 0; -} - -/* Allocates memory */ -bignum_type -digit_stream_to_bignum(unsigned int n_digits, - unsigned int (*producer)(unsigned int), - unsigned int radix, - int negative_p) -{ - BIGNUM_ASSERT ((radix > 1) && (radix <= BIGNUM_RADIX_ROOT)); - if (n_digits == 0) - return (BIGNUM_ZERO ()); - if (n_digits == 1) - { - F_FIXNUM digit = ((F_FIXNUM) ((*producer) (0))); - return (fixnum_to_bignum (negative_p ? (- digit) : digit)); - } - { - bignum_length_type length; - { - unsigned int radix_copy = radix; - unsigned int log_radix = 0; - while (radix_copy > 0) - { - radix_copy >>= 1; - log_radix += 1; - } - /* This length will be at least as large as needed. */ - length = (BIGNUM_BITS_TO_DIGITS (n_digits * log_radix)); - } - { - bignum_type result = (allot_bignum_zeroed (length, negative_p)); - while ((n_digits--) > 0) - { - bignum_destructive_scale_up (result, ((bignum_digit_type) radix)); - bignum_destructive_add - (result, ((bignum_digit_type) ((*producer) (n_digits)))); - } - return (bignum_trim (result)); - } - } -} diff --git a/vmpp/bignum.cpp b/vm/bignum.cpp similarity index 100% rename from vmpp/bignum.cpp rename to vm/bignum.cpp diff --git a/vm/bignum.h b/vm/bignum.h deleted file mode 100644 index 02309cad34..0000000000 --- a/vm/bignum.h +++ /dev/null @@ -1,127 +0,0 @@ -/* :tabSize=2:indentSize=2:noTabs=true: - -Copyright (C) 1989-1992 Massachusetts Institute of Technology -Portions copyright (C) 2004-2007 Slava Pestov - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy and modify this software, to -redistribute either the original software or a modified version, and -to use this software for any purpose is granted, subject to the -following restrictions and understandings. - -1. Any copy made of this software must include this copyright notice -in full. - -2. Users of this software agree to make their best efforts (a) to -return to the MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. All materials developed as a consequence of the use of this -software shall duly acknowledge such use, in accordance with the usual -standards of acknowledging credit in academic research. - -4. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -typedef F_ARRAY * bignum_type; -#define BIGNUM_OUT_OF_BAND ((bignum_type) 0) - -enum bignum_comparison -{ - bignum_comparison_equal = 0, - bignum_comparison_less = -1, - bignum_comparison_greater = 1 -}; - -int bignum_equal_p(bignum_type, bignum_type); -enum bignum_comparison bignum_compare(bignum_type, bignum_type); -bignum_type bignum_add(bignum_type, bignum_type); -bignum_type bignum_subtract(bignum_type, bignum_type); -bignum_type bignum_negate(bignum_type); -bignum_type bignum_multiply(bignum_type, bignum_type); -void -bignum_divide(bignum_type numerator, bignum_type denominator, - bignum_type * quotient, bignum_type * remainder); -bignum_type bignum_quotient(bignum_type, bignum_type); -bignum_type bignum_remainder(bignum_type, bignum_type); -DLLEXPORT bignum_type fixnum_to_bignum(F_FIXNUM); -DLLEXPORT bignum_type cell_to_bignum(CELL); -DLLEXPORT bignum_type long_long_to_bignum(s64 n); -DLLEXPORT bignum_type ulong_long_to_bignum(u64 n); -F_FIXNUM bignum_to_fixnum(bignum_type); -CELL bignum_to_cell(bignum_type); -s64 bignum_to_long_long(bignum_type); -u64 bignum_to_ulong_long(bignum_type); -bignum_type double_to_bignum(double); -double bignum_to_double(bignum_type); - -/* Added bitwise operators. */ - -DLLEXPORT bignum_type bignum_bitwise_not(bignum_type), - bignum_arithmetic_shift(bignum_type, F_FIXNUM), - bignum_bitwise_and(bignum_type, bignum_type), - bignum_bitwise_ior(bignum_type, bignum_type), - bignum_bitwise_xor(bignum_type, bignum_type); - -/* Forward references */ -int bignum_equal_p_unsigned(bignum_type, bignum_type); -enum bignum_comparison bignum_compare_unsigned(bignum_type, bignum_type); -bignum_type bignum_add_unsigned(bignum_type, bignum_type, int); -bignum_type bignum_subtract_unsigned(bignum_type, bignum_type); -bignum_type bignum_multiply_unsigned(bignum_type, bignum_type, int); -bignum_type bignum_multiply_unsigned_small_factor - (bignum_type, bignum_digit_type, int); -void bignum_destructive_scale_up(bignum_type, bignum_digit_type); -void bignum_destructive_add(bignum_type, bignum_digit_type); -void bignum_divide_unsigned_large_denominator - (bignum_type, bignum_type, bignum_type *, bignum_type *, int, int); -void bignum_destructive_normalization(bignum_type, bignum_type, int); -void bignum_destructive_unnormalization(bignum_type, int); -void bignum_divide_unsigned_normalized(bignum_type, bignum_type, bignum_type); -bignum_digit_type bignum_divide_subtract - (bignum_digit_type *, bignum_digit_type *, bignum_digit_type, - bignum_digit_type *); -void bignum_divide_unsigned_medium_denominator - (bignum_type, bignum_digit_type, bignum_type *, bignum_type *, int, int); -bignum_digit_type bignum_digit_divide - (bignum_digit_type, bignum_digit_type, bignum_digit_type, bignum_digit_type *); -bignum_digit_type bignum_digit_divide_subtract - (bignum_digit_type, bignum_digit_type, bignum_digit_type, bignum_digit_type *); -void bignum_divide_unsigned_small_denominator - (bignum_type, bignum_digit_type, bignum_type *, bignum_type *, int, int); -bignum_digit_type bignum_destructive_scale_down - (bignum_type, bignum_digit_type); -bignum_type bignum_remainder_unsigned_small_denominator - (bignum_type, bignum_digit_type, int); -bignum_type bignum_digit_to_bignum(bignum_digit_type, int); -bignum_type allot_bignum(bignum_length_type, int); -bignum_type allot_bignum_zeroed(bignum_length_type, int); -bignum_type bignum_shorten_length(bignum_type, bignum_length_type); -bignum_type bignum_trim(bignum_type); -bignum_type bignum_new_sign(bignum_type, int); -bignum_type bignum_maybe_new_sign(bignum_type, int); -void bignum_destructive_copy(bignum_type, bignum_type); - -/* Added for bitwise operations. */ -bignum_type bignum_magnitude_ash(bignum_type arg1, F_FIXNUM n); -bignum_type bignum_pospos_bitwise_op(int op, bignum_type, bignum_type); -bignum_type bignum_posneg_bitwise_op(int op, bignum_type, bignum_type); -bignum_type bignum_negneg_bitwise_op(int op, bignum_type, bignum_type); -void bignum_negate_magnitude(bignum_type); - -bignum_type bignum_integer_length(bignum_type arg1); -int bignum_unsigned_logbitp(int shift, bignum_type bignum); -int bignum_logbitp(int shift, bignum_type arg); -bignum_type digit_stream_to_bignum(unsigned int n_digits, - unsigned int (*producer)(unsigned int), - unsigned int radix, - int negative_p); diff --git a/vmpp/bignum.hpp b/vm/bignum.hpp similarity index 100% rename from vmpp/bignum.hpp rename to vm/bignum.hpp diff --git a/vm/bignumint.h b/vm/bignumint.h deleted file mode 100644 index 7c835686c2..0000000000 --- a/vm/bignumint.h +++ /dev/null @@ -1,100 +0,0 @@ -/* -*-C-*- - -$Id: s48_bignumint.h,v 1.14 2005/12/21 02:36:52 spestov Exp $ - -Copyright (c) 1989-1992 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy and modify this software, to -redistribute either the original software or a modified version, and -to use this software for any purpose is granted, subject to the -following restrictions and understandings. - -1. Any copy made of this software must include this copyright notice -in full. - -2. Users of this software agree to make their best efforts (a) to -return to the MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. All materials developed as a consequence of the use of this -software shall duly acknowledge such use, in accordance with the usual -standards of acknowledging credit in academic research. - -4. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* Internal Interface to Bignum Code */ -#undef BIGNUM_ZERO_P -#undef BIGNUM_NEGATIVE_P - -/* The memory model is based on the following definitions, and on the - definition of the type `bignum_type'. The only other special - definition is `CHAR_BIT', which is defined in the Ansi C header - file "limits.h". */ - -typedef F_FIXNUM bignum_digit_type; -typedef F_FIXNUM bignum_length_type; - -/* BIGNUM_TO_POINTER casts a bignum object to a digit array pointer. */ -#define BIGNUM_TO_POINTER(bignum) ((bignum_digit_type *)AREF(bignum,0)) - -/* BIGNUM_EXCEPTION is invoked to handle assertion violations. */ -#define BIGNUM_EXCEPTION abort - - -#define BIGNUM_DIGIT_LENGTH (((sizeof (bignum_digit_type)) * CHAR_BIT) - 2) -#define BIGNUM_HALF_DIGIT_LENGTH (BIGNUM_DIGIT_LENGTH / 2) -#define BIGNUM_RADIX (((CELL) 1) << BIGNUM_DIGIT_LENGTH) -#define BIGNUM_RADIX_ROOT (((CELL) 1) << BIGNUM_HALF_DIGIT_LENGTH) -#define BIGNUM_DIGIT_MASK (BIGNUM_RADIX - 1) -#define BIGNUM_HALF_DIGIT_MASK (BIGNUM_RADIX_ROOT - 1) - -#define BIGNUM_START_PTR(bignum) \ - ((BIGNUM_TO_POINTER (bignum)) + 1) - -#define BIGNUM_LENGTH(bignum) (untag_fixnum_fast((bignum)->capacity) - 1) - -#define BIGNUM_NEGATIVE_P(bignum) (get(AREF(bignum,0)) != 0) -#define BIGNUM_SET_NEGATIVE_P(bignum,neg) put(AREF(bignum,0),neg) - -#define BIGNUM_ZERO_P(bignum) \ - ((BIGNUM_LENGTH (bignum)) == 0) - -#define BIGNUM_REF(bignum, index) \ - (* ((BIGNUM_START_PTR (bignum)) + (index))) - -/* These definitions are here to facilitate caching of the constants - 0, 1, and -1. */ -#define BIGNUM_ZERO() untag_object(bignum_zero) -#define BIGNUM_ONE(neg_p) \ - untag_object(neg_p ? bignum_neg_one : bignum_pos_one) - -#define HD_LOW(digit) ((digit) & BIGNUM_HALF_DIGIT_MASK) -#define HD_HIGH(digit) ((digit) >> BIGNUM_HALF_DIGIT_LENGTH) -#define HD_CONS(high, low) (((high) << BIGNUM_HALF_DIGIT_LENGTH) | (low)) - -#define BIGNUM_BITS_TO_DIGITS(n) \ - (((n) + (BIGNUM_DIGIT_LENGTH - 1)) / BIGNUM_DIGIT_LENGTH) - -#define BIGNUM_DIGITS_FOR(type) \ - (BIGNUM_BITS_TO_DIGITS ((sizeof (type)) * CHAR_BIT)) - -#ifndef BIGNUM_DISABLE_ASSERTION_CHECKS - -#define BIGNUM_ASSERT(expression) \ -{ \ - if (! (expression)) \ - BIGNUM_EXCEPTION (); \ -} - -#endif /* not BIGNUM_DISABLE_ASSERTION_CHECKS */ diff --git a/vmpp/bignumint.hpp b/vm/bignumint.hpp similarity index 100% rename from vmpp/bignumint.hpp rename to vm/bignumint.hpp diff --git a/vm/booleans.c b/vm/booleans.c deleted file mode 100644 index 113265873f..0000000000 --- a/vm/booleans.c +++ /dev/null @@ -1,13 +0,0 @@ -#include "master.h" - -/* FFI calls this */ -void box_boolean(bool value) -{ - dpush(value ? T : F); -} - -/* FFI calls this */ -bool to_boolean(CELL value) -{ - return value != F; -} diff --git a/vmpp/booleans.cpp b/vm/booleans.cpp similarity index 100% rename from vmpp/booleans.cpp rename to vm/booleans.cpp diff --git a/vm/booleans.h b/vm/booleans.h deleted file mode 100644 index ae49652dd8..0000000000 --- a/vm/booleans.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 to_boolean(CELL value); diff --git a/vmpp/booleans.hpp b/vm/booleans.hpp similarity index 100% rename from vmpp/booleans.hpp rename to vm/booleans.hpp diff --git a/vm/byte_arrays.c b/vm/byte_arrays.c deleted file mode 100644 index 480b4d7a9f..0000000000 --- a/vm/byte_arrays.c +++ /dev/null @@ -1,85 +0,0 @@ -#include "master.h" - -/* must fill out array before next GC */ -F_BYTE_ARRAY *allot_byte_array_internal(CELL size) -{ - F_BYTE_ARRAY *array = allot_object(BYTE_ARRAY_TYPE, - byte_array_size(size)); - array->capacity = tag_fixnum(size); - return array; -} - -/* size is in bytes this time */ -F_BYTE_ARRAY *allot_byte_array(CELL size) -{ - F_BYTE_ARRAY *array = allot_byte_array_internal(size); - memset(array + 1,0,size); - return array; -} - -/* push a new byte array on the stack */ -void primitive_byte_array(void) -{ - CELL size = unbox_array_size(); - dpush(tag_object(allot_byte_array(size))); -} - -void primitive_uninitialized_byte_array(void) -{ - CELL size = unbox_array_size(); - dpush(tag_object(allot_byte_array_internal(size))); -} - -static bool reallot_byte_array_in_place_p(F_BYTE_ARRAY *array, CELL capacity) -{ - return in_zone(&nursery,(CELL)array) && capacity <= array_capacity(array); -} - -F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity) -{ -#ifdef FACTOR_DEBUG - assert(untag_header(array->header) == BYTE_ARRAY_TYPE); -#endif - if(reallot_byte_array_in_place_p(array,capacity)) - { - array->capacity = tag_fixnum(capacity); - return array; - } - else - { - CELL to_copy = array_capacity(array); - if(capacity < to_copy) - to_copy = capacity; - - REGISTER_UNTAGGED(array); - F_BYTE_ARRAY *new_array = allot_byte_array_internal(capacity); - UNREGISTER_UNTAGGED(array); - - memcpy(new_array + 1,array + 1,to_copy); - - return new_array; - } -} - -void primitive_resize_byte_array(void) -{ - F_BYTE_ARRAY* array = untag_byte_array(dpop()); - CELL capacity = unbox_array_size(); - dpush(tag_object(reallot_byte_array(array,capacity))); -} - -void growable_byte_array_append(F_GROWABLE_BYTE_ARRAY *array, void *elts, CELL len) -{ - CELL new_size = array->count + len; - F_BYTE_ARRAY *underlying = untag_object(array->array); - - if(new_size >= byte_array_capacity(underlying)) - { - underlying = reallot_byte_array(underlying,new_size * 2); - array->array = tag_object(underlying); - } - - memcpy((void *)BREF(underlying,array->count),elts,len); - - array->count += len; -} diff --git a/vmpp/byte_arrays.cpp b/vm/byte_arrays.cpp similarity index 100% rename from vmpp/byte_arrays.cpp rename to vm/byte_arrays.cpp diff --git a/vm/byte_arrays.h b/vm/byte_arrays.h deleted file mode 100644 index 65c9731047..0000000000 --- a/vm/byte_arrays.h +++ /dev/null @@ -1,40 +0,0 @@ -DEFINE_UNTAG(F_BYTE_ARRAY,BYTE_ARRAY_TYPE,byte_array) - -INLINE CELL byte_array_capacity(F_BYTE_ARRAY *array) -{ - return untag_fixnum_fast(array->capacity); -} - -INLINE CELL byte_array_size(CELL size) -{ - return sizeof(F_BYTE_ARRAY) + size; -} - -F_BYTE_ARRAY *allot_byte_array(CELL size); -F_BYTE_ARRAY *allot_byte_array_internal(CELL size); -F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity); - -void primitive_byte_array(void); -void primitive_uninitialized_byte_array(void); -void primitive_resize_byte_array(void); - -/* Macros to simulate a byte vector in C */ -typedef struct { - CELL count; - CELL array; -} F_GROWABLE_BYTE_ARRAY; - -INLINE F_GROWABLE_BYTE_ARRAY make_growable_byte_array(void) -{ - F_GROWABLE_BYTE_ARRAY result; - result.count = 0; - result.array = tag_object(allot_byte_array(100)); - return result; -} - -void growable_byte_array_append(F_GROWABLE_BYTE_ARRAY *result, void *elts, CELL len); - -INLINE void growable_byte_array_trim(F_GROWABLE_BYTE_ARRAY *byte_array) -{ - byte_array->array = tag_object(reallot_byte_array(untag_object(byte_array->array),byte_array->count)); -} diff --git a/vmpp/byte_arrays.hpp b/vm/byte_arrays.hpp similarity index 100% rename from vmpp/byte_arrays.hpp rename to vm/byte_arrays.hpp diff --git a/vm/callstack.c b/vm/callstack.c deleted file mode 100755 index 26f8589c29..0000000000 --- a/vm/callstack.c +++ /dev/null @@ -1,230 +0,0 @@ -#include "master.h" - -/* called before entry into Factor code. */ -F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom) -{ - stack_chain->callstack_bottom = callstack_bottom; -} - -void iterate_callstack(CELL top, CELL bottom, CALLSTACK_ITER iterator) -{ - F_STACK_FRAME *frame = (F_STACK_FRAME *)bottom - 1; - - while((CELL)frame >= top) - { - F_STACK_FRAME *next = frame_successor(frame); - iterator(frame); - frame = next; - } -} - -void iterate_callstack_object(F_CALLSTACK *stack, CALLSTACK_ITER iterator) -{ - CELL top = (CELL)FIRST_STACK_FRAME(stack); - CELL bottom = top + untag_fixnum_fast(stack->length); - - iterate_callstack(top,bottom,iterator); -} - -F_CALLSTACK *allot_callstack(CELL size) -{ - F_CALLSTACK *callstack = allot_object( - CALLSTACK_TYPE, - callstack_size(size)); - callstack->length = tag_fixnum(size); - return callstack; -} - -F_STACK_FRAME *fix_callstack_top(F_STACK_FRAME *top, F_STACK_FRAME *bottom) -{ - F_STACK_FRAME *frame = bottom - 1; - - while(frame >= top) - frame = frame_successor(frame); - - return frame + 1; -} - -/* We ignore the topmost frame, the one calling 'callstack', -so that set-callstack doesn't get stuck in an infinite loop. - -This means that if 'callstack' is called in tail position, we -will have popped a necessary frame... however this word is only -called by continuation implementation, and user code shouldn't -be calling it at all, so we leave it as it is for now. */ -F_STACK_FRAME *capture_start(void) -{ - F_STACK_FRAME *frame = stack_chain->callstack_bottom - 1; - while(frame >= stack_chain->callstack_top - && frame_successor(frame) >= stack_chain->callstack_top) - { - frame = frame_successor(frame); - } - return frame + 1; -} - -void primitive_callstack(void) -{ - F_STACK_FRAME *top = capture_start(); - F_STACK_FRAME *bottom = stack_chain->callstack_bottom; - - F_FIXNUM size = (CELL)bottom - (CELL)top; - if(size < 0) - size = 0; - - F_CALLSTACK *callstack = allot_callstack(size); - memcpy(FIRST_STACK_FRAME(callstack),top,size); - dpush(tag_object(callstack)); -} - -void primitive_set_callstack(void) -{ - F_CALLSTACK *stack = untag_callstack(dpop()); - - set_callstack(stack_chain->callstack_bottom, - FIRST_STACK_FRAME(stack), - untag_fixnum_fast(stack->length), - memcpy); - - /* We cannot return here ... */ - critical_error("Bug in set_callstack()",0); -} - -F_CODE_BLOCK *frame_code(F_STACK_FRAME *frame) -{ - return (F_CODE_BLOCK *)frame->xt - 1; -} - -CELL frame_type(F_STACK_FRAME *frame) -{ - return frame_code(frame)->block.type; -} - -CELL frame_executing(F_STACK_FRAME *frame) -{ - F_CODE_BLOCK *compiled = frame_code(frame); - if(compiled->literals == F || !stack_traces_p()) - return F; - else - { - F_ARRAY *array = untag_object(compiled->literals); - return array_nth(array,0); - } -} - -F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame) -{ - if(frame->size == 0) - critical_error("Stack frame has zero size",(CELL)frame); - return (F_STACK_FRAME *)((CELL)frame - frame->size); -} - -CELL frame_scan(F_STACK_FRAME *frame) -{ - if(frame_type(frame) == QUOTATION_TYPE) - { - CELL quot = frame_executing(frame); - if(quot == F) - return F; - else - { - XT return_addr = FRAME_RETURN_ADDRESS(frame); - XT quot_xt = (XT)(frame_code(frame) + 1); - - return tag_fixnum(quot_code_offset_to_scan( - quot,(CELL)(return_addr - quot_xt))); - } - } - else - return F; -} - -/* C doesn't have closures... */ -static CELL frame_count; - -void count_stack_frame(F_STACK_FRAME *frame) -{ - frame_count += 2; -} - -static CELL frame_index; -static F_ARRAY *array; - -void stack_frame_to_array(F_STACK_FRAME *frame) -{ - set_array_nth(array,frame_index++,frame_executing(frame)); - set_array_nth(array,frame_index++,frame_scan(frame)); -} - -void primitive_callstack_to_array(void) -{ - F_CALLSTACK *stack = untag_callstack(dpop()); - - frame_count = 0; - iterate_callstack_object(stack,count_stack_frame); - - REGISTER_UNTAGGED(stack); - array = allot_array_internal(ARRAY_TYPE,frame_count); - UNREGISTER_UNTAGGED(stack); - - frame_index = 0; - iterate_callstack_object(stack,stack_frame_to_array); - - dpush(tag_array(array)); -} - -F_STACK_FRAME *innermost_stack_frame(F_CALLSTACK *callstack) -{ - F_STACK_FRAME *top = FIRST_STACK_FRAME(callstack); - CELL bottom = (CELL)top + untag_fixnum_fast(callstack->length); - - F_STACK_FRAME *frame = (F_STACK_FRAME *)bottom - 1; - - while(frame >= top && frame_successor(frame) >= top) - frame = frame_successor(frame); - - return frame; -} - -/* Some primitives implementing a limited form of callstack mutation. -Used by the single stepper. */ -void primitive_innermost_stack_frame_quot(void) -{ - F_STACK_FRAME *inner = innermost_stack_frame( - untag_callstack(dpop())); - type_check(QUOTATION_TYPE,frame_executing(inner)); - - dpush(frame_executing(inner)); -} - -void primitive_innermost_stack_frame_scan(void) -{ - F_STACK_FRAME *inner = innermost_stack_frame( - untag_callstack(dpop())); - type_check(QUOTATION_TYPE,frame_executing(inner)); - - dpush(frame_scan(inner)); -} - -void primitive_set_innermost_stack_frame_quot(void) -{ - F_CALLSTACK *callstack = untag_callstack(dpop()); - F_QUOTATION *quot = untag_quotation(dpop()); - - REGISTER_UNTAGGED(callstack); - REGISTER_UNTAGGED(quot); - - jit_compile(tag_quotation(quot),true); - - UNREGISTER_UNTAGGED(quot); - UNREGISTER_UNTAGGED(callstack); - - F_STACK_FRAME *inner = innermost_stack_frame(callstack); - type_check(QUOTATION_TYPE,frame_executing(inner)); - - CELL offset = FRAME_RETURN_ADDRESS(inner) - inner->xt; - - inner->xt = quot->xt; - - FRAME_RETURN_ADDRESS(inner) = quot->xt + offset; -} diff --git a/vmpp/callstack.cpp b/vm/callstack.cpp similarity index 100% rename from vmpp/callstack.cpp rename to vm/callstack.cpp diff --git a/vm/callstack.h b/vm/callstack.h deleted file mode 100755 index 8b693c451c..0000000000 --- a/vm/callstack.h +++ /dev/null @@ -1,28 +0,0 @@ -INLINE CELL callstack_size(CELL size) -{ - return sizeof(F_CALLSTACK) + size; -} - -DEFINE_UNTAG(F_CALLSTACK,CALLSTACK_TYPE,callstack) - -F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom); - -#define FIRST_STACK_FRAME(stack) (F_STACK_FRAME *)((stack) + 1) - -typedef void (*CALLSTACK_ITER)(F_STACK_FRAME *frame); - -F_STACK_FRAME *fix_callstack_top(F_STACK_FRAME *top, F_STACK_FRAME *bottom); -void iterate_callstack(CELL top, CELL bottom, CALLSTACK_ITER iterator); -void iterate_callstack_object(F_CALLSTACK *stack, CALLSTACK_ITER iterator); -F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame); -F_CODE_BLOCK *frame_code(F_STACK_FRAME *frame); -CELL frame_executing(F_STACK_FRAME *frame); -CELL frame_scan(F_STACK_FRAME *frame); -CELL frame_type(F_STACK_FRAME *frame); - -void primitive_callstack(void); -void primitive_set_callstack(void); -void primitive_callstack_to_array(void); -void primitive_innermost_stack_frame_quot(void); -void primitive_innermost_stack_frame_scan(void); -void primitive_set_innermost_stack_frame_quot(void); diff --git a/vmpp/callstack.hpp b/vm/callstack.hpp similarity index 100% rename from vmpp/callstack.hpp rename to vm/callstack.hpp diff --git a/vm/code_block.c b/vm/code_block.c deleted file mode 100644 index f2ddc717f7..0000000000 --- a/vm/code_block.c +++ /dev/null @@ -1,506 +0,0 @@ -#include "master.h" - -void flush_icache_for(F_CODE_BLOCK *block) -{ - flush_icache((CELL)block,block->block.size); -} - -void iterate_relocations(F_CODE_BLOCK *compiled, RELOCATION_ITERATOR iter) -{ - if(compiled->relocation != F) - { - F_BYTE_ARRAY *relocation = untag_object(compiled->relocation); - - CELL index = stack_traces_p() ? 1 : 0; - - F_REL *rel = (F_REL *)(relocation + 1); - F_REL *rel_end = (F_REL *)((char *)rel + byte_array_capacity(relocation)); - - while(rel < rel_end) - { - iter(*rel,index,compiled); - - switch(REL_TYPE(*rel)) - { - case RT_PRIMITIVE: - case RT_XT: - case RT_XT_DIRECT: - case RT_IMMEDIATE: - case RT_HERE: - case RT_UNTAGGED: - index++; - break; - case RT_DLSYM: - index += 2; - break; - case RT_THIS: - case RT_STACK_CHAIN: - break; - default: - critical_error("Bad rel type",*rel); - return; /* Can't happen */ - } - - rel++; - } - } -} - -/* Store a 32-bit value into a PowerPC LIS/ORI sequence */ -INLINE void store_address_2_2(CELL cell, CELL value) -{ - put(cell - CELLS,((get(cell - CELLS) & ~0xffff) | ((value >> 16) & 0xffff))); - put(cell,((get(cell) & ~0xffff) | (value & 0xffff))); -} - -/* Store a value into a bitfield of a PowerPC instruction */ -INLINE void store_address_masked(CELL cell, F_FIXNUM value, CELL mask, F_FIXNUM shift) -{ - /* This is unaccurate but good enough */ - F_FIXNUM test = (F_FIXNUM)mask >> 1; - if(value <= -test || value >= test) - critical_error("Value does not fit inside relocation",0); - - u32 original = *(u32*)cell; - original &= ~mask; - *(u32*)cell = (original | ((value >> shift) & mask)); -} - -/* Perform a fixup on a code block */ -void store_address_in_code_block(CELL class, CELL offset, F_FIXNUM absolute_value) -{ - F_FIXNUM relative_value = absolute_value - offset; - - switch(class) - { - case RC_ABSOLUTE_CELL: - put(offset,absolute_value); - break; - case RC_ABSOLUTE: - *(u32*)offset = absolute_value; - break; - case RC_RELATIVE: - *(u32*)offset = relative_value - sizeof(u32); - break; - case RC_ABSOLUTE_PPC_2_2: - store_address_2_2(offset,absolute_value); - break; - case RC_RELATIVE_PPC_2: - store_address_masked(offset,relative_value,REL_RELATIVE_PPC_2_MASK,0); - break; - case RC_RELATIVE_PPC_3: - store_address_masked(offset,relative_value,REL_RELATIVE_PPC_3_MASK,0); - break; - case RC_RELATIVE_ARM_3: - store_address_masked(offset,relative_value - CELLS * 2, - REL_RELATIVE_ARM_3_MASK,2); - break; - case RC_INDIRECT_ARM: - store_address_masked(offset,relative_value - CELLS, - REL_INDIRECT_ARM_MASK,0); - break; - case RC_INDIRECT_ARM_PC: - store_address_masked(offset,relative_value - CELLS * 2, - REL_INDIRECT_ARM_MASK,0); - break; - default: - critical_error("Bad rel class",class); - break; - } -} - -void update_literal_references_step(F_REL rel, CELL index, F_CODE_BLOCK *compiled) -{ - if(REL_TYPE(rel) == RT_IMMEDIATE) - { - CELL offset = REL_OFFSET(rel) + (CELL)(compiled + 1); - F_ARRAY *literals = untag_object(compiled->literals); - F_FIXNUM absolute_value = array_nth(literals,index); - store_address_in_code_block(REL_CLASS(rel),offset,absolute_value); - } -} - -/* Update pointers to literals from compiled code. */ -void update_literal_references(F_CODE_BLOCK *compiled) -{ - iterate_relocations(compiled,update_literal_references_step); - flush_icache_for(compiled); -} - -/* Copy all literals referenced from a code block to newspace. Only for -aging and nursery collections */ -void copy_literal_references(F_CODE_BLOCK *compiled) -{ - if(collecting_gen >= compiled->block.last_scan) - { - if(collecting_accumulation_gen_p()) - compiled->block.last_scan = collecting_gen; - else - compiled->block.last_scan = collecting_gen + 1; - - /* initialize chase pointer */ - CELL scan = newspace->here; - - copy_handle(&compiled->literals); - copy_handle(&compiled->relocation); - - /* do some tracing so that all reachable literals are now - at their final address */ - copy_reachable_objects(scan,&newspace->here); - - update_literal_references(compiled); - } -} - -CELL object_xt(CELL obj) -{ - if(TAG(obj) == QUOTATION_TYPE) - { - F_QUOTATION *quot = untag_object(obj); - return (CELL)quot->xt; - } - else - { - F_WORD *word = untag_object(obj); - return (CELL)word->xt; - } -} - -CELL word_direct_xt(CELL obj) -{ -#ifdef FACTOR_DEBUG - type_check(WORD_TYPE,obj); -#endif - F_WORD *word = untag_object(obj); - CELL quot = word->direct_entry_def; - if(quot == F || max_pic_size == 0) - return (CELL)word->xt; - else - { - F_QUOTATION *untagged = untag_object(quot); -#ifdef FACTOR_DEBUG - type_check(QUOTATION_TYPE,quot); -#endif - if(untagged->compiledp == F) - return (CELL)word->xt; - else - return (CELL)untagged->xt; - } -} - -void update_word_references_step(F_REL rel, CELL index, F_CODE_BLOCK *compiled) -{ - F_RELTYPE type = REL_TYPE(rel); - if(type == RT_XT || type == RT_XT_DIRECT) - { - CELL offset = REL_OFFSET(rel) + (CELL)(compiled + 1); - F_ARRAY *literals = untag_object(compiled->literals); - CELL obj = array_nth(literals,index); - - CELL xt; - if(type == RT_XT) - xt = object_xt(obj); - else - xt = word_direct_xt(obj); - - store_address_in_code_block(REL_CLASS(rel),offset,xt); - } -} - -/* Relocate new code blocks completely; updating references to literals, -dlsyms, and words. For all other words in the code heap, we only need -to update references to other words, without worrying about literals -or dlsyms. */ -void update_word_references(F_CODE_BLOCK *compiled) -{ - if(compiled->block.needs_fixup) - relocate_code_block(compiled); - /* update_word_references() is always applied to every block in - the code heap. Since it resets all call sites to point to - their canonical XT (cold entry point for non-tail calls, - standard entry point for tail calls), it means that no PICs - are referenced after this is done. So instead of polluting - the code heap with dead PICs that will be freed on the next - GC, we add them to the free list immediately. */ - else if(compiled->block.type == PIC_TYPE) - { - fflush(stdout); - heap_free(&code_heap,&compiled->block); - } - else - { - iterate_relocations(compiled,update_word_references_step); - flush_icache_for(compiled); - } -} - -void update_literal_and_word_references(F_CODE_BLOCK *compiled) -{ - update_literal_references(compiled); - update_word_references(compiled); -} - -INLINE void check_code_address(CELL address) -{ -#ifdef FACTOR_DEBUG - assert(address >= code_heap.segment->start && address < code_heap.segment->end); -#endif -} - -/* Update references to words. This is done after a new code block -is added to the heap. */ - -/* Mark all literals referenced from a word XT. Only for tenured -collections */ -void mark_code_block(F_CODE_BLOCK *compiled) -{ - check_code_address((CELL)compiled); - - mark_block(&compiled->block); - - copy_handle(&compiled->literals); - copy_handle(&compiled->relocation); -} - -void mark_stack_frame_step(F_STACK_FRAME *frame) -{ - mark_code_block(frame_code(frame)); -} - -/* Mark code blocks executing in currently active stack frames. */ -void mark_active_blocks(F_CONTEXT *stacks) -{ - if(collecting_gen == TENURED) - { - CELL top = (CELL)stacks->callstack_top; - CELL bottom = (CELL)stacks->callstack_bottom; - - iterate_callstack(top,bottom,mark_stack_frame_step); - } -} - -void mark_object_code_block(CELL scan) -{ - F_WORD *word; - F_QUOTATION *quot; - F_CALLSTACK *stack; - - switch(hi_tag(scan)) - { - case WORD_TYPE: - word = (F_WORD *)scan; - if(word->code) - mark_code_block(word->code); - if(word->profiling) - mark_code_block(word->profiling); - break; - case QUOTATION_TYPE: - quot = (F_QUOTATION *)scan; - if(quot->compiledp != F) - mark_code_block(quot->code); - break; - case CALLSTACK_TYPE: - stack = (F_CALLSTACK *)scan; - iterate_callstack_object(stack,mark_stack_frame_step); - break; - } -} - -/* References to undefined symbols are patched up to call this function on -image load */ -void undefined_symbol(void) -{ - general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL); -} - -/* Look up an external library symbol referenced by a compiled code block */ -void *get_rel_symbol(F_ARRAY *literals, CELL index) -{ - CELL symbol = array_nth(literals,index); - CELL library = array_nth(literals,index + 1); - - F_DLL *dll = (library == F ? NULL : untag_dll(library)); - - if(dll != NULL && !dll->dll) - return undefined_symbol; - - if(type_of(symbol) == BYTE_ARRAY_TYPE) - { - F_SYMBOL *name = alien_offset(symbol); - void *sym = ffi_dlsym(dll,name); - - if(sym) - return sym; - } - else if(type_of(symbol) == ARRAY_TYPE) - { - CELL i; - F_ARRAY *names = untag_object(symbol); - for(i = 0; i < array_capacity(names); i++) - { - F_SYMBOL *name = alien_offset(array_nth(names,i)); - void *sym = ffi_dlsym(dll,name); - - if(sym) - return sym; - } - } - - return undefined_symbol; -} - -/* Compute an address to store at a relocation */ -void relocate_code_block_step(F_REL rel, CELL index, F_CODE_BLOCK *compiled) -{ -#ifdef FACTOR_DEBUG - type_check(ARRAY_TYPE,compiled->literals); - type_check(BYTE_ARRAY_TYPE,compiled->relocation); -#endif - - CELL offset = REL_OFFSET(rel) + (CELL)(compiled + 1); - F_ARRAY *literals = untag_object(compiled->literals); - F_FIXNUM absolute_value; - - switch(REL_TYPE(rel)) - { - case RT_PRIMITIVE: - absolute_value = (CELL)primitives[to_fixnum(array_nth(literals,index))]; - break; - case RT_DLSYM: - absolute_value = (CELL)get_rel_symbol(literals,index); - break; - case RT_IMMEDIATE: - absolute_value = array_nth(literals,index); - break; - case RT_XT: - absolute_value = object_xt(array_nth(literals,index)); - break; - case RT_XT_DIRECT: - absolute_value = word_direct_xt(array_nth(literals,index)); - break; - case RT_HERE: - absolute_value = offset + (short)to_fixnum(array_nth(literals,index)); - break; - case RT_THIS: - absolute_value = (CELL)(compiled + 1); - break; - case RT_STACK_CHAIN: - absolute_value = (CELL)&stack_chain; - break; - case RT_UNTAGGED: - absolute_value = to_fixnum(array_nth(literals,index)); - break; - default: - critical_error("Bad rel type",rel); - return; /* Can't happen */ - } - - store_address_in_code_block(REL_CLASS(rel),offset,absolute_value); -} - -/* Perform all fixups on a code block */ -void relocate_code_block(F_CODE_BLOCK *compiled) -{ - compiled->block.last_scan = NURSERY; - compiled->block.needs_fixup = false; - iterate_relocations(compiled,relocate_code_block_step); - flush_icache_for(compiled); -} - -/* Fixup labels. This is done at compile time, not image load time */ -void fixup_labels(F_ARRAY *labels, F_CODE_BLOCK *compiled) -{ - CELL i; - CELL size = array_capacity(labels); - - for(i = 0; i < size; i += 3) - { - CELL class = to_fixnum(array_nth(labels,i)); - CELL offset = to_fixnum(array_nth(labels,i + 1)); - CELL target = to_fixnum(array_nth(labels,i + 2)); - - store_address_in_code_block(class, - offset + (CELL)(compiled + 1), - target + (CELL)(compiled + 1)); - } -} - -/* Might GC */ -F_CODE_BLOCK *allot_code_block(CELL size) -{ - F_BLOCK *block = heap_allot(&code_heap,size + sizeof(F_CODE_BLOCK)); - - /* If allocation failed, do a code GC */ - if(block == NULL) - { - gc(); - block = heap_allot(&code_heap,size + sizeof(F_CODE_BLOCK)); - - /* Insufficient room even after code GC, give up */ - if(block == NULL) - { - CELL used, total_free, max_free; - heap_usage(&code_heap,&used,&total_free,&max_free); - - print_string("Code heap stats:\n"); - print_string("Used: "); print_cell(used); nl(); - print_string("Total free space: "); print_cell(total_free); nl(); - print_string("Largest free block: "); print_cell(max_free); nl(); - fatal_error("Out of memory in add-compiled-block",0); - } - } - - return (F_CODE_BLOCK *)block; -} - -/* Might GC */ -F_CODE_BLOCK *add_code_block( - CELL type, - F_BYTE_ARRAY *code, - F_ARRAY *labels, - CELL relocation, - CELL literals) -{ -#ifdef FACTOR_DEBUG - type_check(ARRAY_TYPE,literals); - type_check(BYTE_ARRAY_TYPE,relocation); - assert(untag_header(code->header) == BYTE_ARRAY_TYPE); -#endif - - CELL code_length = align8(array_capacity(code)); - - REGISTER_ROOT(literals); - REGISTER_ROOT(relocation); - REGISTER_UNTAGGED(code); - REGISTER_UNTAGGED(labels); - - F_CODE_BLOCK *compiled = allot_code_block(code_length); - - UNREGISTER_UNTAGGED(labels); - UNREGISTER_UNTAGGED(code); - UNREGISTER_ROOT(relocation); - UNREGISTER_ROOT(literals); - - /* slight space optimization */ - if(type_of(literals) == ARRAY_TYPE && array_capacity(untag_object(literals)) == 0) - literals = F; - - /* compiled header */ - compiled->block.type = type; - compiled->block.last_scan = NURSERY; - compiled->block.needs_fixup = true; - compiled->literals = literals; - compiled->relocation = relocation; - - /* code */ - memcpy(compiled + 1,code + 1,code_length); - - /* fixup labels */ - if(labels) fixup_labels(labels,compiled); - - /* next time we do a minor GC, we have to scan the code heap for - literals */ - last_code_heap_scan = NURSERY; - - return compiled; -} diff --git a/vmpp/code_block.cpp b/vm/code_block.cpp similarity index 100% rename from vmpp/code_block.cpp rename to vm/code_block.cpp diff --git a/vm/code_block.h b/vm/code_block.h deleted file mode 100644 index 385f414f88..0000000000 --- a/vm/code_block.h +++ /dev/null @@ -1,92 +0,0 @@ -typedef enum { - /* arg is a primitive number */ - RT_PRIMITIVE, - /* arg is a literal table index, holding an array pair (symbol/dll) */ - RT_DLSYM, - /* a pointer to a compiled word reference */ - RT_DISPATCH, - /* a word's general entry point XT */ - RT_XT, - /* a word's direct entry point XT */ - RT_XT_DIRECT, - /* current offset */ - RT_HERE, - /* current code block */ - RT_THIS, - /* immediate literal */ - RT_IMMEDIATE, - /* address of stack_chain var */ - RT_STACK_CHAIN, - /* untagged fixnum literal */ - RT_UNTAGGED, -} F_RELTYPE; - -typedef enum { - /* absolute address in a 64-bit location */ - RC_ABSOLUTE_CELL, - /* absolute address in a 32-bit location */ - RC_ABSOLUTE, - /* relative address in a 32-bit location */ - RC_RELATIVE, - /* relative address in a PowerPC LIS/ORI sequence */ - RC_ABSOLUTE_PPC_2_2, - /* relative address in a PowerPC LWZ/STW/BC instruction */ - RC_RELATIVE_PPC_2, - /* relative address in a PowerPC B/BL instruction */ - RC_RELATIVE_PPC_3, - /* relative address in an ARM B/BL instruction */ - RC_RELATIVE_ARM_3, - /* pointer to address in an ARM LDR/STR instruction */ - RC_INDIRECT_ARM, - /* pointer to address in an ARM LDR/STR instruction offset by 8 bytes */ - RC_INDIRECT_ARM_PC -} F_RELCLASS; - -#define REL_RELATIVE_PPC_2_MASK 0xfffc -#define REL_RELATIVE_PPC_3_MASK 0x3fffffc -#define REL_INDIRECT_ARM_MASK 0xfff -#define REL_RELATIVE_ARM_3_MASK 0xffffff - -/* code relocation table consists of a table of entries for each fixup */ -typedef u32 F_REL; -#define REL_TYPE(r) (((r) & 0xf0000000) >> 28) -#define REL_CLASS(r) (((r) & 0x0f000000) >> 24) -#define REL_OFFSET(r) ((r) & 0x00ffffff) - -void flush_icache_for(F_CODE_BLOCK *compiled); - -typedef void (*RELOCATION_ITERATOR)(F_REL rel, CELL index, F_CODE_BLOCK *compiled); - -void iterate_relocations(F_CODE_BLOCK *compiled, RELOCATION_ITERATOR iter); - -void store_address_in_code_block(CELL class, CELL offset, F_FIXNUM absolute_value); - -void relocate_code_block(F_CODE_BLOCK *compiled); - -void update_literal_references(F_CODE_BLOCK *compiled); - -void copy_literal_references(F_CODE_BLOCK *compiled); - -void update_word_references(F_CODE_BLOCK *compiled); - -void update_literal_and_word_references(F_CODE_BLOCK *compiled); - -void mark_code_block(F_CODE_BLOCK *compiled); - -void mark_active_blocks(F_CONTEXT *stacks); - -void mark_object_code_block(CELL scan); - -void relocate_code_block(F_CODE_BLOCK *relocating); - -INLINE bool stack_traces_p(void) -{ - return userenv[STACK_TRACES_ENV] != F; -} - -F_CODE_BLOCK *add_code_block( - CELL type, - F_BYTE_ARRAY *code, - F_ARRAY *labels, - CELL relocation, - CELL literals); diff --git a/vmpp/code_block.hpp b/vm/code_block.hpp similarity index 100% rename from vmpp/code_block.hpp rename to vm/code_block.hpp diff --git a/vm/code_gc.c b/vm/code_gc.c deleted file mode 100755 index c7ab02c6e6..0000000000 --- a/vm/code_gc.c +++ /dev/null @@ -1,336 +0,0 @@ -#include "master.h" - -static void clear_free_list(F_HEAP *heap) -{ - memset(&heap->free,0,sizeof(F_HEAP_FREE_LIST)); -} - -/* This malloc-style heap code is reasonably generic. Maybe in the future, it -will be used for the data heap too, if we ever get incremental -mark/sweep/compact GC. */ -void new_heap(F_HEAP *heap, CELL size) -{ - heap->segment = alloc_segment(align_page(size)); - if(!heap->segment) - fatal_error("Out of memory in new_heap",size); - - clear_free_list(heap); -} - -static void add_to_free_list(F_HEAP *heap, F_FREE_BLOCK *block) -{ - if(block->block.size < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT) - { - int index = block->block.size / BLOCK_SIZE_INCREMENT; - block->next_free = heap->free.small_blocks[index]; - heap->free.small_blocks[index] = block; - } - else - { - block->next_free = heap->free.large_blocks; - heap->free.large_blocks = block; - } -} - -/* Called after reading the code heap from the image file, and after code GC. - -In the former case, we must add a large free block from compiling.base + size to -compiling.limit. */ -void build_free_list(F_HEAP *heap, CELL size) -{ - F_BLOCK *prev = NULL; - - clear_free_list(heap); - - size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1); - - F_BLOCK *scan = first_block(heap); - F_FREE_BLOCK *end = (F_FREE_BLOCK *)(heap->segment->start + size); - - /* Add all free blocks to the free list */ - while(scan && scan < (F_BLOCK *)end) - { - switch(scan->status) - { - case B_FREE: - add_to_free_list(heap,(F_FREE_BLOCK *)scan); - break; - case B_ALLOCATED: - break; - default: - critical_error("Invalid scan->status",(CELL)scan); - break; - } - - prev = scan; - scan = next_block(heap,scan); - } - - /* If there is room at the end of the heap, add a free block. This - branch is only taken after loading a new image, not after code GC */ - if((CELL)(end + 1) <= heap->segment->end) - { - end->block.status = B_FREE; - end->block.size = heap->segment->end - (CELL)end; - - /* add final free block */ - add_to_free_list(heap,end); - } - /* This branch is taken if the newly loaded image fits exactly, or - after code GC */ - else - { - /* even if there's no room at the end of the heap for a new - free block, we might have to jigger it up by a few bytes in - case prev + prev->size */ - if(prev) prev->size = heap->segment->end - (CELL)prev; - } - -} - -static void assert_free_block(F_FREE_BLOCK *block) -{ - if(block->block.status != B_FREE) - critical_error("Invalid block in free list",(CELL)block); -} - -static F_FREE_BLOCK *find_free_block(F_HEAP *heap, CELL size) -{ - CELL attempt = size; - - while(attempt < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT) - { - int index = attempt / BLOCK_SIZE_INCREMENT; - F_FREE_BLOCK *block = heap->free.small_blocks[index]; - if(block) - { - assert_free_block(block); - heap->free.small_blocks[index] = block->next_free; - return block; - } - - attempt *= 2; - } - - F_FREE_BLOCK *prev = NULL; - F_FREE_BLOCK *block = heap->free.large_blocks; - - while(block) - { - assert_free_block(block); - if(block->block.size >= size) - { - if(prev) - prev->next_free = block->next_free; - else - heap->free.large_blocks = block->next_free; - return block; - } - - prev = block; - block = block->next_free; - } - - return NULL; -} - -static F_FREE_BLOCK *split_free_block(F_HEAP *heap, F_FREE_BLOCK *block, CELL size) -{ - if(block->block.size != size ) - { - /* split the block in two */ - F_FREE_BLOCK *split = (F_FREE_BLOCK *)((CELL)block + size); - split->block.status = B_FREE; - split->block.size = block->block.size - size; - split->next_free = block->next_free; - block->block.size = size; - add_to_free_list(heap,split); - } - - return block; -} - -/* Allocate a block of memory from the mark and sweep GC heap */ -F_BLOCK *heap_allot(F_HEAP *heap, CELL size) -{ - size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1); - - F_FREE_BLOCK *block = find_free_block(heap,size); - if(block) - { - block = split_free_block(heap,block,size); - - block->block.status = B_ALLOCATED; - return &block->block; - } - else - return NULL; -} - -/* Deallocates a block manually */ -void heap_free(F_HEAP *heap, F_BLOCK *block) -{ - block->status = B_FREE; - add_to_free_list(heap,(F_FREE_BLOCK *)block); -} - -void mark_block(F_BLOCK *block) -{ - /* If already marked, do nothing */ - switch(block->status) - { - case B_MARKED: - return; - case B_ALLOCATED: - block->status = B_MARKED; - break; - default: - critical_error("Marking the wrong block",(CELL)block); - break; - } -} - -/* If in the middle of code GC, we have to grow the heap, data GC restarts from -scratch, so we have to unmark any marked blocks. */ -void unmark_marked(F_HEAP *heap) -{ - F_BLOCK *scan = first_block(heap); - - while(scan) - { - if(scan->status == B_MARKED) - scan->status = B_ALLOCATED; - - scan = next_block(heap,scan); - } -} - -/* After code GC, all referenced code blocks have status set to B_MARKED, so any -which are allocated and not marked can be reclaimed. */ -void free_unmarked(F_HEAP *heap, HEAP_ITERATOR iter) -{ - clear_free_list(heap); - - F_BLOCK *prev = NULL; - F_BLOCK *scan = first_block(heap); - - while(scan) - { - switch(scan->status) - { - case B_ALLOCATED: - if(secure_gc) - memset(scan + 1,0,scan->size - sizeof(F_BLOCK)); - - if(prev && prev->status == B_FREE) - prev->size += scan->size; - else - { - scan->status = B_FREE; - prev = scan; - } - break; - case B_FREE: - if(prev && prev->status == B_FREE) - prev->size += scan->size; - else - prev = scan; - break; - case B_MARKED: - if(prev && prev->status == B_FREE) - add_to_free_list(heap,(F_FREE_BLOCK *)prev); - scan->status = B_ALLOCATED; - prev = scan; - iter(scan); - break; - default: - critical_error("Invalid scan->status",(CELL)scan); - } - - scan = next_block(heap,scan); - } - - if(prev && prev->status == B_FREE) - add_to_free_list(heap,(F_FREE_BLOCK *)prev); -} - -/* Compute total sum of sizes of free blocks, and size of largest free block */ -void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free) -{ - *used = 0; - *total_free = 0; - *max_free = 0; - - F_BLOCK *scan = first_block(heap); - - while(scan) - { - switch(scan->status) - { - case B_ALLOCATED: - *used += scan->size; - break; - case B_FREE: - *total_free += scan->size; - if(scan->size > *max_free) - *max_free = scan->size; - break; - default: - critical_error("Invalid scan->status",(CELL)scan); - } - - scan = next_block(heap,scan); - } -} - -/* The size of the heap, not including the last block if it's free */ -CELL heap_size(F_HEAP *heap) -{ - F_BLOCK *scan = first_block(heap); - - while(next_block(heap,scan) != NULL) - scan = next_block(heap,scan); - - /* this is the last block in the heap, and it is free */ - if(scan->status == B_FREE) - return (CELL)scan - heap->segment->start; - /* otherwise the last block is allocated */ - else - return heap->segment->size; -} - -/* Compute where each block is going to go, after compaction */ -CELL compute_heap_forwarding(F_HEAP *heap) -{ - F_BLOCK *scan = first_block(heap); - CELL address = (CELL)first_block(heap); - - while(scan) - { - if(scan->status == B_ALLOCATED) - { - scan->forwarding = (F_BLOCK *)address; - address += scan->size; - } - else if(scan->status == B_MARKED) - critical_error("Why is the block marked?",0); - - scan = next_block(heap,scan); - } - - return address - heap->segment->start; -} - -void compact_heap(F_HEAP *heap) -{ - F_BLOCK *scan = first_block(heap); - - while(scan) - { - F_BLOCK *next = next_block(heap,scan); - - if(scan->status == B_ALLOCATED && scan != scan->forwarding) - memcpy(scan->forwarding,scan,scan->size); - scan = next; - } -} diff --git a/vmpp/code_gc.cpp b/vm/code_gc.cpp similarity index 100% rename from vmpp/code_gc.cpp rename to vm/code_gc.cpp diff --git a/vm/code_gc.h b/vm/code_gc.h deleted file mode 100755 index 35f8d66d90..0000000000 --- a/vm/code_gc.h +++ /dev/null @@ -1,45 +0,0 @@ -#define FREE_LIST_COUNT 16 -#define BLOCK_SIZE_INCREMENT 32 - -typedef struct { - F_FREE_BLOCK *small_blocks[FREE_LIST_COUNT]; - F_FREE_BLOCK *large_blocks; -} F_HEAP_FREE_LIST; - -typedef struct { - F_SEGMENT *segment; - F_HEAP_FREE_LIST free; -} F_HEAP; - -typedef void (*HEAP_ITERATOR)(F_BLOCK *compiled); - -void new_heap(F_HEAP *heap, CELL size); -void build_free_list(F_HEAP *heap, CELL size); -F_BLOCK *heap_allot(F_HEAP *heap, CELL size); -void heap_free(F_HEAP *heap, F_BLOCK *block); -void mark_block(F_BLOCK *block); -void unmark_marked(F_HEAP *heap); -void free_unmarked(F_HEAP *heap, HEAP_ITERATOR iter); -void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free); -CELL heap_size(F_HEAP *heap); -CELL compute_heap_forwarding(F_HEAP *heap); -void compact_heap(F_HEAP *heap); - -INLINE F_BLOCK *next_block(F_HEAP *heap, F_BLOCK *block) -{ - CELL next = ((CELL)block + block->size); - if(next == heap->segment->end) - return NULL; - else - return (F_BLOCK *)next; -} - -INLINE F_BLOCK *first_block(F_HEAP *heap) -{ - return (F_BLOCK *)heap->segment->start; -} - -INLINE F_BLOCK *last_block(F_HEAP *heap) -{ - return (F_BLOCK *)heap->segment->end; -} diff --git a/vmpp/code_gc.hpp b/vm/code_gc.hpp similarity index 100% rename from vmpp/code_gc.hpp rename to vm/code_gc.hpp diff --git a/vm/code_heap.c b/vm/code_heap.c deleted file mode 100755 index 0a174903b6..0000000000 --- a/vm/code_heap.c +++ /dev/null @@ -1,226 +0,0 @@ -#include "master.h" - -/* Allocate a code heap during startup */ -void init_code_heap(CELL size) -{ - new_heap(&code_heap,size); -} - -bool in_code_heap_p(CELL ptr) -{ - return (ptr >= code_heap.segment->start - && ptr <= code_heap.segment->end); -} - -/* Compile a word definition with the non-optimizing compiler. Allocates memory */ -void jit_compile_word(F_WORD *word, CELL def, bool relocate) -{ - REGISTER_ROOT(def); - REGISTER_UNTAGGED(word); - jit_compile(def,relocate); - UNREGISTER_UNTAGGED(word); - UNREGISTER_ROOT(def); - - word->code = untag_quotation(def)->code; - - if(word->direct_entry_def != F) - jit_compile(word->direct_entry_def,relocate); -} - -/* Apply a function to every code block */ -void iterate_code_heap(CODE_HEAP_ITERATOR iter) -{ - F_BLOCK *scan = first_block(&code_heap); - - while(scan) - { - if(scan->status != B_FREE) - iter((F_CODE_BLOCK *)scan); - scan = next_block(&code_heap,scan); - } -} - -/* Copy literals referenced from all code blocks to newspace. Only for -aging and nursery collections */ -void copy_code_heap_roots(void) -{ - iterate_code_heap(copy_literal_references); -} - -/* Update pointers to words referenced from all code blocks. Only after -defining a new word. */ -void update_code_heap_words(void) -{ - iterate_code_heap(update_word_references); -} - -void primitive_modify_code_heap(void) -{ - F_ARRAY *alist = untag_array(dpop()); - - CELL count = untag_fixnum_fast(alist->capacity); - if(count == 0) - return; - - CELL i; - for(i = 0; i < count; i++) - { - F_ARRAY *pair = untag_array(array_nth(alist,i)); - - F_WORD *word = untag_word(array_nth(pair,0)); - - CELL data = array_nth(pair,1); - - if(type_of(data) == QUOTATION_TYPE) - { - REGISTER_UNTAGGED(alist); - REGISTER_UNTAGGED(word); - jit_compile_word(word,data,false); - UNREGISTER_UNTAGGED(word); - UNREGISTER_UNTAGGED(alist); - } - else if(type_of(data) == ARRAY_TYPE) - { - F_ARRAY *compiled_code = untag_array(data); - - CELL literals = array_nth(compiled_code,0); - CELL relocation = array_nth(compiled_code,1); - F_ARRAY *labels = untag_array(array_nth(compiled_code,2)); - F_BYTE_ARRAY *code = untag_byte_array(array_nth(compiled_code,3)); - - REGISTER_UNTAGGED(alist); - REGISTER_UNTAGGED(word); - - F_CODE_BLOCK *compiled = add_code_block( - WORD_TYPE, - code, - labels, - relocation, - literals); - - UNREGISTER_UNTAGGED(word); - UNREGISTER_UNTAGGED(alist); - - word->code = compiled; - } - else - critical_error("Expected a quotation or an array",data); - - REGISTER_UNTAGGED(alist); - update_word_xt(word); - UNREGISTER_UNTAGGED(alist); - } - - update_code_heap_words(); -} - -/* Push the free space and total size of the code heap */ -void primitive_code_room(void) -{ - CELL used, total_free, max_free; - heap_usage(&code_heap,&used,&total_free,&max_free); - dpush(tag_fixnum((code_heap.segment->size) / 1024)); - dpush(tag_fixnum(used / 1024)); - dpush(tag_fixnum(total_free / 1024)); - dpush(tag_fixnum(max_free / 1024)); -} - -F_CODE_BLOCK *forward_xt(F_CODE_BLOCK *compiled) -{ - return (F_CODE_BLOCK *)compiled->block.forwarding; -} - -void forward_frame_xt(F_STACK_FRAME *frame) -{ - CELL offset = (CELL)FRAME_RETURN_ADDRESS(frame) - (CELL)frame_code(frame); - F_CODE_BLOCK *forwarded = forward_xt(frame_code(frame)); - frame->xt = (XT)(forwarded + 1); - FRAME_RETURN_ADDRESS(frame) = (XT)((CELL)forwarded + offset); -} - -void forward_object_xts(void) -{ - begin_scan(); - - CELL obj; - - while((obj = next_object()) != F) - { - if(type_of(obj) == WORD_TYPE) - { - F_WORD *word = untag_object(obj); - - word->code = forward_xt(word->code); - if(word->profiling) - word->profiling = forward_xt(word->profiling); - } - else if(type_of(obj) == QUOTATION_TYPE) - { - F_QUOTATION *quot = untag_object(obj); - - if(quot->compiledp != F) - quot->code = forward_xt(quot->code); - } - else if(type_of(obj) == CALLSTACK_TYPE) - { - F_CALLSTACK *stack = untag_object(obj); - iterate_callstack_object(stack,forward_frame_xt); - } - } - - /* End the heap scan */ - gc_off = false; -} - -/* Set the XT fields now that the heap has been compacted */ -void fixup_object_xts(void) -{ - begin_scan(); - - CELL obj; - - while((obj = next_object()) != F) - { - if(type_of(obj) == WORD_TYPE) - { - F_WORD *word = untag_object(obj); - update_word_xt(word); - } - else if(type_of(obj) == QUOTATION_TYPE) - { - F_QUOTATION *quot = untag_object(obj); - - if(quot->compiledp != F) - set_quot_xt(quot,quot->code); - } - } - - /* End the heap scan */ - gc_off = false; -} - -/* Move all free space to the end of the code heap. This is not very efficient, -since it makes several passes over the code and data heaps, but we only ever -do this before saving a deployed image and exiting, so performaance is not -critical here */ -void compact_code_heap(void) -{ - /* Free all unreachable code blocks */ - gc(); - - /* Figure out where the code heap blocks are going to end up */ - CELL size = compute_heap_forwarding(&code_heap); - - /* Update word and quotation code pointers */ - forward_object_xts(); - - /* Actually perform the compaction */ - compact_heap(&code_heap); - - /* Update word and quotation XTs */ - fixup_object_xts(); - - /* Now update the free list; there will be a single free block at - the end */ - build_free_list(&code_heap,size); -} diff --git a/vmpp/code_heap.cpp b/vm/code_heap.cpp similarity index 100% rename from vmpp/code_heap.cpp rename to vm/code_heap.cpp diff --git a/vm/code_heap.h b/vm/code_heap.h deleted file mode 100755 index 01d282acfa..0000000000 --- a/vm/code_heap.h +++ /dev/null @@ -1,27 +0,0 @@ -/* compiled code */ -F_HEAP code_heap; - -void init_code_heap(CELL size); - -bool in_code_heap_p(CELL ptr); - -void jit_compile_word(F_WORD *word, CELL def, bool relocate); - -typedef void (*CODE_HEAP_ITERATOR)(F_CODE_BLOCK *compiled); - -void iterate_code_heap(CODE_HEAP_ITERATOR iter); - -void copy_code_heap_roots(void); - -void primitive_modify_code_heap(void); - -void primitive_code_room(void); - -void compact_code_heap(void); - -INLINE void check_code_pointer(CELL pointer) -{ -#ifdef FACTOR_DEBUG - assert(pointer >= code_heap.segment->start && pointer < code_heap.segment->end); -#endif -} diff --git a/vmpp/code_heap.hpp b/vm/code_heap.hpp similarity index 100% rename from vmpp/code_heap.hpp rename to vm/code_heap.hpp diff --git a/vm/cpu-arm.h b/vm/cpu-arm.h deleted file mode 100755 index e6ea0a1158..0000000000 --- a/vm/cpu-arm.h +++ /dev/null @@ -1,13 +0,0 @@ -#define FACTOR_CPU_STRING "arm" - -register CELL ds asm("r5"); -register CELL rs asm("r6"); - -#define F_FASTCALL - -#define FRAME_RETURN_ADDRESS(frame) *(XT *)(frame_successor(frame) + 1) - -void c_to_factor(CELL quot); -void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy); -void throw_impl(CELL quot, F_STACK_FRAME *rewind); -void lazy_jit_compile(CELL quot); diff --git a/vmpp/cpu-arm.hpp b/vm/cpu-arm.hpp similarity index 100% rename from vmpp/cpu-arm.hpp rename to vm/cpu-arm.hpp diff --git a/vm/cpu-ppc.h b/vm/cpu-ppc.h deleted file mode 100755 index 298e21aa7d..0000000000 --- a/vm/cpu-ppc.h +++ /dev/null @@ -1,12 +0,0 @@ -#define FACTOR_CPU_STRING "ppc" -#define F_FASTCALL - -register CELL ds asm("r29"); -register CELL rs asm("r30"); - -void c_to_factor(CELL quot); -void undefined(CELL word); -void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy); -void throw_impl(CELL quot, F_STACK_FRAME *rewind); -void lazy_jit_compile(CELL quot); -void flush_icache(CELL start, CELL len); diff --git a/vmpp/cpu-ppc.hpp b/vm/cpu-ppc.hpp similarity index 100% rename from vmpp/cpu-ppc.hpp rename to vm/cpu-ppc.hpp diff --git a/vm/cpu-x86.32.h b/vm/cpu-x86.32.h deleted file mode 100755 index 21f07cf2b4..0000000000 --- a/vm/cpu-x86.32.h +++ /dev/null @@ -1,6 +0,0 @@ -#define FACTOR_CPU_STRING "x86.32" - -register CELL ds asm("esi"); -register CELL rs asm("edi"); - -#define F_FASTCALL __attribute__ ((regparm (2))) diff --git a/vmpp/cpu-x86.32.hpp b/vm/cpu-x86.32.hpp similarity index 100% rename from vmpp/cpu-x86.32.hpp rename to vm/cpu-x86.32.hpp diff --git a/vm/cpu-x86.64.h b/vm/cpu-x86.64.h deleted file mode 100644 index 6412355129..0000000000 --- a/vm/cpu-x86.64.h +++ /dev/null @@ -1,6 +0,0 @@ -#define FACTOR_CPU_STRING "x86.64" - -register CELL ds asm("r14"); -register CELL rs asm("r15"); - -#define F_FASTCALL diff --git a/vmpp/cpu-x86.64.hpp b/vm/cpu-x86.64.hpp similarity index 100% rename from vmpp/cpu-x86.64.hpp rename to vm/cpu-x86.64.hpp diff --git a/vm/cpu-x86.h b/vm/cpu-x86.h deleted file mode 100755 index 0888ec57fd..0000000000 --- a/vm/cpu-x86.h +++ /dev/null @@ -1,35 +0,0 @@ -#include - -#define FRAME_RETURN_ADDRESS(frame) *(XT *)(frame_successor(frame) + 1) - -INLINE void flush_icache(CELL start, CELL len) {} - -F_FASTCALL void c_to_factor(CELL quot); -F_FASTCALL void throw_impl(CELL quot, F_STACK_FRAME *rewind_to); -F_FASTCALL void lazy_jit_compile(CELL quot); - -void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy); - -INLINE void check_call_site(CELL return_address) -{ - /* An x86 CALL instruction looks like so: - |e8|..|..|..|..| - where the ... are a PC-relative jump address. - The return_address points to right after the - instruction. */ -#ifdef FACTOR_DEBUG - assert(*(unsigned char *)(return_address - 5) == 0xe8); -#endif -} - -INLINE CELL get_call_target(CELL return_address) -{ - check_call_site(return_address); - return *(int *)(return_address - 4) + return_address; -} - -INLINE void set_call_target(CELL return_address, CELL target) -{ - check_call_site(return_address); - *(int *)(return_address - 4) = (target - return_address); -} diff --git a/vmpp/cpu-x86.hpp b/vm/cpu-x86.hpp similarity index 100% rename from vmpp/cpu-x86.hpp rename to vm/cpu-x86.hpp diff --git a/vm/data_gc.c b/vm/data_gc.c deleted file mode 100755 index 1662fc9a4d..0000000000 --- a/vm/data_gc.c +++ /dev/null @@ -1,618 +0,0 @@ -#include "master.h" - -/* Scan all the objects in the card */ -void copy_card(F_CARD *ptr, CELL gen, CELL here) -{ - CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + CARD_OFFSET(ptr); - CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1); - - if(here < card_end) - card_end = here; - - copy_reachable_objects(card_scan,&card_end); - - cards_scanned++; -} - -void copy_card_deck(F_DECK *deck, CELL gen, F_CARD mask, F_CARD unmask) -{ - F_CARD *first_card = DECK_TO_CARD(deck); - F_CARD *last_card = DECK_TO_CARD(deck + 1); - - CELL here = data_heap->generations[gen].here; - - u32 *quad_ptr; - u32 quad_mask = mask | (mask << 8) | (mask << 16) | (mask << 24); - - for(quad_ptr = (u32 *)first_card; quad_ptr < (u32 *)last_card; quad_ptr++) - { - if(*quad_ptr & quad_mask) - { - F_CARD *ptr = (F_CARD *)quad_ptr; - - int card; - for(card = 0; card < 4; card++) - { - if(ptr[card] & mask) - { - copy_card(&ptr[card],gen,here); - ptr[card] &= ~unmask; - } - } - } - } - - decks_scanned++; -} - -/* Copy all newspace objects referenced from marked cards to the destination */ -void copy_gen_cards(CELL gen) -{ - F_DECK *first_deck = ADDR_TO_DECK(data_heap->generations[gen].start); - F_DECK *last_deck = ADDR_TO_DECK(data_heap->generations[gen].end); - - F_CARD mask, unmask; - - /* if we are collecting the nursery, we care about old->nursery pointers - but not old->aging pointers */ - if(collecting_gen == NURSERY) - { - mask = CARD_POINTS_TO_NURSERY; - - /* after the collection, no old->nursery pointers remain - anywhere, but old->aging pointers might remain in tenured - space */ - if(gen == TENURED) - unmask = CARD_POINTS_TO_NURSERY; - /* after the collection, all cards in aging space can be - cleared */ - else if(HAVE_AGING_P && gen == AGING) - unmask = CARD_MARK_MASK; - else - { - critical_error("bug in copy_gen_cards",gen); - return; - } - } - /* if we are collecting aging space into tenured space, we care about - all old->nursery and old->aging pointers. no old->aging pointers can - remain */ - else if(HAVE_AGING_P && collecting_gen == AGING) - { - if(collecting_aging_again) - { - mask = CARD_POINTS_TO_AGING; - unmask = CARD_MARK_MASK; - } - /* after we collect aging space into the aging semispace, no - old->nursery pointers remain but tenured space might still have - pointers to aging space. */ - else - { - mask = CARD_POINTS_TO_AGING; - unmask = CARD_POINTS_TO_NURSERY; - } - } - else - { - critical_error("bug in copy_gen_cards",gen); - return; - } - - F_DECK *ptr; - - for(ptr = first_deck; ptr < last_deck; ptr++) - { - if(*ptr & mask) - { - copy_card_deck(ptr,gen,mask,unmask); - *ptr &= ~unmask; - } - } -} - -/* Scan cards in all generations older than the one being collected, copying -old->new references */ -void copy_cards(void) -{ - u64 start = current_micros(); - - int i; - for(i = collecting_gen + 1; i < data_heap->gen_count; i++) - copy_gen_cards(i); - - card_scan_time += (current_micros() - start); -} - -/* Copy all tagged pointers in a range of memory */ -void copy_stack_elements(F_SEGMENT *region, CELL top) -{ - CELL ptr = region->start; - - for(; ptr <= top; ptr += CELLS) - copy_handle((CELL*)ptr); -} - -void copy_registered_locals(void) -{ - CELL ptr = gc_locals_region->start; - - for(; ptr <= gc_locals; ptr += CELLS) - copy_handle(*(CELL **)ptr); -} - -/* Copy roots over at the start of GC, namely various constants, stacks, -the user environment and extra roots registered with REGISTER_ROOT */ -void copy_roots(void) -{ - copy_handle(&T); - copy_handle(&bignum_zero); - copy_handle(&bignum_pos_one); - copy_handle(&bignum_neg_one); - - copy_registered_locals(); - copy_stack_elements(extra_roots_region,extra_roots); - - if(!performing_compaction) - { - save_stacks(); - F_CONTEXT *stacks = stack_chain; - - while(stacks) - { - copy_stack_elements(stacks->datastack_region,stacks->datastack); - copy_stack_elements(stacks->retainstack_region,stacks->retainstack); - - copy_handle(&stacks->catchstack_save); - copy_handle(&stacks->current_callback_save); - - mark_active_blocks(stacks); - - stacks = stacks->next; - } - } - - int i; - for(i = 0; i < USER_ENV; i++) - copy_handle(&userenv[i]); -} - -/* Given a pointer to oldspace, copy it to newspace */ -INLINE void *copy_untagged_object(void *pointer, CELL size) -{ - if(newspace->here + size >= newspace->end) - longjmp(gc_jmp,1); - allot_barrier(newspace->here); - void *newpointer = allot_zone(newspace,size); - - F_GC_STATS *s = &gc_stats[collecting_gen]; - s->object_count++; - s->bytes_copied += size; - - memcpy(newpointer,pointer,size); - return newpointer; -} - -INLINE void forward_object(CELL pointer, CELL newpointer) -{ - if(pointer != newpointer) - put(UNTAG(pointer),RETAG(newpointer,GC_COLLECTED)); -} - -INLINE CELL copy_object_impl(CELL pointer) -{ - CELL newpointer = (CELL)copy_untagged_object( - (void*)UNTAG(pointer), - object_size(pointer)); - forward_object(pointer,newpointer); - return newpointer; -} - -/* Follow a chain of forwarding pointers */ -CELL resolve_forwarding(CELL untagged, CELL tag) -{ - check_data_pointer(untagged); - - CELL header = get(untagged); - /* another forwarding pointer */ - if(TAG(header) == GC_COLLECTED) - return resolve_forwarding(UNTAG(header),tag); - /* we've found the destination */ - else - { - check_header(header); - CELL pointer = RETAG(untagged,tag); - if(should_copy(untagged)) - pointer = RETAG(copy_object_impl(pointer),tag); - return pointer; - } -} - -/* Given a pointer to a tagged pointer to oldspace, copy it to newspace. -If the object has already been copied, return the forwarding -pointer address without copying anything; otherwise, install -a new forwarding pointer. */ -INLINE CELL copy_object(CELL pointer) -{ - check_data_pointer(pointer); - - CELL tag = TAG(pointer); - CELL header = get(UNTAG(pointer)); - - if(TAG(header) == GC_COLLECTED) - return resolve_forwarding(UNTAG(header),tag); - else - { - check_header(header); - return RETAG(copy_object_impl(pointer),tag); - } -} - -void copy_handle(CELL *handle) -{ - CELL pointer = *handle; - - if(!immediate_p(pointer)) - { - check_data_pointer(pointer); - if(should_copy(pointer)) - *handle = copy_object(pointer); - } -} - -CELL copy_next_from_nursery(CELL scan) -{ - CELL *obj = (CELL *)scan; - CELL *end = (CELL *)(scan + binary_payload_start(scan)); - - if(obj != end) - { - obj++; - - CELL nursery_start = nursery.start; - CELL nursery_end = nursery.end; - - for(; obj < end; obj++) - { - CELL pointer = *obj; - - if(!immediate_p(pointer)) - { - check_data_pointer(pointer); - if(pointer >= nursery_start && pointer < nursery_end) - *obj = copy_object(pointer); - } - } - } - - return scan + untagged_object_size(scan); -} - -CELL copy_next_from_aging(CELL scan) -{ - CELL *obj = (CELL *)scan; - CELL *end = (CELL *)(scan + binary_payload_start(scan)); - - if(obj != end) - { - obj++; - - CELL tenured_start = data_heap->generations[TENURED].start; - CELL tenured_end = data_heap->generations[TENURED].end; - - CELL newspace_start = newspace->start; - CELL newspace_end = newspace->end; - - for(; obj < end; obj++) - { - CELL pointer = *obj; - - if(!immediate_p(pointer)) - { - check_data_pointer(pointer); - if(!(pointer >= newspace_start && pointer < newspace_end) - && !(pointer >= tenured_start && pointer < tenured_end)) - *obj = copy_object(pointer); - } - } - } - - return scan + untagged_object_size(scan); -} - -CELL copy_next_from_tenured(CELL scan) -{ - CELL *obj = (CELL *)scan; - CELL *end = (CELL *)(scan + binary_payload_start(scan)); - - if(obj != end) - { - obj++; - - CELL newspace_start = newspace->start; - CELL newspace_end = newspace->end; - - for(; obj < end; obj++) - { - CELL pointer = *obj; - - if(!immediate_p(pointer)) - { - check_data_pointer(pointer); - if(!(pointer >= newspace_start && pointer < newspace_end)) - *obj = copy_object(pointer); - } - } - } - - mark_object_code_block(scan); - - return scan + untagged_object_size(scan); -} - -void copy_reachable_objects(CELL scan, CELL *end) -{ - if(collecting_gen == NURSERY) - { - while(scan < *end) - scan = copy_next_from_nursery(scan); - } - else if(HAVE_AGING_P && collecting_gen == AGING) - { - while(scan < *end) - scan = copy_next_from_aging(scan); - } - else if(collecting_gen == TENURED) - { - while(scan < *end) - scan = copy_next_from_tenured(scan); - } -} - -/* Prepare to start copying reachable objects into an unused zone */ -void begin_gc(CELL requested_bytes) -{ - if(growing_data_heap) - { - if(collecting_gen != TENURED) - critical_error("Invalid parameters to begin_gc",0); - - old_data_heap = data_heap; - set_data_heap(grow_data_heap(old_data_heap,requested_bytes)); - newspace = &data_heap->generations[TENURED]; - } - else if(collecting_accumulation_gen_p()) - { - /* when collecting one of these generations, rotate it - with the semispace */ - F_ZONE z = data_heap->generations[collecting_gen]; - data_heap->generations[collecting_gen] = data_heap->semispaces[collecting_gen]; - data_heap->semispaces[collecting_gen] = z; - reset_generation(collecting_gen); - newspace = &data_heap->generations[collecting_gen]; - clear_cards(collecting_gen,collecting_gen); - clear_decks(collecting_gen,collecting_gen); - clear_allot_markers(collecting_gen,collecting_gen); - } - else - { - /* when collecting a younger generation, we copy - reachable objects to the next oldest generation, - so we set the newspace so the next generation. */ - newspace = &data_heap->generations[collecting_gen + 1]; - } -} - -void end_gc(CELL gc_elapsed) -{ - F_GC_STATS *s = &gc_stats[collecting_gen]; - - s->collections++; - s->gc_time += gc_elapsed; - if(s->max_gc_time < gc_elapsed) - s->max_gc_time = gc_elapsed; - - if(growing_data_heap) - { - dealloc_data_heap(old_data_heap); - old_data_heap = NULL; - growing_data_heap = false; - } - - if(collecting_accumulation_gen_p()) - { - /* all younger generations except are now empty. - if collecting_gen == NURSERY here, we only have 1 generation; - old-school Cheney collector */ - if(collecting_gen != NURSERY) - reset_generations(NURSERY,collecting_gen - 1); - } - else if(collecting_gen == NURSERY) - { - nursery.here = nursery.start; - } - else - { - /* all generations up to and including the one - collected are now empty */ - reset_generations(NURSERY,collecting_gen); - } - - collecting_aging_again = false; -} - -/* Collect gen and all younger generations. -If growing_data_heap_ is true, we must grow the data heap to such a size that -an allocation of requested_bytes won't fail */ -void garbage_collection(CELL gen, - bool growing_data_heap_, - CELL requested_bytes) -{ - if(gc_off) - { - critical_error("GC disabled",gen); - return; - } - - u64 start = current_micros(); - - performing_gc = true; - growing_data_heap = growing_data_heap_; - collecting_gen = gen; - - /* we come back here if a generation is full */ - if(setjmp(gc_jmp)) - { - /* We have no older generations we can try collecting, so we - resort to growing the data heap */ - if(collecting_gen == TENURED) - { - growing_data_heap = true; - - /* see the comment in unmark_marked() */ - unmark_marked(&code_heap); - } - /* we try collecting AGING space twice before going on to - collect TENURED */ - else if(HAVE_AGING_P - && collecting_gen == AGING - && !collecting_aging_again) - { - collecting_aging_again = true; - } - /* Collect the next oldest generation */ - else - { - collecting_gen++; - } - } - - begin_gc(requested_bytes); - - /* initialize chase pointer */ - CELL scan = newspace->here; - - /* collect objects referenced from stacks and environment */ - copy_roots(); - /* collect objects referenced from older generations */ - copy_cards(); - - /* do some tracing */ - copy_reachable_objects(scan,&newspace->here); - - /* don't scan code heap unless it has pointers to this - generation or younger */ - if(collecting_gen >= last_code_heap_scan) - { - code_heap_scans++; - - if(collecting_gen == TENURED) - free_unmarked(&code_heap,(HEAP_ITERATOR)update_literal_and_word_references); - else - copy_code_heap_roots(); - - if(collecting_accumulation_gen_p()) - last_code_heap_scan = collecting_gen; - else - last_code_heap_scan = collecting_gen + 1; - } - - CELL gc_elapsed = (current_micros() - start); - - end_gc(gc_elapsed); - - performing_gc = false; -} - -void gc(void) -{ - garbage_collection(TENURED,false,0); -} - -void minor_gc(void) -{ - garbage_collection(NURSERY,false,0); -} - -void primitive_gc(void) -{ - gc(); -} - -void primitive_gc_stats(void) -{ - GROWABLE_ARRAY(stats); - - CELL i; - u64 total_gc_time = 0; - - for(i = 0; i < MAX_GEN_COUNT; i++) - { - F_GC_STATS *s = &gc_stats[i]; - GROWABLE_ARRAY_ADD(stats,allot_cell(s->collections)); - GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(s->gc_time))); - GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(s->max_gc_time))); - GROWABLE_ARRAY_ADD(stats,allot_cell(s->collections == 0 ? 0 : s->gc_time / s->collections)); - GROWABLE_ARRAY_ADD(stats,allot_cell(s->object_count)); - GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(s->bytes_copied))); - - total_gc_time += s->gc_time; - } - - GROWABLE_ARRAY_ADD(stats,tag_bignum(ulong_long_to_bignum(total_gc_time))); - GROWABLE_ARRAY_ADD(stats,tag_bignum(ulong_long_to_bignum(cards_scanned))); - GROWABLE_ARRAY_ADD(stats,tag_bignum(ulong_long_to_bignum(decks_scanned))); - GROWABLE_ARRAY_ADD(stats,tag_bignum(ulong_long_to_bignum(card_scan_time))); - GROWABLE_ARRAY_ADD(stats,allot_cell(code_heap_scans)); - - GROWABLE_ARRAY_TRIM(stats); - GROWABLE_ARRAY_DONE(stats); - dpush(stats); -} - -void clear_gc_stats(void) -{ - int i; - for(i = 0; i < MAX_GEN_COUNT; i++) - memset(&gc_stats[i],0,sizeof(F_GC_STATS)); - - cards_scanned = 0; - decks_scanned = 0; - card_scan_time = 0; - code_heap_scans = 0; -} - -void primitive_clear_gc_stats(void) -{ - clear_gc_stats(); -} - -/* classes.tuple uses this to reshape tuples; tools.deploy.shaker uses this - to coalesce equal but distinct quotations and wrappers. */ -void primitive_become(void) -{ - F_ARRAY *new_objects = untag_array(dpop()); - F_ARRAY *old_objects = untag_array(dpop()); - - CELL capacity = array_capacity(new_objects); - if(capacity != array_capacity(old_objects)) - critical_error("bad parameters to become",0); - - CELL i; - - for(i = 0; i < capacity; i++) - { - CELL old_obj = array_nth(old_objects,i); - CELL new_obj = array_nth(new_objects,i); - - forward_object(old_obj,new_obj); - } - - gc(); - - /* If a word's definition quotation was in old_objects and the - quotation in new_objects is not compiled, we might leak memory - by referencing the old quotation unless we recompile all - unoptimized words. */ - compile_all_words(); -} diff --git a/vmpp/data_gc.cpp b/vm/data_gc.cpp similarity index 100% rename from vmpp/data_gc.cpp rename to vm/data_gc.cpp diff --git a/vm/data_gc.h b/vm/data_gc.h old mode 100755 new mode 100644 index 50f87ce0be..1def24ae73 --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -78,25 +78,18 @@ allocation (which does not call GC because of possible roots in volatile registers) does not run out of memory */ #define ALLOT_BUFFER_ZONE 1024 -/* If this is defined, we GC every 100 allocations. This catches missing local roots */ -#ifdef GC_DEBUG -int gc_count; -#endif +/* If this is defined, we GC every allocation. This catches missing local roots */ /* * It is up to the caller to fill in the object's fields in a meaningful * fashion! */ -int count; + INLINE void *allot_object(CELL type, CELL a) { #ifdef GC_DEBUG if(!gc_off) - { - if(gc_count++ % 100 == 0) - gc(); - - } + gc(); #endif CELL *object; @@ -109,7 +102,7 @@ INLINE void *allot_object(CELL type, CELL a) CELL h = nursery.here; nursery.here = h + align8(a); - object = (void*)h; + object = (CELL*)h; } /* If the object is bigger than the nursery, allocate it in tenured space */ @@ -131,7 +124,7 @@ INLINE void *allot_object(CELL type, CELL a) tenured = &data_heap->generations[TENURED]; } - object = allot_zone(tenured,a); + object = (CELL *)allot_zone(tenured,a); /* We have to do this */ allot_barrier((CELL)object); diff --git a/vmpp/data_gc.hpp b/vm/data_gc.hpp similarity index 100% rename from vmpp/data_gc.hpp rename to vm/data_gc.hpp diff --git a/vm/data_heap.c b/vm/data_heap.c deleted file mode 100644 index cab9114089..0000000000 --- a/vm/data_heap.c +++ /dev/null @@ -1,366 +0,0 @@ -#include "master.h" - -CELL init_zone(F_ZONE *z, CELL size, CELL start) -{ - z->size = size; - z->start = z->here = start; - z->end = start + size; - return z->end; -} - -void init_card_decks(void) -{ - CELL start = align(data_heap->segment->start,DECK_SIZE); - allot_markers_offset = (CELL)data_heap->allot_markers - (start >> CARD_BITS); - cards_offset = (CELL)data_heap->cards - (start >> CARD_BITS); - decks_offset = (CELL)data_heap->decks - (start >> DECK_BITS); -} - -F_DATA_HEAP *alloc_data_heap(CELL gens, - CELL young_size, - CELL aging_size, - CELL tenured_size) -{ - young_size = align(young_size,DECK_SIZE); - aging_size = align(aging_size,DECK_SIZE); - tenured_size = align(tenured_size,DECK_SIZE); - - F_DATA_HEAP *data_heap = safe_malloc(sizeof(F_DATA_HEAP)); - data_heap->young_size = young_size; - data_heap->aging_size = aging_size; - data_heap->tenured_size = tenured_size; - data_heap->gen_count = gens; - - CELL total_size; - if(data_heap->gen_count == 2) - total_size = young_size + 2 * tenured_size; - else if(data_heap->gen_count == 3) - total_size = young_size + 2 * aging_size + 2 * tenured_size; - else - { - fatal_error("Invalid number of generations",data_heap->gen_count); - return NULL; /* can't happen */ - } - - total_size += DECK_SIZE; - - data_heap->segment = alloc_segment(total_size); - - data_heap->generations = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count); - data_heap->semispaces = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count); - - CELL cards_size = total_size >> CARD_BITS; - data_heap->allot_markers = safe_malloc(cards_size); - data_heap->allot_markers_end = data_heap->allot_markers + cards_size; - - data_heap->cards = safe_malloc(cards_size); - data_heap->cards_end = data_heap->cards + cards_size; - - CELL decks_size = total_size >> DECK_BITS; - data_heap->decks = safe_malloc(decks_size); - data_heap->decks_end = data_heap->decks + decks_size; - - CELL alloter = align(data_heap->segment->start,DECK_SIZE); - - alloter = init_zone(&data_heap->generations[TENURED],tenured_size,alloter); - alloter = init_zone(&data_heap->semispaces[TENURED],tenured_size,alloter); - - if(data_heap->gen_count == 3) - { - alloter = init_zone(&data_heap->generations[AGING],aging_size,alloter); - alloter = init_zone(&data_heap->semispaces[AGING],aging_size,alloter); - } - - if(data_heap->gen_count >= 2) - { - alloter = init_zone(&data_heap->generations[NURSERY],young_size,alloter); - alloter = init_zone(&data_heap->semispaces[NURSERY],0,alloter); - } - - if(data_heap->segment->end - alloter > DECK_SIZE) - critical_error("Bug in alloc_data_heap",alloter); - - return data_heap; -} - -F_DATA_HEAP *grow_data_heap(F_DATA_HEAP *data_heap, CELL requested_bytes) -{ - CELL new_tenured_size = (data_heap->tenured_size * 2) + requested_bytes; - - return alloc_data_heap(data_heap->gen_count, - data_heap->young_size, - data_heap->aging_size, - new_tenured_size); -} - -void dealloc_data_heap(F_DATA_HEAP *data_heap) -{ - dealloc_segment(data_heap->segment); - free(data_heap->generations); - free(data_heap->semispaces); - free(data_heap->allot_markers); - free(data_heap->cards); - free(data_heap->decks); - free(data_heap); -} - -void clear_cards(CELL from, CELL to) -{ - /* NOTE: reverse order due to heap layout. */ - F_CARD *first_card = ADDR_TO_CARD(data_heap->generations[to].start); - F_CARD *last_card = ADDR_TO_CARD(data_heap->generations[from].end); - memset(first_card,0,last_card - first_card); -} - -void clear_decks(CELL from, CELL to) -{ - /* NOTE: reverse order due to heap layout. */ - F_DECK *first_deck = ADDR_TO_DECK(data_heap->generations[to].start); - F_DECK *last_deck = ADDR_TO_DECK(data_heap->generations[from].end); - memset(first_deck,0,last_deck - first_deck); -} - -void clear_allot_markers(CELL from, CELL to) -{ - /* NOTE: reverse order due to heap layout. */ - F_CARD *first_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[to].start); - F_CARD *last_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[from].end); - memset(first_card,INVALID_ALLOT_MARKER,last_card - first_card); -} - -void reset_generation(CELL i) -{ - F_ZONE *z = (i == NURSERY ? &nursery : &data_heap->generations[i]); - - z->here = z->start; - if(secure_gc) - memset((void*)z->start,69,z->size); -} - -/* After garbage collection, any generations which are now empty need to have -their allocation pointers and cards reset. */ -void reset_generations(CELL from, CELL to) -{ - CELL i; - for(i = from; i <= to; i++) - reset_generation(i); - - clear_cards(from,to); - clear_decks(from,to); - clear_allot_markers(from,to); -} - -void set_data_heap(F_DATA_HEAP *data_heap_) -{ - data_heap = data_heap_; - nursery = data_heap->generations[NURSERY]; - init_card_decks(); - clear_cards(NURSERY,TENURED); - clear_decks(NURSERY,TENURED); - clear_allot_markers(NURSERY,TENURED); -} - -void init_data_heap(CELL gens, - CELL young_size, - CELL aging_size, - CELL tenured_size, - bool secure_gc_) -{ - set_data_heap(alloc_data_heap(gens,young_size,aging_size,tenured_size)); - - gc_locals_region = alloc_segment(getpagesize()); - gc_locals = gc_locals_region->start - CELLS; - - extra_roots_region = alloc_segment(getpagesize()); - extra_roots = extra_roots_region->start - CELLS; - - secure_gc = secure_gc_; -} - -/* Size of the object pointed to by a tagged pointer */ -CELL object_size(CELL tagged) -{ - if(immediate_p(tagged)) - return 0; - else - return untagged_object_size(UNTAG(tagged)); -} - -/* Size of the object pointed to by an untagged pointer */ -CELL untagged_object_size(CELL pointer) -{ - return align8(unaligned_object_size(pointer)); -} - -/* Size of the data area of an object pointed to by an untagged pointer */ -CELL unaligned_object_size(CELL pointer) -{ - F_TUPLE *tuple; - F_TUPLE_LAYOUT *layout; - - switch(untag_header(get(pointer))) - { - case ARRAY_TYPE: - case BIGNUM_TYPE: - return array_size(array_capacity((F_ARRAY*)pointer)); - case BYTE_ARRAY_TYPE: - return byte_array_size( - byte_array_capacity((F_BYTE_ARRAY*)pointer)); - case STRING_TYPE: - return string_size(string_capacity((F_STRING*)pointer)); - case TUPLE_TYPE: - tuple = untag_object(pointer); - layout = untag_object(tuple->layout); - return tuple_size(layout); - case QUOTATION_TYPE: - return sizeof(F_QUOTATION); - case WORD_TYPE: - return sizeof(F_WORD); - case FLOAT_TYPE: - return sizeof(F_FLOAT); - case DLL_TYPE: - return sizeof(F_DLL); - case ALIEN_TYPE: - return sizeof(F_ALIEN); - case WRAPPER_TYPE: - return sizeof(F_WRAPPER); - case CALLSTACK_TYPE: - return callstack_size( - untag_fixnum_fast(((F_CALLSTACK *)pointer)->length)); - default: - critical_error("Invalid header",pointer); - return -1; /* can't happen */ - } -} - -void primitive_size(void) -{ - box_unsigned_cell(object_size(dpop())); -} - -/* The number of cells from the start of the object which should be scanned by -the GC. Some types have a binary payload at the end (string, word, DLL) which -we ignore. */ -CELL binary_payload_start(CELL pointer) -{ - F_TUPLE *tuple; - F_TUPLE_LAYOUT *layout; - - switch(untag_header(get(pointer))) - { - /* these objects do not refer to other objects at all */ - case FLOAT_TYPE: - case BYTE_ARRAY_TYPE: - case BIGNUM_TYPE: - case CALLSTACK_TYPE: - return 0; - /* these objects have some binary data at the end */ - case WORD_TYPE: - return sizeof(F_WORD) - CELLS * 3; - case ALIEN_TYPE: - return CELLS * 3; - case DLL_TYPE: - return CELLS * 2; - case QUOTATION_TYPE: - return sizeof(F_QUOTATION) - CELLS * 2; - case STRING_TYPE: - return sizeof(F_STRING); - /* everything else consists entirely of pointers */ - case ARRAY_TYPE: - return array_size(array_capacity((F_ARRAY*)pointer)); - case TUPLE_TYPE: - tuple = untag_object(pointer); - layout = untag_object(tuple->layout); - return tuple_size(layout); - case WRAPPER_TYPE: - return sizeof(F_WRAPPER); - default: - critical_error("Invalid header",pointer); - return -1; /* can't happen */ - } -} - -/* Push memory usage statistics in data heap */ -void primitive_data_room(void) -{ - dpush(tag_fixnum((data_heap->cards_end - data_heap->cards) >> 10)); - dpush(tag_fixnum((data_heap->decks_end - data_heap->decks) >> 10)); - - GROWABLE_ARRAY(a); - - int gen; - for(gen = 0; gen < data_heap->gen_count; gen++) - { - F_ZONE *z = (gen == NURSERY ? &nursery : &data_heap->generations[gen]); - GROWABLE_ARRAY_ADD(a,tag_fixnum((z->end - z->here) >> 10)); - GROWABLE_ARRAY_ADD(a,tag_fixnum((z->size) >> 10)); - } - - GROWABLE_ARRAY_TRIM(a); - GROWABLE_ARRAY_DONE(a); - dpush(a); -} - -/* Disables GC and activates next-object ( -- obj ) primitive */ -void begin_scan(void) -{ - heap_scan_ptr = data_heap->generations[TENURED].start; - gc_off = true; -} - -void primitive_begin_scan(void) -{ - begin_scan(); -} - -CELL next_object(void) -{ - if(!gc_off) - general_error(ERROR_HEAP_SCAN,F,F,NULL); - - CELL value = get(heap_scan_ptr); - CELL obj = heap_scan_ptr; - CELL type; - - if(heap_scan_ptr >= data_heap->generations[TENURED].here) - return F; - - type = untag_header(value); - heap_scan_ptr += untagged_object_size(heap_scan_ptr); - - return RETAG(obj,type < HEADER_TYPE ? type : OBJECT_TYPE); -} - -/* Push object at heap scan cursor and advance; pushes f when done */ -void primitive_next_object(void) -{ - dpush(next_object()); -} - -/* Re-enables GC */ -void primitive_end_scan(void) -{ - gc_off = false; -} - -CELL find_all_words(void) -{ - GROWABLE_ARRAY(words); - - begin_scan(); - - CELL obj; - while((obj = next_object()) != F) - { - if(type_of(obj) == WORD_TYPE) - GROWABLE_ARRAY_ADD(words,obj); - } - - /* End heap scan */ - gc_off = false; - - GROWABLE_ARRAY_TRIM(words); - GROWABLE_ARRAY_DONE(words); - - return words; -} diff --git a/vmpp/data_heap.cpp b/vm/data_heap.cpp similarity index 100% rename from vmpp/data_heap.cpp rename to vm/data_heap.cpp diff --git a/vm/data_heap.h b/vm/data_heap.h deleted file mode 100644 index 4a86367208..0000000000 --- a/vm/data_heap.h +++ /dev/null @@ -1,138 +0,0 @@ -/* Set by the -securegc command line argument */ -bool secure_gc; - -/* generational copying GC divides memory into zones */ -typedef struct { - /* allocation pointer is 'here'; its offset is hardcoded in the - compiler backends*/ - CELL start; - CELL here; - CELL size; - CELL end; -} F_ZONE; - -typedef struct { - F_SEGMENT *segment; - - CELL young_size; - CELL aging_size; - CELL tenured_size; - - CELL gen_count; - - F_ZONE *generations; - F_ZONE* semispaces; - - CELL *allot_markers; - CELL *allot_markers_end; - - CELL *cards; - CELL *cards_end; - - CELL *decks; - CELL *decks_end; -} F_DATA_HEAP; - -F_DATA_HEAP *data_heap; - -/* the 0th generation is where new objects are allocated. */ -#define NURSERY 0 -/* where objects hang around */ -#define AGING (data_heap->gen_count-2) -#define HAVE_AGING_P (data_heap->gen_count>2) -/* the oldest generation */ -#define TENURED (data_heap->gen_count-1) - -#define MIN_GEN_COUNT 1 -#define MAX_GEN_COUNT 3 - -/* new objects are allocated here */ -DLLEXPORT F_ZONE nursery; - -INLINE bool in_zone(F_ZONE *z, CELL pointer) -{ - return pointer >= z->start && pointer < z->end; -} - -CELL init_zone(F_ZONE *z, CELL size, CELL base); - -void init_card_decks(void); - -F_DATA_HEAP *grow_data_heap(F_DATA_HEAP *data_heap, CELL requested_bytes); - -void dealloc_data_heap(F_DATA_HEAP *data_heap); - -void clear_cards(CELL from, CELL to); -void clear_decks(CELL from, CELL to); -void clear_allot_markers(CELL from, CELL to); -void reset_generation(CELL i); -void reset_generations(CELL from, CELL to); - -void set_data_heap(F_DATA_HEAP *data_heap_); - -void init_data_heap(CELL gens, - CELL young_size, - CELL aging_size, - CELL tenured_size, - bool secure_gc_); - -/* set up guard pages to check for under/overflow. -size must be a multiple of the page size */ -F_SEGMENT *alloc_segment(CELL size); -void dealloc_segment(F_SEGMENT *block); - -CELL untagged_object_size(CELL pointer); -CELL unaligned_object_size(CELL pointer); -CELL object_size(CELL pointer); -CELL binary_payload_start(CELL pointer); - -void begin_scan(void); -CELL next_object(void); - -void primitive_data_room(void); -void primitive_size(void); - -void primitive_begin_scan(void); -void primitive_next_object(void); -void primitive_end_scan(void); - -/* A heap walk allows useful things to be done, like finding all -references to an object for debugging purposes. */ -CELL heap_scan_ptr; - -/* GC is off during heap walking */ -bool gc_off; - -INLINE bool in_data_heap_p(CELL ptr) -{ - return (ptr >= data_heap->segment->start - && ptr <= data_heap->segment->end); -} - -INLINE void *allot_zone(F_ZONE *z, CELL a) -{ - CELL h = z->here; - z->here = h + align8(a); - return (void*)h; -} - -CELL find_all_words(void); - -/* Every object has a regular representation in the runtime, which makes GC -much simpler. Every slot of the object until binary_payload_start is a pointer -to some other object. */ -INLINE void do_slots(CELL obj, void (* iter)(CELL *)) -{ - CELL scan = obj; - CELL payload_start = binary_payload_start(obj); - CELL end = obj + payload_start; - - scan += CELLS; - - while(scan < end) - { - iter((CELL *)scan); - scan += CELLS; - } -} - diff --git a/vmpp/data_heap.hpp b/vm/data_heap.hpp similarity index 100% rename from vmpp/data_heap.hpp rename to vm/data_heap.hpp diff --git a/vm/debug.c b/vm/debug.c deleted file mode 100755 index a9afd2c3c0..0000000000 --- a/vm/debug.c +++ /dev/null @@ -1,501 +0,0 @@ -#include "master.h" - -static bool full_output; - -void print_chars(F_STRING* str) -{ - CELL i; - for(i = 0; i < string_capacity(str); i++) - putchar(string_nth(str,i)); -} - -void print_word(F_WORD* word, CELL nesting) -{ - - if(type_of(word->vocabulary) == STRING_TYPE) - { - print_chars(untag_string(word->vocabulary)); - print_string(":"); - } - - if(type_of(word->name) == STRING_TYPE) - print_chars(untag_string(word->name)); - else - { - print_string("#name,nesting); - print_string(">"); - } -} - -void print_factor_string(F_STRING* str) -{ - putchar('"'); - print_chars(str); - putchar('"'); -} - -void print_array(F_ARRAY* array, CELL nesting) -{ - CELL length = array_capacity(array); - CELL i; - bool trimmed; - - if(length > 10 && !full_output) - { - trimmed = true; - length = 10; - } - else - trimmed = false; - - for(i = 0; i < length; i++) - { - print_string(" "); - print_nested_obj(array_nth(array,i),nesting); - } - - if(trimmed) - print_string("..."); -} - -void print_tuple(F_TUPLE* tuple, CELL nesting) -{ - F_TUPLE_LAYOUT *layout = untag_object(tuple->layout); - CELL length = to_fixnum(layout->size); - - print_string(" "); - print_nested_obj(layout->class,nesting); - - CELL i; - bool trimmed; - - if(length > 10 && !full_output) - { - trimmed = true; - length = 10; - } - else - trimmed = false; - - for(i = 0; i < length; i++) - { - print_string(" "); - print_nested_obj(tuple_nth(tuple,i),nesting); - } - - if(trimmed) - print_string("..."); -} - -void print_nested_obj(CELL obj, F_FIXNUM nesting) -{ - if(nesting <= 0 && !full_output) - { - print_string(" ... "); - return; - } - - F_QUOTATION *quot; - - switch(type_of(obj)) - { - case FIXNUM_TYPE: - print_fixnum(untag_fixnum_fast(obj)); - break; - case WORD_TYPE: - print_word(untag_word(obj),nesting - 1); - break; - case STRING_TYPE: - print_factor_string(untag_string(obj)); - break; - case F_TYPE: - print_string("f"); - break; - case TUPLE_TYPE: - print_string("T{"); - print_tuple(untag_object(obj),nesting - 1); - print_string(" }"); - break; - case ARRAY_TYPE: - print_string("{"); - print_array(untag_object(obj),nesting - 1); - print_string(" }"); - break; - case QUOTATION_TYPE: - print_string("["); - quot = untag_object(obj); - print_array(untag_object(quot->array),nesting - 1); - print_string(" ]"); - break; - default: - print_string("#"); - break; - } -} - -void print_obj(CELL obj) -{ - print_nested_obj(obj,10); -} - -void print_objects(CELL start, CELL end) -{ - for(; start <= end; start += CELLS) - { - print_obj(get(start)); - nl(); - } -} - -void print_datastack(void) -{ - print_string("==== DATA STACK:\n"); - print_objects(ds_bot,ds); -} - -void print_retainstack(void) -{ - print_string("==== RETAIN STACK:\n"); - print_objects(rs_bot,rs); -} - -void print_stack_frame(F_STACK_FRAME *frame) -{ - print_obj(frame_executing(frame)); - print_string("\n"); - print_obj(frame_scan(frame)); - print_string("\n"); - print_cell_hex((CELL)frame_executing(frame)); - print_string(" "); - print_cell_hex((CELL)frame->xt); - print_string("\n"); -} - -void print_callstack(void) -{ - print_string("==== CALL STACK:\n"); - CELL bottom = (CELL)stack_chain->callstack_bottom; - CELL top = (CELL)stack_chain->callstack_top; - iterate_callstack(top,bottom,print_stack_frame); -} - -void dump_cell(CELL cell) -{ - print_cell_hex_pad(cell); print_string(": "); - - cell = get(cell); - - print_cell_hex_pad(cell); print_string(" tag "); print_cell(TAG(cell)); - - switch(TAG(cell)) - { - case OBJECT_TYPE: - case BIGNUM_TYPE: - case FLOAT_TYPE: - if(cell == F) - print_string(" -- F"); - else if(cell < TYPE_COUNT<>TAG_BITS); - } - else if(cell >= data_heap->segment->start - && cell < data_heap->segment->end) - { - CELL header = get(UNTAG(cell)); - CELL type = header>>TAG_BITS; - print_string(" -- object; "); - if(TAG(header) == 0 && type < TYPE_COUNT) - { - print_string(" type "); print_cell(type); - } - else - print_string(" header corrupt"); - } - break; - } - - nl(); -} - -void dump_memory(CELL from, CELL to) -{ - from = UNTAG(from); - - for(; from <= to; from += CELLS) - dump_cell(from); -} - -void dump_zone(F_ZONE *z) -{ - print_string("Start="); print_cell(z->start); - print_string(", size="); print_cell(z->size); - print_string(", here="); print_cell(z->here - z->start); nl(); -} - -void dump_generations(void) -{ - CELL i; - - print_string("Nursery: "); - dump_zone(&nursery); - - for(i = 1; i < data_heap->gen_count; i++) - { - print_string("Generation "); print_cell(i); print_string(": "); - dump_zone(&data_heap->generations[i]); - } - - for(i = 0; i < data_heap->gen_count; i++) - { - print_string("Semispace "); print_cell(i); print_string(": "); - dump_zone(&data_heap->semispaces[i]); - } - - print_string("Cards: base="); - print_cell((CELL)data_heap->cards); - print_string(", size="); - print_cell((CELL)(data_heap->cards_end - data_heap->cards)); - nl(); -} - -void dump_objects(F_FIXNUM type) -{ - gc(); - begin_scan(); - - CELL obj; - while((obj = next_object()) != F) - { - if(type == -1 || type_of(obj) == type) - { - print_cell_hex_pad(obj); - print_string(" "); - print_nested_obj(obj,2); - nl(); - } - } - - /* end scan */ - gc_off = false; -} - -CELL look_for; -CELL obj; - -void find_data_references_step(CELL *scan) -{ - if(look_for == *scan) - { - print_cell_hex_pad(obj); - print_string(" "); - print_nested_obj(obj,2); - nl(); - } -} - -void find_data_references(CELL look_for_) -{ - look_for = look_for_; - - begin_scan(); - - while((obj = next_object()) != F) - do_slots(UNTAG(obj),find_data_references_step); - - /* end scan */ - gc_off = false; -} - -/* Dump all code blocks for debugging */ -void dump_code_heap(void) -{ - CELL reloc_size = 0, literal_size = 0; - - F_BLOCK *scan = first_block(&code_heap); - - while(scan) - { - char *status; - switch(scan->status) - { - case B_FREE: - status = "free"; - break; - case B_ALLOCATED: - reloc_size += object_size(((F_CODE_BLOCK *)scan)->relocation); - literal_size += object_size(((F_CODE_BLOCK *)scan)->literals); - status = "allocated"; - break; - case B_MARKED: - reloc_size += object_size(((F_CODE_BLOCK *)scan)->relocation); - literal_size += object_size(((F_CODE_BLOCK *)scan)->literals); - status = "marked"; - break; - default: - status = "invalid"; - break; - } - - print_cell_hex((CELL)scan); print_string(" "); - print_cell_hex(scan->size); print_string(" "); - print_string(status); print_string("\n"); - - scan = next_block(&code_heap,scan); - } - - print_cell(reloc_size); print_string(" bytes of relocation data\n"); - print_cell(literal_size); print_string(" bytes of literal data\n"); -} - -void factorbug(void) -{ - if(fep_disabled) - { - print_string("Low level debugger disabled\n"); - exit(1); - } - - /* open_console(); */ - - print_string("Starting low level debugger...\n"); - print_string(" Basic commands:\n"); - print_string("q -- continue executing Factor - NOT SAFE\n"); - print_string("im -- save image to fep.image\n"); - print_string("x -- exit Factor\n"); - print_string(" Advanced commands:\n"); - print_string("d -- dump memory\n"); - print_string("u -- dump object at tagged \n"); - print_string(". -- print object at tagged \n"); - print_string("t -- toggle output trimming\n"); - print_string("s r -- dump data, retain stacks\n"); - print_string(".s .r .c -- print data, retain, call stacks\n"); - print_string("e -- dump environment\n"); - print_string("g -- dump generations\n"); - print_string("card -- print card containing address\n"); - print_string("addr -- print address containing card\n"); - print_string("data -- data heap dump\n"); - print_string("words -- words dump\n"); - print_string("tuples -- tuples dump\n"); - print_string("refs -- find data heap references to object\n"); - print_string("push -- push object on data stack - NOT SAFE\n"); - print_string("code -- code heap dump\n"); - - bool seen_command = false; - - for(;;) - { - char cmd[1024]; - - print_string("READY\n"); - fflush(stdout); - - if(scanf("%1000s",cmd) <= 0) - { - if(!seen_command) - { - /* If we exit with an EOF immediately, then - dump stacks. This is useful for builder and - other cases where Factor is run with stdin - redirected to /dev/null */ - fep_disabled = true; - - print_datastack(); - print_retainstack(); - print_callstack(); - } - - exit(1); - } - - seen_command = true; - - if(strcmp(cmd,"d") == 0) - { - CELL addr = read_cell_hex(); - if(scanf(" ") < 0) break; - CELL count = read_cell_hex(); - dump_memory(addr,addr+count); - } - else if(strcmp(cmd,"u") == 0) - { - CELL addr = read_cell_hex(); - CELL count = object_size(addr); - dump_memory(addr,addr+count); - } - else if(strcmp(cmd,".") == 0) - { - CELL addr = read_cell_hex(); - print_obj(addr); - print_string("\n"); - } - else if(strcmp(cmd,"t") == 0) - full_output = !full_output; - else if(strcmp(cmd,"s") == 0) - dump_memory(ds_bot,ds); - else if(strcmp(cmd,"r") == 0) - dump_memory(rs_bot,rs); - else if(strcmp(cmd,".s") == 0) - print_datastack(); - else if(strcmp(cmd,".r") == 0) - print_retainstack(); - else if(strcmp(cmd,".c") == 0) - print_callstack(); - else if(strcmp(cmd,"e") == 0) - { - int i; - for(i = 0; i < USER_ENV; i++) - dump_cell((CELL)&userenv[i]); - } - else if(strcmp(cmd,"g") == 0) - dump_generations(); - else if(strcmp(cmd,"card") == 0) - { - CELL addr = read_cell_hex(); - print_cell_hex((CELL)ADDR_TO_CARD(addr)); - nl(); - } - else if(strcmp(cmd,"addr") == 0) - { - CELL card = read_cell_hex(); - print_cell_hex((CELL)CARD_TO_ADDR(card)); - nl(); - } - else if(strcmp(cmd,"q") == 0) - return; - else if(strcmp(cmd,"x") == 0) - exit(1); - else if(strcmp(cmd,"im") == 0) - save_image(STRING_LITERAL("fep.image")); - else if(strcmp(cmd,"data") == 0) - dump_objects(-1); - else if(strcmp(cmd,"refs") == 0) - { - CELL addr = read_cell_hex(); - print_string("Data heap references:\n"); - find_data_references(addr); - nl(); - } - else if(strcmp(cmd,"words") == 0) - dump_objects(WORD_TYPE); - else if(strcmp(cmd,"tuples") == 0) - dump_objects(TUPLE_TYPE); - else if(strcmp(cmd,"push") == 0) - { - CELL addr = read_cell_hex(); - dpush(addr); - } - else if(strcmp(cmd,"code") == 0) - dump_code_heap(); - else - print_string("unknown command\n"); - } -} - -void primitive_die(void) -{ - print_string("The die word was called by the library. Unless you called it yourself,\n"); - print_string("you have triggered a bug in Factor. Please report.\n"); - factorbug(); -} diff --git a/vmpp/debug.cpp b/vm/debug.cpp similarity index 100% rename from vmpp/debug.cpp rename to vm/debug.cpp diff --git a/vm/debug.h b/vm/debug.h deleted file mode 100755 index 594d8ec919..0000000000 --- a/vm/debug.h +++ /dev/null @@ -1,9 +0,0 @@ -void print_obj(CELL obj); -void print_nested_obj(CELL obj, F_FIXNUM nesting); -void dump_generations(void); -void factorbug(void); -void dump_zone(F_ZONE *z); - -bool fep_disabled; - -void primitive_die(void); diff --git a/vmpp/debug.hpp b/vm/debug.hpp similarity index 100% rename from vmpp/debug.hpp rename to vm/debug.hpp diff --git a/vm/dispatch.c b/vm/dispatch.c deleted file mode 100644 index 68ef192531..0000000000 --- a/vm/dispatch.c +++ /dev/null @@ -1,202 +0,0 @@ -#include "master.h" - -static CELL search_lookup_alist(CELL table, CELL class) -{ - F_ARRAY *pairs = untag_object(table); - F_FIXNUM index = array_capacity(pairs) - 1; - while(index >= 0) - { - F_ARRAY *pair = untag_object(array_nth(pairs,index)); - if(array_nth(pair,0) == class) - return array_nth(pair,1); - else - index--; - } - - return F; -} - -static CELL search_lookup_hash(CELL table, CELL class, CELL hashcode) -{ - F_ARRAY *buckets = untag_object(table); - CELL bucket = array_nth(buckets,hashcode & (array_capacity(buckets) - 1)); - if(type_of(bucket) == WORD_TYPE || bucket == F) - return bucket; - else - return search_lookup_alist(bucket,class); -} - -static CELL nth_superclass(F_TUPLE_LAYOUT *layout, F_FIXNUM echelon) -{ - CELL *ptr = (CELL *)(layout + 1); - return ptr[echelon * 2]; -} - -static CELL nth_hashcode(F_TUPLE_LAYOUT *layout, F_FIXNUM echelon) -{ - CELL *ptr = (CELL *)(layout + 1); - return ptr[echelon * 2 + 1]; -} - -static CELL lookup_tuple_method(CELL object, CELL methods) -{ - F_TUPLE *tuple = untag_object(object); - F_TUPLE_LAYOUT *layout = untag_object(tuple->layout); - - F_ARRAY *echelons = untag_object(methods); - - F_FIXNUM echelon = untag_fixnum_fast(layout->echelon); - F_FIXNUM max_echelon = array_capacity(echelons) - 1; - if(echelon > max_echelon) echelon = max_echelon; - - while(echelon >= 0) - { - CELL echelon_methods = array_nth(echelons,echelon); - - if(type_of(echelon_methods) == WORD_TYPE) - return echelon_methods; - else if(echelon_methods != F) - { - CELL class = nth_superclass(layout,echelon); - CELL hashcode = untag_fixnum_fast(nth_hashcode(layout,echelon)); - CELL result = search_lookup_hash(echelon_methods,class,hashcode); - if(result != F) - return result; - } - - echelon--; - } - - critical_error("Cannot find tuple method",methods); - return F; -} - -static CELL lookup_hi_tag_method(CELL object, CELL methods) -{ - F_ARRAY *hi_tag_methods = untag_object(methods); - CELL tag = hi_tag(object) - HEADER_TYPE; -#ifdef FACTOR_DEBUG - assert(tag < TYPE_COUNT - HEADER_TYPE); -#endif - return array_nth(hi_tag_methods,tag); -} - -static CELL lookup_hairy_method(CELL object, CELL methods) -{ - CELL method = array_nth(untag_object(methods),TAG(object)); - if(type_of(method) == WORD_TYPE) - return method; - else - { - switch(TAG(object)) - { - case TUPLE_TYPE: - return lookup_tuple_method(object,method); - break; - case OBJECT_TYPE: - return lookup_hi_tag_method(object,method); - break; - default: - critical_error("Bad methods array",methods); - return -1; - } - } -} - -CELL lookup_method(CELL object, CELL methods) -{ - if(!HI_TAG_OR_TUPLE_P(object)) - return array_nth(untag_object(methods),TAG(object)); - else - return lookup_hairy_method(object,methods); -} - -void primitive_lookup_method(void) -{ - CELL methods = dpop(); - CELL object = dpop(); - dpush(lookup_method(object,methods)); -} - -CELL object_class(CELL object) -{ - if(!HI_TAG_OR_TUPLE_P(object)) - return tag_fixnum(TAG(object)); - else - return get(HI_TAG_HEADER(object)); -} - -static CELL method_cache_hashcode(CELL class, F_ARRAY *array) -{ - CELL capacity = (array_capacity(array) >> 1) - 1; - return ((class >> TAG_BITS) & capacity) << 1; -} - -static void update_method_cache(CELL cache, CELL class, CELL method) -{ - F_ARRAY *array = untag_object(cache); - CELL hashcode = method_cache_hashcode(class,array); - set_array_nth(array,hashcode,class); - set_array_nth(array,hashcode + 1,method); -} - -void primitive_mega_cache_miss(void) -{ - megamorphic_cache_misses++; - - CELL cache = dpop(); - F_FIXNUM index = untag_fixnum_fast(dpop()); - CELL methods = dpop(); - - CELL object = get(ds - index * CELLS); - CELL class = object_class(object); - CELL method = lookup_method(object,methods); - - update_method_cache(cache,class,method); - - dpush(method); -} - -void primitive_reset_dispatch_stats(void) -{ - megamorphic_cache_hits = megamorphic_cache_misses = 0; -} - -void primitive_dispatch_stats(void) -{ - GROWABLE_ARRAY(stats); - GROWABLE_ARRAY_ADD(stats,allot_cell(megamorphic_cache_hits)); - GROWABLE_ARRAY_ADD(stats,allot_cell(megamorphic_cache_misses)); - GROWABLE_ARRAY_TRIM(stats); - GROWABLE_ARRAY_DONE(stats); - dpush(stats); -} - -void jit_emit_class_lookup(F_JIT *jit, F_FIXNUM index, CELL type) -{ - jit_emit_with(jit,userenv[PIC_LOAD],tag_fixnum(-index * CELLS)); - jit_emit(jit,userenv[type]); -} - -void jit_emit_mega_cache_lookup(F_JIT *jit, CELL methods, F_FIXNUM index, CELL cache) -{ - /* Generate machine code to determine the object's class. */ - jit_emit_class_lookup(jit,index,PIC_HI_TAG_TUPLE); - - /* Do a cache lookup. */ - jit_emit_with(jit,userenv[MEGA_LOOKUP],cache); - - /* If we end up here, the cache missed. */ - jit_emit(jit,userenv[JIT_PROLOG]); - - /* Push index, method table and cache on the stack. */ - jit_push(jit,methods); - jit_push(jit,tag_fixnum(index)); - jit_push(jit,cache); - jit_word_call(jit,userenv[MEGA_MISS_WORD]); - - /* Now the new method has been stored into the cache, and its on - the stack. */ - jit_emit(jit,userenv[JIT_EPILOG]); - jit_emit(jit,userenv[JIT_EXECUTE_JUMP]); -} diff --git a/vmpp/dispatch.cpp b/vm/dispatch.cpp similarity index 100% rename from vmpp/dispatch.cpp rename to vm/dispatch.cpp diff --git a/vm/dispatch.h b/vm/dispatch.h deleted file mode 100644 index 1aac242293..0000000000 --- a/vm/dispatch.h +++ /dev/null @@ -1,16 +0,0 @@ -CELL megamorphic_cache_hits; -CELL megamorphic_cache_misses; - -CELL lookup_method(CELL object, CELL methods); -void primitive_lookup_method(void); - -CELL object_class(CELL object); - -void primitive_mega_cache_miss(void); - -void primitive_reset_dispatch_stats(void); -void primitive_dispatch_stats(void); - -void jit_emit_class_lookup(F_JIT *jit, F_FIXNUM index, CELL type); - -void jit_emit_mega_cache_lookup(F_JIT *jit, CELL methods, F_FIXNUM index, CELL cache); diff --git a/vmpp/dispatch.hpp b/vm/dispatch.hpp similarity index 100% rename from vmpp/dispatch.hpp rename to vm/dispatch.hpp diff --git a/vm/errors.c b/vm/errors.c deleted file mode 100755 index 8e7b4818bf..0000000000 --- a/vm/errors.c +++ /dev/null @@ -1,151 +0,0 @@ -#include "master.h" - -void out_of_memory(void) -{ - print_string("Out of memory\n\n"); - dump_generations(); - exit(1); -} - -void fatal_error(char* msg, CELL tagged) -{ - print_string("fatal_error: "); print_string(msg); - print_string(": "); print_cell_hex(tagged); nl(); - exit(1); -} - -void critical_error(char* msg, CELL tagged) -{ - print_string("You have triggered a bug in Factor. Please report.\n"); - print_string("critical_error: "); print_string(msg); - print_string(": "); print_cell_hex(tagged); nl(); - factorbug(); -} - -void throw_error(CELL error, F_STACK_FRAME *callstack_top) -{ - /* If the error handler is set, we rewind any C stack frames and - pass the error to user-space. */ - if(userenv[BREAK_ENV] != F) - { - /* If error was thrown during heap scan, we re-enable the GC */ - gc_off = false; - - /* Reset local roots */ - gc_locals = gc_locals_region->start - CELLS; - extra_roots = extra_roots_region->start - CELLS; - - /* If we had an underflow or overflow, stack pointers might be - out of bounds */ - fix_stacks(); - - dpush(error); - - /* Errors thrown from C code pass NULL for this parameter. - Errors thrown from Factor code, or signal handlers, pass the - actual stack pointer at the time, since the saved pointer is - not necessarily up to date at that point. */ - if(callstack_top) - { - callstack_top = fix_callstack_top(callstack_top, - stack_chain->callstack_bottom); - } - else - callstack_top = stack_chain->callstack_top; - - throw_impl(userenv[BREAK_ENV],callstack_top); - } - /* Error was thrown in early startup before error handler is set, just - crash. */ - else - { - print_string("You have triggered a bug in Factor. Please report.\n"); - print_string("early_error: "); - print_obj(error); - nl(); - factorbug(); - } -} - -void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2, - F_STACK_FRAME *callstack_top) -{ - throw_error(allot_array_4(userenv[ERROR_ENV], - tag_fixnum(error),arg1,arg2),callstack_top); -} - -void type_error(CELL type, CELL tagged) -{ - general_error(ERROR_TYPE,tag_fixnum(type),tagged,NULL); -} - -void not_implemented_error(void) -{ - general_error(ERROR_NOT_IMPLEMENTED,F,F,NULL); -} - -/* Test if 'fault' is in the guard page at the top or bottom (depending on -offset being 0 or -1) of area+area_size */ -bool in_page(CELL fault, CELL area, CELL area_size, int offset) -{ - int pagesize = getpagesize(); - area += area_size; - area += offset * pagesize; - - return fault >= area && fault <= area + pagesize; -} - -void memory_protection_error(CELL addr, F_STACK_FRAME *native_stack) -{ - if(in_page(addr, ds_bot, 0, -1)) - general_error(ERROR_DS_UNDERFLOW,F,F,native_stack); - else if(in_page(addr, ds_bot, ds_size, 0)) - general_error(ERROR_DS_OVERFLOW,F,F,native_stack); - else if(in_page(addr, rs_bot, 0, -1)) - general_error(ERROR_RS_UNDERFLOW,F,F,native_stack); - else if(in_page(addr, rs_bot, rs_size, 0)) - general_error(ERROR_RS_OVERFLOW,F,F,native_stack); - else if(in_page(addr, nursery.end, 0, 0)) - critical_error("allot_object() missed GC check",0); - else if(in_page(addr, gc_locals_region->start, 0, -1)) - critical_error("gc locals underflow",0); - else if(in_page(addr, gc_locals_region->end, 0, 0)) - critical_error("gc locals overflow",0); - else if(in_page(addr, extra_roots_region->start, 0, -1)) - critical_error("extra roots underflow",0); - else if(in_page(addr, extra_roots_region->end, 0, 0)) - critical_error("extra roots overflow",0); - else - general_error(ERROR_MEMORY,allot_cell(addr),F,native_stack); -} - -void signal_error(int signal, F_STACK_FRAME *native_stack) -{ - general_error(ERROR_SIGNAL,tag_fixnum(signal),F,native_stack); -} - -void divide_by_zero_error(void) -{ - general_error(ERROR_DIVIDE_BY_ZERO,F,F,NULL); -} - -void memory_signal_handler_impl(void) -{ - memory_protection_error(signal_fault_addr,signal_callstack_top); -} - -void misc_signal_handler_impl(void) -{ - signal_error(signal_number,signal_callstack_top); -} - -void primitive_call_clear(void) -{ - throw_impl(dpop(),stack_chain->callstack_bottom); -} - -/* For testing purposes */ -void primitive_unimplemented(void) -{ - not_implemented_error(); -} diff --git a/vmpp/errors.cpp b/vm/errors.cpp similarity index 100% rename from vmpp/errors.cpp rename to vm/errors.cpp diff --git a/vm/errors.h b/vm/errors.h deleted file mode 100755 index 56aaf60d54..0000000000 --- a/vm/errors.h +++ /dev/null @@ -1,58 +0,0 @@ -/* Runtime errors */ -typedef enum -{ - ERROR_EXPIRED = 0, - ERROR_IO, - ERROR_NOT_IMPLEMENTED, - ERROR_TYPE, - ERROR_DIVIDE_BY_ZERO, - ERROR_SIGNAL, - ERROR_ARRAY_SIZE, - ERROR_C_STRING, - ERROR_FFI, - ERROR_HEAP_SCAN, - ERROR_UNDEFINED_SYMBOL, - ERROR_DS_UNDERFLOW, - ERROR_DS_OVERFLOW, - ERROR_RS_UNDERFLOW, - ERROR_RS_OVERFLOW, - ERROR_MEMORY, -} F_ERRORTYPE; - -void out_of_memory(void); -void fatal_error(char* msg, CELL tagged); -void critical_error(char* msg, CELL tagged); -void primitive_die(void); - -void throw_error(CELL error, F_STACK_FRAME *native_stack); -void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2, F_STACK_FRAME *native_stack); -void divide_by_zero_error(void); -void memory_protection_error(CELL addr, F_STACK_FRAME *native_stack); -void signal_error(int signal, F_STACK_FRAME *native_stack); -void type_error(CELL type, CELL tagged); -void not_implemented_error(void); - -void primitive_call_clear(void); - -INLINE void type_check(CELL type, CELL tagged) -{ - if(type_of(tagged) != type) type_error(type,tagged); -} - -#define DEFINE_UNTAG(type,check,name) \ - INLINE type *untag_##name(CELL obj) \ - { \ - type_check(check,obj); \ - return untag_object(obj); \ - } - -/* Global variables used to pass fault handler state from signal handler to -user-space */ -CELL signal_number; -CELL signal_fault_addr; -void *signal_callstack_top; - -void memory_signal_handler_impl(void); -void misc_signal_handler_impl(void); - -void primitive_unimplemented(void); diff --git a/vmpp/errors.hpp b/vm/errors.hpp similarity index 100% rename from vmpp/errors.hpp rename to vm/errors.hpp diff --git a/vm/factor.c b/vm/factor.c deleted file mode 100755 index 0a652f7aab..0000000000 --- a/vm/factor.c +++ /dev/null @@ -1,219 +0,0 @@ -#include "master.h" - -void default_parameters(F_PARAMETERS *p) -{ - p->image_path = NULL; - - /* We make a wild guess here that if we're running on ARM, we don't - have a lot of memory. */ -#ifdef FACTOR_ARM - p->ds_size = 8 * CELLS; - p->rs_size = 8 * CELLS; - - p->gen_count = 2; - p->code_size = 4; - p->young_size = 1; - p->aging_size = 1; - p->tenured_size = 6; -#else - p->ds_size = 32 * CELLS; - p->rs_size = 32 * CELLS; - - p->gen_count = 3; - p->code_size = 8 * CELLS; - p->young_size = CELLS / 4; - p->aging_size = CELLS / 2; - p->tenured_size = 4 * CELLS; -#endif - - p->max_pic_size = 3; - - p->secure_gc = false; - p->fep = false; - -#ifdef WINDOWS - p->console = false; -#else - p->console = true; -#endif - - p->stack_traces = true; -} - -INLINE bool factor_arg(const F_CHAR* str, const F_CHAR* arg, CELL* value) -{ - int val; - if(SSCANF(str,arg,&val) > 0) - { - *value = val; - return true; - } - else - return false; -} - -void init_parameters_from_args(F_PARAMETERS *p, int argc, F_CHAR **argv) -{ - default_parameters(p); - p->executable_path = argv[0]; - - int i = 0; - - for(i = 1; i < argc; i++) - { - if(factor_arg(argv[i],STRING_LITERAL("-datastack=%d"),&p->ds_size)); - else if(factor_arg(argv[i],STRING_LITERAL("-retainstack=%d"),&p->rs_size)); - else if(factor_arg(argv[i],STRING_LITERAL("-generations=%d"),&p->gen_count)); - else if(factor_arg(argv[i],STRING_LITERAL("-young=%d"),&p->young_size)); - else if(factor_arg(argv[i],STRING_LITERAL("-aging=%d"),&p->aging_size)); - else if(factor_arg(argv[i],STRING_LITERAL("-tenured=%d"),&p->tenured_size)); - else if(factor_arg(argv[i],STRING_LITERAL("-codeheap=%d"),&p->code_size)); - else if(factor_arg(argv[i],STRING_LITERAL("-pic=%d"),&p->max_pic_size)); - else if(STRCMP(argv[i],STRING_LITERAL("-securegc")) == 0) p->secure_gc = true; - else if(STRCMP(argv[i],STRING_LITERAL("-fep")) == 0) p->fep = true; - else if(STRNCMP(argv[i],STRING_LITERAL("-i="),3) == 0) p->image_path = argv[i] + 3; - else if(STRCMP(argv[i],STRING_LITERAL("-console")) == 0) p->console = true; - else if(STRCMP(argv[i],STRING_LITERAL("-no-stack-traces")) == 0) p->stack_traces = false; - } -} - -/* Do some initialization that we do once only */ -void do_stage1_init(void) -{ - print_string("*** Stage 2 early init... "); - fflush(stdout); - - compile_all_words(); - userenv[STAGE2_ENV] = T; - - print_string("done\n"); - fflush(stdout); -} - -void init_factor(F_PARAMETERS *p) -{ - /* Kilobytes */ - p->ds_size = align_page(p->ds_size << 10); - p->rs_size = align_page(p->rs_size << 10); - - /* Megabytes */ - p->young_size <<= 20; - p->aging_size <<= 20; - p->tenured_size <<= 20; - p->code_size <<= 20; - - /* Disable GC during init as a sanity check */ - gc_off = true; - - /* OS-specific initialization */ - early_init(); - - const F_CHAR *executable_path = vm_executable_path(); - - if(executable_path) - p->executable_path = executable_path; - - if(p->image_path == NULL) - p->image_path = default_image_path(); - - srand(current_micros()); - init_ffi(); - init_stacks(p->ds_size,p->rs_size); - load_image(p); - init_c_io(); - init_inline_caching(p->max_pic_size); - -#ifndef FACTOR_DEBUG - init_signals(); -#endif - - if(p->console) - open_console(); - - stack_chain = NULL; - profiling_p = false; - performing_gc = false; - last_code_heap_scan = NURSERY; - collecting_aging_again = false; - - userenv[CPU_ENV] = tag_object(from_char_string(FACTOR_CPU_STRING)); - userenv[OS_ENV] = tag_object(from_char_string(FACTOR_OS_STRING)); - userenv[CELL_SIZE_ENV] = tag_fixnum(sizeof(CELL)); - userenv[EXECUTABLE_ENV] = (p->executable_path ? tag_object(from_native_string(p->executable_path)) : F); - userenv[ARGS_ENV] = F; - userenv[EMBEDDED_ENV] = F; - - /* We can GC now */ - gc_off = false; - - if(!stage2) - { - userenv[STACK_TRACES_ENV] = tag_boolean(p->stack_traces); - do_stage1_init(); - } -} - -/* May allocate memory */ -void pass_args_to_factor(int argc, F_CHAR **argv) -{ - F_ARRAY *args = allot_array(ARRAY_TYPE,argc,F); - int i; - - for(i = 1; i < argc; i++) - { - REGISTER_UNTAGGED(args); - CELL arg = tag_object(from_native_string(argv[i])); - UNREGISTER_UNTAGGED(args); - set_array_nth(args,i,arg); - } - - userenv[ARGS_ENV] = tag_array(args); -} - -void start_factor(F_PARAMETERS *p) -{ - if(p->fep) factorbug(); - - nest_stacks(); - c_to_factor_toplevel(userenv[BOOT_ENV]); - unnest_stacks(); -} - -void start_embedded_factor(F_PARAMETERS *p) -{ - userenv[EMBEDDED_ENV] = T; - start_factor(p); -} - -void start_standalone_factor(int argc, F_CHAR **argv) -{ - F_PARAMETERS p; - default_parameters(&p); - init_parameters_from_args(&p,argc,argv); - init_factor(&p); - pass_args_to_factor(argc,argv); - start_factor(&p); -} - -char *factor_eval_string(char *string) -{ - char* (*callback)(char*) = alien_offset(userenv[EVAL_CALLBACK_ENV]); - return callback(string); -} - -void factor_eval_free(char *result) -{ - free(result); -} - -void factor_yield(void) -{ - void (*callback)() = alien_offset(userenv[YIELD_CALLBACK_ENV]); - callback(); -} - -void factor_sleep(long us) -{ - void (*callback)() = alien_offset(userenv[SLEEP_CALLBACK_ENV]); - callback(us); -} diff --git a/vmpp/factor.cpp b/vm/factor.cpp similarity index 100% rename from vmpp/factor.cpp rename to vm/factor.cpp diff --git a/vm/factor.h b/vm/factor.h deleted file mode 100644 index a3de31a502..0000000000 --- a/vm/factor.h +++ /dev/null @@ -1,11 +0,0 @@ -DLLEXPORT void default_parameters(F_PARAMETERS *p); -DLLEXPORT void init_parameters_from_args(F_PARAMETERS *p, int argc, F_CHAR **argv); -DLLEXPORT void init_factor(F_PARAMETERS *p); -DLLEXPORT void pass_args_to_factor(int argc, F_CHAR **argv); -DLLEXPORT void start_embedded_factor(F_PARAMETERS *p); -DLLEXPORT void start_standalone_factor(int argc, F_CHAR **argv); - -DLLEXPORT char *factor_eval_string(char *string); -DLLEXPORT void factor_eval_free(char *result); -DLLEXPORT void factor_yield(void); -DLLEXPORT void factor_sleep(long ms); diff --git a/vmpp/factor.hpp b/vm/factor.hpp similarity index 100% rename from vmpp/factor.hpp rename to vm/factor.hpp diff --git a/vm/ffi_test.c b/vm/ffi_test.c index a5a43cf2ae..680b144140 100755 --- a/vm/ffi_test.c +++ b/vm/ffi_test.c @@ -1,8 +1,10 @@ /* This file is linked into the runtime for the sole purpose * of testing FFI code. */ -#include "master.h" #include "ffi_test.h" +#include +#include + void ffi_test_0(void) { } @@ -259,7 +261,7 @@ unsigned long long ffi_test_38(unsigned long long x, unsigned long long y) int ffi_test_39(long a, long b, struct test_struct_13 s) { - if(a != b) abort(); + assert(a == b); return s.x1 + s.x2 + s.x3 + s.x4 + s.x5 + s.x6; } diff --git a/vm/ffi_test.h b/vm/ffi_test.h index f8634b304e..f16e52e091 100755 --- a/vm/ffi_test.h +++ b/vm/ffi_test.h @@ -4,6 +4,8 @@ #define F_STDCALL #endif +#define DLLEXPORT + DLLEXPORT void ffi_test_0(void); DLLEXPORT int ffi_test_1(void); DLLEXPORT int ffi_test_2(int x, int y); diff --git a/vm/float_bits.h b/vm/float_bits.h deleted file mode 100644 index a60d42f97c..0000000000 --- a/vm/float_bits.h +++ /dev/null @@ -1,40 +0,0 @@ -/* Some functions for converting floating point numbers to binary -representations and vice versa */ - -typedef union { - double x; - u64 y; -} F_DOUBLE_BITS; - -INLINE u64 double_bits(double x) -{ - F_DOUBLE_BITS b; - b.x = x; - return b.y; -} - -INLINE double bits_double(u64 y) -{ - F_DOUBLE_BITS b; - b.y = y; - return b.x; -} - -typedef union { - float x; - u32 y; -} F_FLOAT_BITS; - -INLINE u32 float_bits(float x) -{ - F_FLOAT_BITS b; - b.x = x; - return b.y; -} - -INLINE float bits_float(u32 y) -{ - F_FLOAT_BITS b; - b.y = y; - return b.x; -} diff --git a/vmpp/float_bits.hpp b/vm/float_bits.hpp similarity index 100% rename from vmpp/float_bits.hpp rename to vm/float_bits.hpp diff --git a/vmpp/generic_arrays.hpp b/vm/generic_arrays.hpp similarity index 100% rename from vmpp/generic_arrays.hpp rename to vm/generic_arrays.hpp diff --git a/vm/image.c b/vm/image.c deleted file mode 100755 index d7bf035514..0000000000 --- a/vm/image.c +++ /dev/null @@ -1,323 +0,0 @@ -#include "master.h" - -/* Certain special objects in the image are known to the runtime */ -void init_objects(F_HEADER *h) -{ - memcpy(userenv,h->userenv,sizeof(userenv)); - - T = h->t; - bignum_zero = h->bignum_zero; - bignum_pos_one = h->bignum_pos_one; - bignum_neg_one = h->bignum_neg_one; - - stage2 = (userenv[STAGE2_ENV] != F); -} - -INLINE void load_data_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p) -{ - CELL good_size = h->data_size + (1 << 20); - - if(good_size > p->tenured_size) - p->tenured_size = good_size; - - init_data_heap(p->gen_count, - p->young_size, - p->aging_size, - p->tenured_size, - p->secure_gc); - - clear_gc_stats(); - - F_ZONE *tenured = &data_heap->generations[TENURED]; - - F_FIXNUM bytes_read = fread((void*)tenured->start,1,h->data_size,file); - - if(bytes_read != h->data_size) - { - print_string("truncated image: "); - print_fixnum(bytes_read); - print_string(" bytes read, "); - print_cell(h->data_size); - print_string(" bytes expected\n"); - fatal_error("load_data_heap failed",0); - } - - tenured->here = tenured->start + h->data_size; - data_relocation_base = h->data_relocation_base; -} - -INLINE void load_code_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p) -{ - CELL good_size = h->code_size + (1 << 19); - - if(good_size > p->code_size) - p->code_size = good_size; - - init_code_heap(p->code_size); - - if(h->code_size != 0) - { - F_FIXNUM bytes_read = fread(first_block(&code_heap),1,h->code_size,file); - if(bytes_read != h->code_size) - { - print_string("truncated image: "); - print_fixnum(bytes_read); - print_string(" bytes read, "); - print_cell(h->code_size); - print_string(" bytes expected\n"); - fatal_error("load_code_heap failed",0); - } - } - - code_relocation_base = h->code_relocation_base; - build_free_list(&code_heap,h->code_size); -} - -/* Read an image file from disk, only done once during startup */ -/* This function also initializes the data and code heaps */ -void load_image(F_PARAMETERS *p) -{ - FILE *file = OPEN_READ(p->image_path); - if(file == NULL) - { - print_string("Cannot open image file: "); print_native_string(p->image_path); nl(); - print_string(strerror(errno)); nl(); - exit(1); - } - - F_HEADER h; - if(fread(&h,sizeof(F_HEADER),1,file) != 1) - fatal_error("Cannot read image header",0); - - if(h.magic != IMAGE_MAGIC) - fatal_error("Bad image: magic number check failed",h.magic); - - if(h.version != IMAGE_VERSION) - fatal_error("Bad image: version number check failed",h.version); - - load_data_heap(file,&h,p); - load_code_heap(file,&h,p); - - fclose(file); - - init_objects(&h); - - relocate_data(); - relocate_code(); - - /* Store image path name */ - userenv[IMAGE_ENV] = tag_object(from_native_string(p->image_path)); -} - -/* Save the current image to disk */ -bool save_image(const F_CHAR *filename) -{ - FILE* file; - F_HEADER h; - - file = OPEN_WRITE(filename); - if(file == NULL) - { - print_string("Cannot open image file: "); print_native_string(filename); nl(); - print_string(strerror(errno)); nl(); - return false; - } - - F_ZONE *tenured = &data_heap->generations[TENURED]; - - h.magic = IMAGE_MAGIC; - h.version = IMAGE_VERSION; - h.data_relocation_base = tenured->start; - h.data_size = tenured->here - tenured->start; - h.code_relocation_base = code_heap.segment->start; - h.code_size = heap_size(&code_heap); - - h.t = T; - h.bignum_zero = bignum_zero; - h.bignum_pos_one = bignum_pos_one; - h.bignum_neg_one = bignum_neg_one; - - CELL i; - for(i = 0; i < USER_ENV; i++) - { - if(i < FIRST_SAVE_ENV) - h.userenv[i] = F; - else - h.userenv[i] = userenv[i]; - } - - bool ok = true; - - if(fwrite(&h,sizeof(F_HEADER),1,file) != 1) ok = false; - if(fwrite((void*)tenured->start,h.data_size,1,file) != 1) ok = false; - if(fwrite(first_block(&code_heap),h.code_size,1,file) != 1) ok = false; - if(fclose(file)) ok = false; - - if(!ok) - { - print_string("save-image failed: "); print_string(strerror(errno)); nl(); - } - - return ok; -} - -void primitive_save_image(void) -{ - /* do a full GC to push everything into tenured space */ - gc(); - - save_image(unbox_native_string()); -} - -void primitive_save_image_and_exit(void) -{ - /* We unbox this before doing anything else. This is the only point - where we might throw an error, so we have to throw an error here since - later steps destroy the current image. */ - F_CHAR *path = unbox_native_string(); - - REGISTER_C_STRING(path); - - /* strip out userenv data which is set on startup anyway */ - CELL i; - for(i = 0; i < FIRST_SAVE_ENV; i++) - userenv[i] = F; - - for(i = LAST_SAVE_ENV + 1; i < STACK_TRACES_ENV; i++) - userenv[i] = F; - - /* do a full GC + code heap compaction */ - performing_compaction = true; - compact_code_heap(); - performing_compaction = false; - - UNREGISTER_C_STRING(path); - - /* Save the image */ - if(save_image(path)) - exit(0); - else - exit(1); -} - -void fixup_word(F_WORD *word) -{ - if(stage2) - { - code_fixup((CELL)&word->code); - if(word->profiling) code_fixup((CELL)&word->profiling); - code_fixup((CELL)&word->xt); - } -} - -void fixup_quotation(F_QUOTATION *quot) -{ - if(quot->compiledp == F) - quot->xt = lazy_jit_compile; - else - { - code_fixup((CELL)"->xt); - code_fixup((CELL)"->code); - } -} - -void fixup_alien(F_ALIEN *d) -{ - d->expired = T; -} - -void fixup_stack_frame(F_STACK_FRAME *frame) -{ - code_fixup((CELL)&frame->xt); - code_fixup((CELL)&FRAME_RETURN_ADDRESS(frame)); -} - -void fixup_callstack_object(F_CALLSTACK *stack) -{ - iterate_callstack_object(stack,fixup_stack_frame); -} - -/* Initialize an object in a newly-loaded image */ -void relocate_object(CELL relocating) -{ - /* Tuple relocation is a bit trickier; we have to fix up the - fixup object before we can get the tuple size, so do_slots is - out of the question */ - if(untag_header(get(relocating)) == TUPLE_TYPE) - { - data_fixup((CELL *)relocating + 1); - - CELL scan = relocating + 2 * CELLS; - CELL size = untagged_object_size(relocating); - CELL end = relocating + size; - - while(scan < end) - { - data_fixup((CELL *)scan); - scan += CELLS; - } - } - else - { - do_slots(relocating,data_fixup); - - switch(untag_header(get(relocating))) - { - case WORD_TYPE: - fixup_word((F_WORD *)relocating); - break; - case QUOTATION_TYPE: - fixup_quotation((F_QUOTATION *)relocating); - break; - case DLL_TYPE: - ffi_dlopen((F_DLL *)relocating); - break; - case ALIEN_TYPE: - fixup_alien((F_ALIEN *)relocating); - break; - case CALLSTACK_TYPE: - fixup_callstack_object((F_CALLSTACK *)relocating); - break; - } - } -} - -/* Since the image might have been saved with a different base address than -where it is loaded, we need to fix up pointers in the image. */ -void relocate_data() -{ - CELL relocating; - - CELL i; - for(i = 0; i < USER_ENV; i++) - data_fixup(&userenv[i]); - - data_fixup(&T); - data_fixup(&bignum_zero); - data_fixup(&bignum_pos_one); - data_fixup(&bignum_neg_one); - - F_ZONE *tenured = &data_heap->generations[TENURED]; - - for(relocating = tenured->start; - relocating < tenured->here; - relocating += untagged_object_size(relocating)) - { - allot_barrier(relocating); - relocate_object(relocating); - } -} - -void fixup_code_block(F_CODE_BLOCK *compiled) -{ - /* relocate literal table data */ - data_fixup(&compiled->relocation); - data_fixup(&compiled->literals); - - relocate_code_block(compiled); -} - -void relocate_code() -{ - iterate_code_heap(fixup_code_block); -} diff --git a/vmpp/image.cpp b/vm/image.cpp similarity index 100% rename from vmpp/image.cpp rename to vm/image.cpp diff --git a/vm/image.h b/vm/image.h deleted file mode 100755 index de5b55f0af..0000000000 --- a/vm/image.h +++ /dev/null @@ -1,69 +0,0 @@ -#define IMAGE_MAGIC 0x0f0e0d0c -#define IMAGE_VERSION 4 - -typedef struct { - CELL magic; - CELL version; - /* all pointers in the image file are relocated from - relocation_base to here when the image is loaded */ - CELL data_relocation_base; - /* size of heap */ - CELL data_size; - /* code relocation base */ - CELL code_relocation_base; - /* size of code heap */ - CELL code_size; - /* tagged pointer to t singleton */ - CELL t; - /* tagged pointer to bignum 0 */ - CELL bignum_zero; - /* tagged pointer to bignum 1 */ - CELL bignum_pos_one; - /* tagged pointer to bignum -1 */ - CELL bignum_neg_one; - /* Initial user environment */ - CELL userenv[USER_ENV]; -} F_HEADER; - -typedef struct { - const F_CHAR *image_path; - const F_CHAR *executable_path; - CELL ds_size, rs_size; - CELL gen_count, young_size, aging_size, tenured_size; - CELL code_size; - bool secure_gc; - bool fep; - bool console; - bool stack_traces; - CELL max_pic_size; -} F_PARAMETERS; - -void load_image(F_PARAMETERS *p); -void init_objects(F_HEADER *h); -bool save_image(const F_CHAR *file); - -void primitive_save_image(void); -void primitive_save_image_and_exit(void); - -/* relocation base of currently loaded image's data heap */ -CELL data_relocation_base; - -INLINE void data_fixup(CELL *cell) -{ - if(immediate_p(*cell)) - return; - - F_ZONE *tenured = &data_heap->generations[TENURED]; - *cell += (tenured->start - data_relocation_base); -} - -CELL code_relocation_base; - -INLINE void code_fixup(CELL cell) -{ - CELL value = get(cell); - put(cell,value + (code_heap.segment->start - code_relocation_base)); -} - -void relocate_data(); -void relocate_code(); diff --git a/vmpp/image.hpp b/vm/image.hpp similarity index 100% rename from vmpp/image.hpp rename to vm/image.hpp diff --git a/vm/inline_cache.c b/vm/inline_cache.c deleted file mode 100644 index 83981d2894..0000000000 --- a/vm/inline_cache.c +++ /dev/null @@ -1,248 +0,0 @@ -#include "master.h" - -void init_inline_caching(int max_size) -{ - max_pic_size = max_size; -} - -void deallocate_inline_cache(CELL return_address) -{ - /* Find the call target. */ - XT old_xt = (XT)get_call_target(return_address); - F_CODE_BLOCK *old_block = (F_CODE_BLOCK *)old_xt - 1; - CELL old_type = old_block->block.type; - -#ifdef FACTOR_DEBUG - /* The call target was either another PIC, - or a compiled quotation (megamorphic stub) */ - assert(old_type == PIC_TYPE || old_type == QUOTATION_TYPE); -#endif - - if(old_type == PIC_TYPE) - heap_free(&code_heap,&old_block->block); -} - -/* Figure out what kind of type check the PIC needs based on the methods -it contains */ -static CELL determine_inline_cache_type(CELL cache_entries) -{ - F_ARRAY *array = untag_object(cache_entries); - - bool seen_hi_tag = false, seen_tuple = false; - - CELL i; - for(i = 0; i < array_capacity(array); i += 2) - { - CELL class = array_nth(array,i); - F_FIXNUM type; - - /* Is it a tuple layout? */ - switch(type_of(class)) - { - case FIXNUM_TYPE: - type = untag_fixnum_fast(class); - if(type >= HEADER_TYPE) - seen_hi_tag = true; - break; - case ARRAY_TYPE: - seen_tuple = true; - break; - default: - critical_error("Expected a fixnum or array",class); - break; - } - } - - if(seen_hi_tag && seen_tuple) return PIC_HI_TAG_TUPLE; - if(seen_hi_tag && !seen_tuple) return PIC_HI_TAG; - if(!seen_hi_tag && seen_tuple) return PIC_TUPLE; - if(!seen_hi_tag && !seen_tuple) return PIC_TAG; - - critical_error("Oops",0); - return -1; -} - -static void update_pic_count(CELL type) -{ - pic_counts[type - PIC_TAG]++; -} - -static void jit_emit_check(F_JIT *jit, CELL class) -{ - CELL template; - if(TAG(class) == FIXNUM_TYPE && untag_fixnum_fast(class) < HEADER_TYPE) - template = userenv[PIC_CHECK_TAG]; - else - template = userenv[PIC_CHECK]; - - jit_emit_with(jit,template,class); -} - -/* index: 0 = top of stack, 1 = item underneath, etc - cache_entries: array of class/method pairs */ -static F_CODE_BLOCK *compile_inline_cache(F_FIXNUM index, CELL generic_word, CELL methods, CELL cache_entries) -{ -#ifdef FACTOR_DEBUG - type_check(WORD_TYPE,generic_word); - type_check(ARRAY_TYPE,cache_entries); -#endif - - REGISTER_ROOT(generic_word); - REGISTER_ROOT(methods); - REGISTER_ROOT(cache_entries); - - CELL inline_cache_type = determine_inline_cache_type(cache_entries); - - update_pic_count(inline_cache_type); - - F_JIT jit; - jit_init(&jit,PIC_TYPE,generic_word); - - /* Generate machine code to determine the object's class. */ - jit_emit_class_lookup(&jit,index,inline_cache_type); - - /* Generate machine code to check, in turn, if the class is one of the cached entries. */ - CELL i; - for(i = 0; i < array_capacity(untag_object(cache_entries)); i += 2) - { - /* Class equal? */ - CELL class = array_nth(untag_object(cache_entries),i); - jit_emit_check(&jit,class); - - /* Yes? Jump to method */ - CELL method = array_nth(untag_object(cache_entries),i + 1); - jit_emit_with(&jit,userenv[PIC_HIT],method); - } - - /* Generate machine code to handle a cache miss, which ultimately results in - this function being called again. - - The inline-cache-miss primitive call receives enough information to - reconstruct the PIC. */ - jit_push(&jit,generic_word); - jit_push(&jit,methods); - jit_push(&jit,tag_fixnum(index)); - jit_push(&jit,cache_entries); - jit_word_jump(&jit,userenv[PIC_MISS_WORD]); - - F_CODE_BLOCK *code = jit_make_code_block(&jit); - relocate_code_block(code); - - jit_dispose(&jit); - - UNREGISTER_ROOT(cache_entries); - UNREGISTER_ROOT(methods); - UNREGISTER_ROOT(generic_word); - - return code; -} - -/* A generic word's definition performs general method lookup. Allocates memory */ -static XT megamorphic_call_stub(CELL generic_word) -{ - return untag_word(generic_word)->xt; -} - -static CELL inline_cache_size(CELL cache_entries) -{ - return (cache_entries == F ? 0 : array_capacity(untag_array(cache_entries)) / 2); -} - -/* Allocates memory */ -static CELL add_inline_cache_entry(CELL cache_entries, CELL class, CELL method) -{ - if(cache_entries == F) - return allot_array_2(class,method); - else - { - F_ARRAY *cache_entries_array = untag_object(cache_entries); - CELL pic_size = array_capacity(cache_entries_array); - cache_entries_array = reallot_array(cache_entries_array,pic_size + 2); - set_array_nth(cache_entries_array,pic_size,class); - set_array_nth(cache_entries_array,pic_size + 1,method); - return tag_array(cache_entries_array); - } -} - -static void update_pic_transitions(CELL pic_size) -{ - if(pic_size == max_pic_size) - pic_to_mega_transitions++; - else if(pic_size == 0) - cold_call_to_ic_transitions++; - else if(pic_size == 1) - ic_to_pic_transitions++; -} - -/* The cache_entries parameter is either f (on cold call site) or an array (on cache miss). -Called from assembly with the actual return address */ -XT inline_cache_miss(CELL return_address) -{ - check_code_pointer(return_address); - - /* Since each PIC is only referenced from a single call site, - if the old call target was a PIC, we can deallocate it immediately, - instead of leaving dead PICs around until the next GC. */ - deallocate_inline_cache(return_address); - - CELL cache_entries = dpop(); - F_FIXNUM index = untag_fixnum_fast(dpop()); - CELL methods = dpop(); - CELL generic_word = dpop(); - CELL object = get(ds - index * CELLS); - - XT xt; - - CELL pic_size = inline_cache_size(cache_entries); - - update_pic_transitions(pic_size); - - if(pic_size >= max_pic_size) - xt = megamorphic_call_stub(generic_word); - else - { - REGISTER_ROOT(generic_word); - REGISTER_ROOT(cache_entries); - REGISTER_ROOT(methods); - - CELL class = object_class(object); - CELL method = lookup_method(object,methods); - - cache_entries = add_inline_cache_entry(cache_entries,class,method); - xt = compile_inline_cache(index,generic_word,methods,cache_entries) + 1; - - UNREGISTER_ROOT(methods); - UNREGISTER_ROOT(cache_entries); - UNREGISTER_ROOT(generic_word); - } - - /* Install the new stub. */ - set_call_target(return_address,(CELL)xt); - -#ifdef PIC_DEBUG - printf("Updated call site 0x%lx with 0x%lx\n",return_address,(CELL)xt); -#endif - - return xt; -} - -void primitive_reset_inline_cache_stats(void) -{ - cold_call_to_ic_transitions = ic_to_pic_transitions = pic_to_mega_transitions = 0; - CELL i; - for(i = 0; i < 4; i++) pic_counts[i] = 0; -} - -void primitive_inline_cache_stats(void) -{ - GROWABLE_ARRAY(stats); - GROWABLE_ARRAY_ADD(stats,allot_cell(cold_call_to_ic_transitions)); - GROWABLE_ARRAY_ADD(stats,allot_cell(ic_to_pic_transitions)); - GROWABLE_ARRAY_ADD(stats,allot_cell(pic_to_mega_transitions)); - CELL i; - for(i = 0; i < 4; i++) - GROWABLE_ARRAY_ADD(stats,allot_cell(pic_counts[i])); - GROWABLE_ARRAY_TRIM(stats); - GROWABLE_ARRAY_DONE(stats); - dpush(stats); -} diff --git a/vmpp/inline_cache.cpp b/vm/inline_cache.cpp similarity index 100% rename from vmpp/inline_cache.cpp rename to vm/inline_cache.cpp diff --git a/vm/inline_cache.h b/vm/inline_cache.h deleted file mode 100644 index 83f2644f5a..0000000000 --- a/vm/inline_cache.h +++ /dev/null @@ -1,17 +0,0 @@ -CELL max_pic_size; - -CELL cold_call_to_ic_transitions; -CELL ic_to_pic_transitions; -CELL pic_to_mega_transitions; - -/* PIC_TAG, PIC_HI_TAG, PIC_TUPLE, PIC_HI_TAG_TUPLE */ -CELL pic_counts[4]; - -void init_inline_caching(int max_size); - -void primitive_inline_cache_miss(void); - -XT inline_cache_miss(CELL return_address); - -void primitive_reset_inline_cache_stats(void); -void primitive_inline_cache_stats(void); diff --git a/vmpp/inline_cache.hpp b/vm/inline_cache.hpp similarity index 100% rename from vmpp/inline_cache.hpp rename to vm/inline_cache.hpp diff --git a/vm/io.c b/vm/io.c deleted file mode 100755 index d88f1bab50..0000000000 --- a/vm/io.c +++ /dev/null @@ -1,226 +0,0 @@ -#include "master.h" - -/* Simple wrappers for ANSI C I/O functions, used for bootstrapping. - -Note the ugly loop logic in almost every function; we have to handle EINTR -and restart the operation if the system call was interrupted. Naive -applications don't do this, but then they quickly fail if one enables -itimer()s or other signals. - -The Factor library provides platform-specific code for Unix and Windows -with many more capabilities so these words are not usually used in -normal operation. */ - -void init_c_io(void) -{ - userenv[STDIN_ENV] = allot_alien(F,(CELL)stdin); - userenv[STDOUT_ENV] = allot_alien(F,(CELL)stdout); - userenv[STDERR_ENV] = allot_alien(F,(CELL)stderr); -} - -void io_error(void) -{ -#ifndef WINCE - if(errno == EINTR) - return; -#endif - - CELL error = tag_object(from_char_string(strerror(errno))); - general_error(ERROR_IO,error,F,NULL); -} - -void primitive_fopen(void) -{ - char *mode = unbox_char_string(); - REGISTER_C_STRING(mode); - char *path = unbox_char_string(); - UNREGISTER_C_STRING(mode); - - for(;;) - { - FILE *file = fopen(path,mode); - if(file == NULL) - io_error(); - else - { - box_alien(file); - break; - } - } -} - -void primitive_fgetc(void) -{ - FILE* file = unbox_alien(); - - for(;;) - { - int c = fgetc(file); - if(c == EOF) - { - if(feof(file)) - { - dpush(F); - break; - } - else - io_error(); - } - else - { - dpush(tag_fixnum(c)); - break; - } - } -} - -void primitive_fread(void) -{ - FILE* file = unbox_alien(); - CELL size = unbox_array_size(); - - if(size == 0) - { - dpush(tag_object(allot_string(0,0))); - return; - } - - F_BYTE_ARRAY *buf = allot_byte_array(size); - - for(;;) - { - int c = fread(buf + 1,1,size,file); - if(c <= 0) - { - if(feof(file)) - { - dpush(F); - break; - } - else - io_error(); - } - else - { - if(c != size) - { - REGISTER_UNTAGGED(buf); - F_BYTE_ARRAY *new_buf = allot_byte_array(c); - UNREGISTER_UNTAGGED(buf); - memcpy(new_buf + 1, buf + 1,c); - buf = new_buf; - } - dpush(tag_object(buf)); - break; - } - } -} - -void primitive_fputc(void) -{ - FILE *file = unbox_alien(); - F_FIXNUM ch = to_fixnum(dpop()); - - for(;;) - { - if(fputc(ch,file) == EOF) - { - io_error(); - - /* Still here? EINTR */ - } - else - break; - } -} - -void primitive_fwrite(void) -{ - FILE *file = unbox_alien(); - F_BYTE_ARRAY *text = untag_byte_array(dpop()); - F_FIXNUM length = array_capacity(text); - char *string = (char *)(text + 1); - - if(length == 0) - return; - - for(;;) - { - size_t written = fwrite(string,1,length,file); - if(written == length) - break; - else - { - if(feof(file)) - break; - else - io_error(); - - /* Still here? EINTR */ - length -= written; - string += written; - } - } -} - -void primitive_fseek(void) -{ - int whence = to_fixnum(dpop()); - FILE *file = unbox_alien(); - off_t offset = to_signed_8(dpop()); - - switch(whence) - { - case 0: whence = SEEK_SET; break; - case 1: whence = SEEK_CUR; break; - case 2: whence = SEEK_END; break; - default: - critical_error("Bad value for whence",whence); - break; - } - - if(FSEEK(file,offset,whence) == -1) - { - io_error(); - - /* Still here? EINTR */ - critical_error("Don't know what to do; EINTR from fseek()?",0); - } -} - -void primitive_fflush(void) -{ - FILE *file = unbox_alien(); - for(;;) - { - if(fflush(file) == EOF) - io_error(); - else - break; - } -} - -void primitive_fclose(void) -{ - FILE *file = unbox_alien(); - for(;;) - { - if(fclose(file) == EOF) - io_error(); - else - break; - } -} - -/* This function is used by FFI I/O. Accessing the errno global directly is -not portable, since on some libc's errno is not a global but a funky macro that -reads thread-local storage. */ -int err_no(void) -{ - return errno; -} - -void clear_err_no(void) -{ - errno = 0; -} diff --git a/vmpp/io.cpp b/vm/io.cpp similarity index 100% rename from vmpp/io.cpp rename to vm/io.cpp diff --git a/vm/io.h b/vm/io.h deleted file mode 100755 index 63a9c35490..0000000000 --- a/vm/io.h +++ /dev/null @@ -1,18 +0,0 @@ -void init_c_io(void); -void io_error(void); -DLLEXPORT int err_no(void); -DLLEXPORT void clear_err_no(void); - -void primitive_fopen(void); -void primitive_fgetc(void); -void primitive_fread(void); -void primitive_fputc(void); -void primitive_fwrite(void); -void primitive_fflush(void); -void primitive_fseek(void); -void primitive_fclose(void); - -/* Platform specific primitives */ -void primitive_open_file(void); -void primitive_existsp(void); -void primitive_read_dir(void); diff --git a/vmpp/io.hpp b/vm/io.hpp similarity index 100% rename from vmpp/io.hpp rename to vm/io.hpp diff --git a/vm/jit.c b/vm/jit.c deleted file mode 100644 index 8d7dcd657a..0000000000 --- a/vm/jit.c +++ /dev/null @@ -1,119 +0,0 @@ -#include "master.h" - -/* Simple code generator used by: -- profiler (profiler.c), -- quotation compiler (quotations.c), -- megamorphic caches (dispatch.c), -- polymorphic inline caches (inline_cache.c) */ - -/* Allocates memory */ -void jit_init(F_JIT *jit, CELL jit_type, CELL owner) -{ - jit->owner = owner; - REGISTER_ROOT(jit->owner); - - jit->type = jit_type; - - jit->code = make_growable_byte_array(); - REGISTER_ROOT(jit->code.array); - jit->relocation = make_growable_byte_array(); - REGISTER_ROOT(jit->relocation.array); - jit->literals = make_growable_array(); - REGISTER_ROOT(jit->literals.array); - - if(stack_traces_p()) - growable_array_add(&jit->literals,jit->owner); - - jit->computing_offset_p = false; -} - -/* Facility to convert compiled code offsets to quotation offsets. -Call jit_compute_offset() with the compiled code offset, then emit -code, and at the end jit->position is the quotation position. */ -void jit_compute_position(F_JIT *jit, CELL offset) -{ - jit->computing_offset_p = true; - jit->position = 0; - jit->offset = offset; -} - -/* Allocates memory */ -F_CODE_BLOCK *jit_make_code_block(F_JIT *jit) -{ - growable_byte_array_trim(&jit->code); - growable_byte_array_trim(&jit->relocation); - growable_array_trim(&jit->literals); - - F_CODE_BLOCK *code = add_code_block( - jit->type, - untag_object(jit->code.array), - NULL, /* no labels */ - jit->relocation.array, - jit->literals.array); - - return code; -} - -void jit_dispose(F_JIT *jit) -{ - UNREGISTER_ROOT(jit->literals.array); - UNREGISTER_ROOT(jit->relocation.array); - UNREGISTER_ROOT(jit->code.array); - UNREGISTER_ROOT(jit->owner); -} - -static F_REL rel_to_emit(F_JIT *jit, CELL template, bool *rel_p) -{ - F_ARRAY *quadruple = untag_object(template); - CELL rel_class = array_nth(quadruple,1); - CELL rel_type = array_nth(quadruple,2); - CELL offset = array_nth(quadruple,3); - - if(rel_class == F) - { - *rel_p = false; - return 0; - } - else - { - *rel_p = true; - return (untag_fixnum_fast(rel_type) << 28) - | (untag_fixnum_fast(rel_class) << 24) - | ((jit->code.count + untag_fixnum_fast(offset))); - } -} - -/* Allocates memory */ -void jit_emit(F_JIT *jit, CELL template) -{ - REGISTER_ROOT(template); - - bool rel_p; - F_REL rel = rel_to_emit(jit,template,&rel_p); - if(rel_p) growable_byte_array_append(&jit->relocation,&rel,sizeof(F_REL)); - - F_BYTE_ARRAY *code = code_to_emit(template); - - if(jit->computing_offset_p) - { - CELL size = array_capacity(code); - - if(jit->offset == 0) - { - jit->position--; - jit->computing_offset_p = false; - } - else if(jit->offset < size) - { - jit->position++; - jit->computing_offset_p = false; - } - else - jit->offset -= size; - } - - growable_byte_array_append(&jit->code,code + 1,array_capacity(code)); - - UNREGISTER_ROOT(template); -} - diff --git a/vmpp/jit.cpp b/vm/jit.cpp similarity index 100% rename from vmpp/jit.cpp rename to vm/jit.cpp diff --git a/vm/jit.h b/vm/jit.h deleted file mode 100644 index 4ea72ee9a4..0000000000 --- a/vm/jit.h +++ /dev/null @@ -1,87 +0,0 @@ -typedef struct { - CELL type; - CELL owner; - F_GROWABLE_BYTE_ARRAY code; - F_GROWABLE_BYTE_ARRAY relocation; - F_GROWABLE_ARRAY literals; - bool computing_offset_p; - F_FIXNUM position; - CELL offset; -} F_JIT; - -void jit_init(F_JIT *jit, CELL jit_type, CELL owner); - -void jit_compute_position(F_JIT *jit, CELL offset); - -F_CODE_BLOCK *jit_make_code_block(F_JIT *jit); - -void jit_dispose(F_JIT *jit); - -INLINE F_BYTE_ARRAY *code_to_emit(CELL template) -{ - return untag_object(array_nth(untag_object(template),0)); -} - -void jit_emit(F_JIT *jit, CELL template); - -/* Allocates memory */ -INLINE void jit_add_literal(F_JIT *jit, CELL literal) -{ - growable_array_add(&jit->literals,literal); -} - -/* Allocates memory */ -INLINE void jit_emit_with(F_JIT *jit, CELL template, CELL argument) -{ - REGISTER_ROOT(template); - jit_add_literal(jit,argument); - UNREGISTER_ROOT(template); - jit_emit(jit,template); -} - -/* Allocates memory */ -INLINE void jit_push(F_JIT *jit, CELL literal) -{ - jit_emit_with(jit,userenv[JIT_PUSH_IMMEDIATE],literal); -} - -/* Allocates memory */ -INLINE void jit_word_jump(F_JIT *jit, CELL word) -{ - jit_emit_with(jit,userenv[JIT_WORD_JUMP],word); -} - -/* Allocates memory */ -INLINE void jit_word_call(F_JIT *jit, CELL word) -{ - jit_emit_with(jit,userenv[JIT_WORD_CALL],word); -} - -/* Allocates memory */ -INLINE void jit_emit_subprimitive(F_JIT *jit, F_WORD *word) -{ - REGISTER_UNTAGGED(word); - if(array_nth(untag_object(word->subprimitive),1) != F) - jit_add_literal(jit,T); - UNREGISTER_UNTAGGED(word); - - jit_emit(jit,word->subprimitive); -} - -INLINE F_FIXNUM jit_get_position(F_JIT *jit) -{ - if(jit->computing_offset_p) - { - /* If this is still on, jit_emit() didn't clear it, - so the offset was out of bounds */ - return -1; - } - else - return jit->position; -} - -INLINE void jit_set_position(F_JIT *jit, F_FIXNUM position) -{ - if(jit->computing_offset_p) - jit->position = position; -} diff --git a/vmpp/jit.hpp b/vm/jit.hpp similarity index 100% rename from vmpp/jit.hpp rename to vm/jit.hpp diff --git a/vm/layouts.h b/vm/layouts.h deleted file mode 100755 index f439b1f8a7..0000000000 --- a/vm/layouts.h +++ /dev/null @@ -1,259 +0,0 @@ -#define INLINE inline static - -typedef unsigned char u8; -typedef unsigned short u16; -typedef unsigned int u32; -typedef unsigned long long u64; -typedef signed char s8; -typedef signed short s16; -typedef signed int s32; -typedef signed long long s64; - -#ifdef _WIN64 - typedef long long F_FIXNUM; - typedef unsigned long long CELL; -#else - typedef long F_FIXNUM; - typedef unsigned long CELL; -#endif - -#define CELLS ((signed)sizeof(CELL)) - -#define WORD_SIZE (CELLS*8) -#define HALF_WORD_SIZE (CELLS*4) -#define HALF_WORD_MASK (((unsigned long)1<> TAG_BITS; -} - -INLINE CELL tag_fixnum(F_FIXNUM untagged) -{ - return RETAG(untagged << TAG_BITS,FIXNUM_TYPE); -} - -INLINE void *untag_object(CELL tagged) -{ - return (void *)UNTAG(tagged); -} - -typedef void *XT; - -/* Assembly code makes assumptions about the layout of this struct */ -typedef struct { - CELL header; - /* tagged */ - CELL capacity; -} F_ARRAY; - -typedef F_ARRAY F_BYTE_ARRAY; - -/* Assembly code makes assumptions about the layout of this struct */ -typedef struct { - CELL header; - /* tagged num of chars */ - CELL length; - /* tagged */ - CELL aux; - /* tagged */ - CELL hashcode; -} F_STRING; - -/* The compiled code heap is structured into blocks. */ -typedef enum -{ - B_FREE, - B_ALLOCATED, - B_MARKED -} F_BLOCK_STATUS; - -typedef struct _F_BLOCK -{ - char status; /* free or allocated? */ - char type; /* this is WORD_TYPE or QUOTATION_TYPE */ - char last_scan; /* the youngest generation in which this block's literals may live */ - char needs_fixup; /* is this a new block that needs full fixup? */ - - /* In bytes, includes this header */ - CELL size; - - /* Used during compaction */ - struct _F_BLOCK *forwarding; -} F_BLOCK; - -typedef struct _F_FREE_BLOCK -{ - F_BLOCK block; - - /* Filled in on image load */ - struct _F_FREE_BLOCK *next_free; -} F_FREE_BLOCK; - -typedef struct -{ - F_BLOCK block; - CELL literals; /* # bytes */ - CELL relocation; /* tagged pointer to byte-array or f */ -} F_CODE_BLOCK; - -/* Assembly code makes assumptions about the layout of this struct */ -typedef struct { - /* TAGGED header */ - CELL header; - /* TAGGED hashcode */ - CELL hashcode; - /* TAGGED word name */ - CELL name; - /* TAGGED word vocabulary */ - CELL vocabulary; - /* TAGGED definition */ - CELL def; - /* TAGGED property assoc for library code */ - CELL props; - /* TAGGED alternative entry point for direct non-tail calls. Used for inline caching */ - CELL direct_entry_def; - /* TAGGED call count for profiling */ - CELL counter; - /* TAGGED machine code for sub-primitive */ - CELL subprimitive; - /* UNTAGGED execution token: jump here to execute word */ - XT xt; - /* UNTAGGED compiled code block */ - F_CODE_BLOCK *code; - /* UNTAGGED profiler stub */ - F_CODE_BLOCK *profiling; -} F_WORD; - -/* Assembly code makes assumptions about the layout of this struct */ -typedef struct { - CELL header; - CELL object; -} F_WRAPPER; - -/* Assembly code makes assumptions about the layout of this struct */ -typedef struct { -/* We use a union here to force the float value to be aligned on an -8-byte boundary. */ - union { - CELL header; - long long padding; - }; - double n; -} F_FLOAT; - -/* Assembly code makes assumptions about the layout of this struct */ -typedef struct { - CELL header; - /* tagged */ - CELL array; - /* tagged */ - CELL compiledp; - /* tagged */ - CELL cached_effect; - /* tagged */ - CELL cache_counter; - /* UNTAGGED */ - XT xt; - /* UNTAGGED compiled code block */ - F_CODE_BLOCK *code; -} F_QUOTATION; - -/* Assembly code makes assumptions about the layout of this struct */ -typedef struct { - CELL header; - /* tagged */ - CELL alien; - /* tagged */ - CELL expired; - /* untagged */ - CELL displacement; -} F_ALIEN; - -typedef struct { - CELL header; - /* tagged byte array holding a C string */ - CELL path; - /* OS-specific handle */ - void *dll; -} F_DLL; - -typedef struct { - CELL header; - /* tagged */ - CELL length; -} F_CALLSTACK; - -typedef struct -{ - XT xt; - /* Frame size in bytes */ - CELL size; -} F_STACK_FRAME; - -/* These are really just arrays, but certain elements have special -significance */ -typedef struct -{ - CELL header; - /* tagged */ - CELL capacity; - /* tagged */ - CELL class; - /* tagged fixnum */ - CELL size; - /* tagged fixnum */ - CELL echelon; -} F_TUPLE_LAYOUT; - -typedef struct -{ - CELL header; - /* tagged layout */ - CELL layout; -} F_TUPLE; diff --git a/vmpp/layouts.hpp b/vm/layouts.hpp similarity index 100% rename from vmpp/layouts.hpp rename to vm/layouts.hpp diff --git a/vmpp/local_roots.cpp b/vm/local_roots.cpp similarity index 100% rename from vmpp/local_roots.cpp rename to vm/local_roots.cpp diff --git a/vm/local_roots.h b/vm/local_roots.h deleted file mode 100644 index bbedf46394..0000000000 --- a/vm/local_roots.h +++ /dev/null @@ -1,68 +0,0 @@ -/* If a runtime function needs to call another function which potentially -allocates memory, it must store any local variable references to Factor -objects on the root stack */ - -/* GC locals: stores addresses of pointers to objects. The GC updates these -pointers, so you can do - -REGISTER_ROOT(some_local); - -... allocate memory ... - -foo(some_local); - -... - -UNREGISTER_ROOT(some_local); */ -F_SEGMENT *gc_locals_region; -CELL gc_locals; - -DEFPUSHPOP(gc_local_,gc_locals) - -#define REGISTER_ROOT(obj) \ - { \ - if(!immediate_p(obj)) \ - check_data_pointer(obj); \ - gc_local_push((CELL)&(obj)); \ - } -#define UNREGISTER_ROOT(obj) \ - { \ - if(gc_local_pop() != (CELL)&(obj)) \ - critical_error("Mismatched REGISTER_ROOT/UNREGISTER_ROOT",0); \ - } - -/* Extra roots: stores pointers to objects in the heap. Requires extra work -(you have to unregister before accessing the object) but more flexible. */ -F_SEGMENT *extra_roots_region; -CELL extra_roots; - -DEFPUSHPOP(root_,extra_roots) - -#define REGISTER_UNTAGGED(obj) root_push(obj ? RETAG(obj,OBJECT_TYPE) : 0) -#define UNREGISTER_UNTAGGED(obj) obj = untag_object(root_pop()) - -/* We ignore strings which point outside the data heap, but we might be given -a char* which points inside the data heap, in which case it is a root, for -example if we call unbox_char_string() the result is placed in a byte array */ -INLINE bool root_push_alien(const void *ptr) -{ - if(in_data_heap_p((CELL)ptr)) - { - F_BYTE_ARRAY *objptr = ((F_BYTE_ARRAY *)ptr) - 1; - if(objptr->header == tag_header(BYTE_ARRAY_TYPE)) - { - root_push(tag_object(objptr)); - return true; - } - } - - return false; -} - -#define REGISTER_C_STRING(obj) \ - bool obj##_root = root_push_alien(obj) -#define UNREGISTER_C_STRING(obj) \ - if(obj##_root) obj = alien_offset(root_pop()) - -#define REGISTER_BIGNUM(obj) if(obj) root_push(tag_bignum(obj)) -#define UNREGISTER_BIGNUM(obj) if(obj) obj = (untag_object(root_pop())) diff --git a/vmpp/local_roots.hpp b/vm/local_roots.hpp similarity index 100% rename from vmpp/local_roots.hpp rename to vm/local_roots.hpp diff --git a/vm/mach_signal.c b/vm/mach_signal.c deleted file mode 100644 index 57fb91d662..0000000000 --- a/vm/mach_signal.c +++ /dev/null @@ -1,199 +0,0 @@ -/* Fault handler information. MacOSX version. -Copyright (C) 1993-1999, 2002-2003 Bruno Haible -Copyright (C) 2003 Paolo Bonzini - -Used under BSD license with permission from Paolo Bonzini and Bruno Haible, -2005-03-10: - -http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org - -Modified for Factor by Slava Pestov */ - -#include "master.h" - -/* The following sources were used as a *reference* for this exception handling -code: -1. Apple's mach/xnu documentation -2. Timothy J. Wood's "Mach Exception Handlers 101" post to the -omnigroup's macosx-dev list. -http://www.wodeveloper.com/omniLists/macosx-dev/2000/June/msg00137.html */ - -/* Modify a suspended thread's thread_state so that when the thread resumes -executing, the call frame of the current C primitive (if any) is rewound, and -the appropriate Factor error is thrown from the top-most Factor frame. */ -static void call_fault_handler(exception_type_t exception, - MACH_EXC_STATE_TYPE *exc_state, - MACH_THREAD_STATE_TYPE *thread_state) -{ - /* There is a race condition here, but in practice an exception - delivered during stack frame setup/teardown or while transitioning - from Factor to C is a sign of things seriously gone wrong, not just - a divide by zero or stack underflow in the listener */ - - /* Are we in compiled Factor code? Then use the current stack pointer */ - if(in_code_heap_p(MACH_PROGRAM_COUNTER(thread_state))) - signal_callstack_top = (void *)MACH_STACK_POINTER(thread_state); - /* Are we in C? Then use the saved callstack top */ - else - signal_callstack_top = NULL; - - MACH_STACK_POINTER(thread_state) = fix_stack_pointer(MACH_STACK_POINTER(thread_state)); - - /* Now we point the program counter at the right handler function. */ - if(exception == EXC_BAD_ACCESS) - { - signal_fault_addr = MACH_EXC_STATE_FAULT(exc_state); - MACH_PROGRAM_COUNTER(thread_state) = (CELL)memory_signal_handler_impl; - } - else - { - if(exception == EXC_ARITHMETIC) - signal_number = SIGFPE; - else - signal_number = SIGABRT; - MACH_PROGRAM_COUNTER(thread_state) = (CELL)misc_signal_handler_impl; - } -} - -/* Handle an exception by invoking the user's fault handler and/or forwarding -the duty to the previously installed handlers. */ -kern_return_t -catch_exception_raise (mach_port_t exception_port, - mach_port_t thread, - mach_port_t task, - exception_type_t exception, - exception_data_t code, - mach_msg_type_number_t code_count) -{ - MACH_EXC_STATE_TYPE exc_state; - MACH_THREAD_STATE_TYPE thread_state; - mach_msg_type_number_t state_count; - - /* Get fault information and the faulting thread's register contents.. - - See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/thread_get_state.html. */ - state_count = MACH_EXC_STATE_COUNT; - if (thread_get_state (thread, MACH_EXC_STATE_FLAVOR, - (void *) &exc_state, &state_count) - != KERN_SUCCESS) - { - /* The thread is supposed to be suspended while the exception - handler is called. This shouldn't fail. */ - return KERN_FAILURE; - } - - state_count = MACH_THREAD_STATE_COUNT; - if (thread_get_state (thread, MACH_THREAD_STATE_FLAVOR, - (void *) &thread_state, &state_count) - != KERN_SUCCESS) - { - /* The thread is supposed to be suspended while the exception - handler is called. This shouldn't fail. */ - return KERN_FAILURE; - } - - /* Modify registers so to have the thread resume executing the - fault handler */ - call_fault_handler(exception,&exc_state,&thread_state); - - /* Set the faulting thread's register contents.. - - See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/thread_set_state.html. */ - if (thread_set_state (thread, MACH_THREAD_STATE_FLAVOR, - (void *) &thread_state, state_count) - != KERN_SUCCESS) - { - return KERN_FAILURE; - } - - return KERN_SUCCESS; -} - - -/* The main function of the thread listening for exceptions. */ -static void * -mach_exception_thread (void *arg) -{ - for (;;) - { - /* These two structures contain some private kernel data. We don't need - to access any of it so we don't bother defining a proper struct. The - correct definitions are in the xnu source code. */ - /* Buffer for a message to be received. */ - struct - { - mach_msg_header_t head; - mach_msg_body_t msgh_body; - char data[1024]; - } - msg; - /* Buffer for a reply message. */ - struct - { - mach_msg_header_t head; - char data[1024]; - } - reply; - - mach_msg_return_t retval; - - /* Wait for a message on the exception port. */ - retval = mach_msg (&msg.head, MACH_RCV_MSG | MACH_RCV_LARGE, 0, - sizeof (msg), our_exception_port, - MACH_MSG_TIMEOUT_NONE, MACH_PORT_NULL); - if (retval != MACH_MSG_SUCCESS) - { - abort (); - } - - /* Handle the message: Call exc_server, which will call - catch_exception_raise and produce a reply message. */ - exc_server (&msg.head, &reply.head); - - /* Send the reply. */ - if (mach_msg (&reply.head, MACH_SEND_MSG, reply.head.msgh_size, - 0, MACH_PORT_NULL, MACH_MSG_TIMEOUT_NONE, MACH_PORT_NULL) - != MACH_MSG_SUCCESS) - { - abort (); - } - } -} - - -/* Initialize the Mach exception handler thread. */ -void mach_initialize (void) -{ - mach_port_t self; - exception_mask_t mask; - - self = mach_task_self (); - - /* Allocate a port on which the thread shall listen for exceptions. */ - if (mach_port_allocate (self, MACH_PORT_RIGHT_RECEIVE, &our_exception_port) - != KERN_SUCCESS) - fatal_error("mach_port_allocate() failed",0); - - /* See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/mach_port_insert_right.html. */ - if (mach_port_insert_right (self, our_exception_port, our_exception_port, - MACH_MSG_TYPE_MAKE_SEND) - != KERN_SUCCESS) - fatal_error("mach_port_insert_right() failed",0); - - /* The exceptions we want to catch. */ - mask = EXC_MASK_BAD_ACCESS | EXC_MASK_ARITHMETIC; - - /* Create the thread listening on the exception port. */ - start_thread(mach_exception_thread); - - /* Replace the exception port info for these exceptions with our own. - Note that we replace the exception port for the entire task, not only - for a particular thread. This has the effect that when our exception - port gets the message, the thread specific exception port has already - been asked, and we don't need to bother about it. - See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/task_set_exception_ports.html. */ - if (task_set_exception_ports (self, mask, our_exception_port, - EXCEPTION_DEFAULT, MACHINE_THREAD_STATE) - != KERN_SUCCESS) - fatal_error("task_set_exception_ports() failed",0); -} diff --git a/vmpp/mach_signal.cpp b/vm/mach_signal.cpp similarity index 100% rename from vmpp/mach_signal.cpp rename to vm/mach_signal.cpp diff --git a/vm/mach_signal.h b/vm/mach_signal.h deleted file mode 100644 index 863fd86dae..0000000000 --- a/vm/mach_signal.h +++ /dev/null @@ -1,80 +0,0 @@ -/* Fault handler information. MacOSX version. -Copyright (C) 1993-1999, 2002-2003 Bruno Haible -Copyright (C) 2003 Paolo Bonzini - -Used under BSD license with permission from Paolo Bonzini and Bruno Haible, -2005-03-10: - -http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org - -Modified for Factor by Slava Pestov */ -#include -#include -#include -#include - -#include -#include -#include -#include -#include -#include - -/* The exception port on which our thread listens. */ -mach_port_t our_exception_port; - -/* This is not defined in any header, although documented. */ - -/* http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/exc_server.html says: - The exc_server function is the MIG generated server handling function - to handle messages from the kernel relating to the occurrence of an - exception in a thread. Such messages are delivered to the exception port - set via thread_set_exception_ports or task_set_exception_ports. When an - exception occurs in a thread, the thread sends an exception message to its - exception port, blocking in the kernel waiting for the receipt of a reply. - The exc_server function performs all necessary argument handling for this - kernel message and calls catch_exception_raise, catch_exception_raise_state - or catch_exception_raise_state_identity, which should handle the exception. - If the called routine returns KERN_SUCCESS, a reply message will be sent, - allowing the thread to continue from the point of the exception; otherwise, - no reply message is sent and the called routine must have dealt with the - exception thread directly. */ -extern boolean_t - exc_server (mach_msg_header_t *request_msg, - mach_msg_header_t *reply_msg); - - -/* http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/catch_exception_raise.html - These functions are defined in this file, and called by exc_server. - FIXME: What needs to be done when this code is put into a shared library? */ -kern_return_t -catch_exception_raise (mach_port_t exception_port, - mach_port_t thread, - mach_port_t task, - exception_type_t exception, - exception_data_t code, - mach_msg_type_number_t code_count); -kern_return_t -catch_exception_raise_state (mach_port_t exception_port, - exception_type_t exception, - exception_data_t code, - mach_msg_type_number_t code_count, - thread_state_flavor_t *flavor, - thread_state_t in_state, - mach_msg_type_number_t in_state_count, - thread_state_t out_state, - mach_msg_type_number_t *out_state_count); -kern_return_t -catch_exception_raise_state_identity (mach_port_t exception_port, - mach_port_t thread, - mach_port_t task, - exception_type_t exception, - exception_data_t code, - mach_msg_type_number_t codeCnt, - thread_state_flavor_t *flavor, - thread_state_t in_state, - mach_msg_type_number_t in_state_count, - thread_state_t out_state, - mach_msg_type_number_t *out_state_count); - -void mach_initialize (void); diff --git a/vmpp/mach_signal.hpp b/vm/mach_signal.hpp similarity index 100% rename from vmpp/mach_signal.hpp rename to vm/mach_signal.hpp diff --git a/vm/main-unix.c b/vm/main-unix.c deleted file mode 100644 index b177c58eb3..0000000000 --- a/vm/main-unix.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "master.h" - -int main(int argc, char **argv) -{ - start_standalone_factor(argc,argv); - return 0; -} diff --git a/vmpp/main-unix.cpp b/vm/main-unix.cpp similarity index 100% rename from vmpp/main-unix.cpp rename to vm/main-unix.cpp diff --git a/vm/main-windows-ce.c b/vm/main-windows-ce.c deleted file mode 100644 index fc04d455db..0000000000 --- a/vm/main-windows-ce.c +++ /dev/null @@ -1,134 +0,0 @@ -#include "master.h" - -/* - Windows CE argument parsing ported to work on - int main(int argc, wchar_t **argv). - - This would not be necessary if Windows CE had CommandLineToArgvW. - - Based on MinGW's public domain char** version. - -*/ - -int __argc; -wchar_t **__argv; - -static int -parse_tokens(wchar_t* string, wchar_t*** tokens, int length) -{ - /* Extract whitespace- and quotes- delimited tokens from the given string - and put them into the tokens array. Returns number of tokens - extracted. Length specifies the current size of tokens[]. - THIS METHOD MODIFIES string. */ - - const wchar_t* whitespace = L" \t\r\n"; - wchar_t* tokenEnd = 0; - const wchar_t* quoteCharacters = L"\"\'"; - wchar_t *end = string + wcslen(string); - - if (string == NULL) - return length; - - while (1) - { - const wchar_t* q; - /* Skip over initial whitespace. */ - string += wcsspn(string, whitespace); - if (*string == '\0') - break; - - for (q = quoteCharacters; *q; ++q) - { - if (*string == *q) - break; - } - if (*q) - { - /* Token is quoted. */ - wchar_t quote = *string++; - tokenEnd = wcschr(string, quote); - /* If there is no endquote, the token is the rest of the string. */ - if (!tokenEnd) - tokenEnd = end; - } - else - { - tokenEnd = string + wcscspn(string, whitespace); - } - - *tokenEnd = '\0'; - - { - wchar_t** new_tokens; - int newlen = length + 1; - new_tokens = realloc (*tokens, sizeof (wchar_t**) * newlen); - if (!new_tokens) - { - /* Out of memory. */ - return -1; - } - - *tokens = new_tokens; - (*tokens)[length] = string; - length = newlen; - } - if (tokenEnd == end) - break; - string = tokenEnd + 1; - } - return length; -} - -static void -parse_args(int *argc, wchar_t ***argv, wchar_t *cmdlinePtrW) -{ - wchar_t cmdnameBufW[MAX_UNICODE_PATH]; - int cmdlineLen = 0; - int modlen; - - /* argv[0] is the path of invoked program - get this from CE. */ - cmdnameBufW[0] = 0; - modlen = GetModuleFileNameW(NULL, cmdnameBufW, sizeof (cmdnameBufW)/sizeof (cmdnameBufW[0])); - - if (!cmdlinePtrW) - cmdlineLen = 0; - else - cmdlineLen = wcslen(cmdlinePtrW); - - /* gets realloc()'d later */ - *argv = malloc (sizeof (wchar_t**) * 1); - if (!*argv) - ExitProcess(-1); - - (*argv)[0] = wcsdup(cmdnameBufW); - if(!(*argv[0])) - ExitProcess(-1); - /* Add one to account for argv[0] */ - (*argc)++; - - if (cmdlineLen > 0) - { - wchar_t* argv1 = (*argv)[0] + wcslen((*argv)[0]) + 1; - argv1 = wcsdup(cmdlinePtrW); - if(!argv1) - ExitProcess(-1); - *argc = parse_tokens(argv1, argv, 1); - if (*argc < 0) - ExitProcess(-1); - } - (*argv)[*argc] = 0; - return; -} - -int WINAPI -WinMain( - HINSTANCE hInstance, - HINSTANCE hPrevInstance, - LPWSTR lpCmdLine, - int nCmdShow) -{ - parse_args(&__argc, &__argv, lpCmdLine); - start_standalone_factor(__argc,(LPWSTR*)__argv); - // memory leak from malloc, wcsdup - return 0; -} diff --git a/vmpp/main-windows-ce.cpp b/vm/main-windows-ce.cpp similarity index 100% rename from vmpp/main-windows-ce.cpp rename to vm/main-windows-ce.cpp diff --git a/vm/main-windows-nt.c b/vm/main-windows-nt.c deleted file mode 100755 index 6552e88bed..0000000000 --- a/vm/main-windows-nt.c +++ /dev/null @@ -1,27 +0,0 @@ -#include -#include -#include -#include "master.h" - -int WINAPI WinMain( - HINSTANCE hInstance, - HINSTANCE hPrevInstance, - LPSTR lpCmdLine, - int nCmdShow) -{ - LPWSTR *szArglist; - int nArgs; - - szArglist = CommandLineToArgvW(GetCommandLineW(), &nArgs); - if(NULL == szArglist) - { - puts("CommandLineToArgvW failed"); - return 1; - } - - start_standalone_factor(nArgs,szArglist); - - LocalFree(szArglist); - - return 0; -} diff --git a/vmpp/main-windows-nt.cpp b/vm/main-windows-nt.cpp similarity index 100% rename from vmpp/main-windows-nt.cpp rename to vm/main-windows-nt.cpp diff --git a/vm/master.h b/vm/master.h deleted file mode 100644 index 9866c4aafd..0000000000 --- a/vm/master.h +++ /dev/null @@ -1,59 +0,0 @@ -#ifndef __FACTOR_MASTER_H__ -#define __FACTOR_MASTER_H__ - -#ifndef WINCE -#include -#endif - -#ifdef FACTOR_DEBUG -#include -#endif - -#include -#include -#include -#include -#include - -#include -#include -#include -#include -#include - -#include "layouts.h" -#include "platform.h" -#include "primitives.h" -#include "run.h" -#include "profiler.h" -#include "errors.h" -#include "bignumint.h" -#include "bignum.h" -#include "write_barrier.h" -#include "data_heap.h" -#include "data_gc.h" -#include "local_roots.h" -#include "debug.h" -#include "arrays.h" -#include "strings.h" -#include "booleans.h" -#include "byte_arrays.h" -#include "tuples.h" -#include "words.h" -#include "math.h" -#include "float_bits.h" -#include "io.h" -#include "code_gc.h" -#include "code_block.h" -#include "code_heap.h" -#include "image.h" -#include "callstack.h" -#include "alien.h" -#include "quotations.h" -#include "jit.h" -#include "dispatch.h" -#include "inline_cache.h" -#include "factor.h" -#include "utilities.h" - -#endif /* __FACTOR_MASTER_H__ */ diff --git a/vmpp/master.hpp b/vm/master.hpp similarity index 100% rename from vmpp/master.hpp rename to vm/master.hpp diff --git a/vm/math.c b/vm/math.c deleted file mode 100644 index 25180abdd6..0000000000 --- a/vm/math.c +++ /dev/null @@ -1,515 +0,0 @@ -#include "master.h" - -/* Fixnums */ -F_FIXNUM to_fixnum(CELL tagged) -{ - switch(TAG(tagged)) - { - case FIXNUM_TYPE: - return untag_fixnum_fast(tagged); - case BIGNUM_TYPE: - return bignum_to_fixnum(untag_object(tagged)); - default: - type_error(FIXNUM_TYPE,tagged); - return -1; /* can't happen */ - } -} - -CELL to_cell(CELL tagged) -{ - return (CELL)to_fixnum(tagged); -} - -void primitive_bignum_to_fixnum(void) -{ - drepl(tag_fixnum(bignum_to_fixnum(untag_object(dpeek())))); -} - -void primitive_float_to_fixnum(void) -{ - drepl(tag_fixnum(float_to_fixnum(dpeek()))); -} - -/* The fixnum+, fixnum- and fixnum* primitives are defined in cpu_*.S. On -overflow, they call these functions. */ -F_FASTCALL void overflow_fixnum_add(F_FIXNUM x, F_FIXNUM y) -{ - drepl(tag_bignum(fixnum_to_bignum( - untag_fixnum_fast(x) + untag_fixnum_fast(y)))); -} - -F_FASTCALL void overflow_fixnum_subtract(F_FIXNUM x, F_FIXNUM y) -{ - drepl(tag_bignum(fixnum_to_bignum( - untag_fixnum_fast(x) - untag_fixnum_fast(y)))); -} - -F_FASTCALL void overflow_fixnum_multiply(F_FIXNUM x, F_FIXNUM y) -{ - F_ARRAY *bx = fixnum_to_bignum(x); - REGISTER_BIGNUM(bx); - F_ARRAY *by = fixnum_to_bignum(y); - UNREGISTER_BIGNUM(bx); - drepl(tag_bignum(bignum_multiply(bx,by))); -} - -/* Division can only overflow when we are dividing the most negative fixnum -by -1. */ -void primitive_fixnum_divint(void) -{ - F_FIXNUM y = untag_fixnum_fast(dpop()); \ - F_FIXNUM x = untag_fixnum_fast(dpeek()); - F_FIXNUM result = x / y; - if(result == -FIXNUM_MIN) - drepl(allot_integer(-FIXNUM_MIN)); - else - drepl(tag_fixnum(result)); -} - -void primitive_fixnum_divmod(void) -{ - F_FIXNUM y = get(ds); - F_FIXNUM x = get(ds - CELLS); - if(y == tag_fixnum(-1) && x == tag_fixnum(FIXNUM_MIN)) - { - put(ds - CELLS,allot_integer(-FIXNUM_MIN)); - put(ds,tag_fixnum(0)); - } - else - { - put(ds - CELLS,tag_fixnum(x / y)); - put(ds,x % y); - } -} - -/* - * If we're shifting right by n bits, we won't overflow as long as none of the - * high WORD_SIZE-TAG_BITS-n bits are set. - */ -#define SIGN_MASK(x) ((x) >> (WORD_SIZE - 1)) -#define BRANCHLESS_MAX(x,y) ((x) - (((x) - (y)) & SIGN_MASK((x) - (y)))) -#define BRANCHLESS_ABS(x) ((x ^ SIGN_MASK(x)) - SIGN_MASK(x)) - -void primitive_fixnum_shift(void) -{ - F_FIXNUM y = untag_fixnum_fast(dpop()); \ - F_FIXNUM x = untag_fixnum_fast(dpeek()); - - if(x == 0) - return; - else if(y < 0) - { - y = BRANCHLESS_MAX(y,-WORD_SIZE + 1); - drepl(tag_fixnum(x >> -y)); - return; - } - else if(y < WORD_SIZE - TAG_BITS) - { - F_FIXNUM mask = -((F_FIXNUM)1 << (WORD_SIZE - 1 - TAG_BITS - y)); - if(!(BRANCHLESS_ABS(x) & mask)) - { - drepl(tag_fixnum(x << y)); - return; - } - } - - drepl(tag_bignum(bignum_arithmetic_shift( - fixnum_to_bignum(x),y))); -} - -/* Bignums */ -void primitive_fixnum_to_bignum(void) -{ - drepl(tag_bignum(fixnum_to_bignum(untag_fixnum_fast(dpeek())))); -} - -void primitive_float_to_bignum(void) -{ - drepl(tag_bignum(float_to_bignum(dpeek()))); -} - -#define POP_BIGNUMS(x,y) \ - F_ARRAY *y = untag_object(dpop()); \ - F_ARRAY *x = untag_object(dpop()); - -void primitive_bignum_eq(void) -{ - POP_BIGNUMS(x,y); - box_boolean(bignum_equal_p(x,y)); -} - -void primitive_bignum_add(void) -{ - POP_BIGNUMS(x,y); - dpush(tag_bignum(bignum_add(x,y))); -} - -void primitive_bignum_subtract(void) -{ - POP_BIGNUMS(x,y); - dpush(tag_bignum(bignum_subtract(x,y))); -} - -void primitive_bignum_multiply(void) -{ - POP_BIGNUMS(x,y); - dpush(tag_bignum(bignum_multiply(x,y))); -} - -void primitive_bignum_divint(void) -{ - POP_BIGNUMS(x,y); - dpush(tag_bignum(bignum_quotient(x,y))); -} - -void primitive_bignum_divmod(void) -{ - F_ARRAY *q, *r; - POP_BIGNUMS(x,y); - bignum_divide(x,y,&q,&r); - dpush(tag_bignum(q)); - dpush(tag_bignum(r)); -} - -void primitive_bignum_mod(void) -{ - POP_BIGNUMS(x,y); - dpush(tag_bignum(bignum_remainder(x,y))); -} - -void primitive_bignum_and(void) -{ - POP_BIGNUMS(x,y); - dpush(tag_bignum(bignum_bitwise_and(x,y))); -} - -void primitive_bignum_or(void) -{ - POP_BIGNUMS(x,y); - dpush(tag_bignum(bignum_bitwise_ior(x,y))); -} - -void primitive_bignum_xor(void) -{ - POP_BIGNUMS(x,y); - dpush(tag_bignum(bignum_bitwise_xor(x,y))); -} - -void primitive_bignum_shift(void) -{ - F_FIXNUM y = untag_fixnum_fast(dpop()); - F_ARRAY* x = untag_object(dpop()); - dpush(tag_bignum(bignum_arithmetic_shift(x,y))); -} - -void primitive_bignum_less(void) -{ - POP_BIGNUMS(x,y); - box_boolean(bignum_compare(x,y) == bignum_comparison_less); -} - -void primitive_bignum_lesseq(void) -{ - POP_BIGNUMS(x,y); - box_boolean(bignum_compare(x,y) != bignum_comparison_greater); -} - -void primitive_bignum_greater(void) -{ - POP_BIGNUMS(x,y); - box_boolean(bignum_compare(x,y) == bignum_comparison_greater); -} - -void primitive_bignum_greatereq(void) -{ - POP_BIGNUMS(x,y); - box_boolean(bignum_compare(x,y) != bignum_comparison_less); -} - -void primitive_bignum_not(void) -{ - drepl(tag_bignum(bignum_bitwise_not(untag_object(dpeek())))); -} - -void primitive_bignum_bitp(void) -{ - F_FIXNUM bit = to_fixnum(dpop()); - F_ARRAY *x = untag_object(dpop()); - box_boolean(bignum_logbitp(bit,x)); -} - -void primitive_bignum_log2(void) -{ - drepl(tag_bignum(bignum_integer_length(untag_object(dpeek())))); -} - -unsigned int bignum_producer(unsigned int digit) -{ - unsigned char *ptr = alien_offset(dpeek()); - return *(ptr + digit); -} - -void primitive_byte_array_to_bignum(void) -{ - type_check(BYTE_ARRAY_TYPE,dpeek()); - CELL n_digits = array_capacity(untag_object(dpeek())); - bignum_type bignum = digit_stream_to_bignum( - n_digits,bignum_producer,0x100,0); - drepl(tag_bignum(bignum)); -} - -void box_signed_1(s8 n) -{ - dpush(tag_fixnum(n)); -} - -void box_unsigned_1(u8 n) -{ - dpush(tag_fixnum(n)); -} - -void box_signed_2(s16 n) -{ - dpush(tag_fixnum(n)); -} - -void box_unsigned_2(u16 n) -{ - dpush(tag_fixnum(n)); -} - -void box_signed_4(s32 n) -{ - dpush(allot_integer(n)); -} - -void box_unsigned_4(u32 n) -{ - dpush(allot_cell(n)); -} - -void box_signed_cell(F_FIXNUM integer) -{ - dpush(allot_integer(integer)); -} - -void box_unsigned_cell(CELL cell) -{ - dpush(allot_cell(cell)); -} - -void box_signed_8(s64 n) -{ - if(n < FIXNUM_MIN || n > FIXNUM_MAX) - dpush(tag_bignum(long_long_to_bignum(n))); - else - dpush(tag_fixnum(n)); -} - -s64 to_signed_8(CELL obj) -{ - switch(type_of(obj)) - { - case FIXNUM_TYPE: - return untag_fixnum_fast(obj); - case BIGNUM_TYPE: - return bignum_to_long_long(untag_object(obj)); - default: - type_error(BIGNUM_TYPE,obj); - return -1; - } -} - -void box_unsigned_8(u64 n) -{ - if(n > FIXNUM_MAX) - dpush(tag_bignum(ulong_long_to_bignum(n))); - else - dpush(tag_fixnum(n)); -} - -u64 to_unsigned_8(CELL obj) -{ - switch(type_of(obj)) - { - case FIXNUM_TYPE: - return untag_fixnum_fast(obj); - case BIGNUM_TYPE: - return bignum_to_ulong_long(untag_object(obj)); - default: - type_error(BIGNUM_TYPE,obj); - return -1; - } -} - -CELL unbox_array_size(void) -{ - switch(type_of(dpeek())) - { - case FIXNUM_TYPE: - { - F_FIXNUM n = untag_fixnum_fast(dpeek()); - if(n >= 0 && n < ARRAY_SIZE_MAX) - { - dpop(); - return n; - } - break; - } - case BIGNUM_TYPE: - { - bignum_type zero = untag_object(bignum_zero); - bignum_type max = cell_to_bignum(ARRAY_SIZE_MAX); - bignum_type n = untag_object(dpeek()); - if(bignum_compare(n,zero) != bignum_comparison_less - && bignum_compare(n,max) == bignum_comparison_less) - { - dpop(); - return bignum_to_cell(n); - } - break; - } - } - - general_error(ERROR_ARRAY_SIZE,dpop(),tag_fixnum(ARRAY_SIZE_MAX),NULL); - return 0; /* can't happen */ -} - -/* Floats */ -void primitive_fixnum_to_float(void) -{ - drepl(allot_float(fixnum_to_float(dpeek()))); -} - -void primitive_bignum_to_float(void) -{ - drepl(allot_float(bignum_to_float(dpeek()))); -} - -void primitive_str_to_float(void) -{ - char *c_str, *end; - double f; - F_STRING *str = untag_string(dpeek()); - CELL capacity = string_capacity(str); - - c_str = to_char_string(str,false); - end = c_str; - f = strtod(c_str,&end); - if(end != c_str + capacity) - drepl(F); - else - drepl(allot_float(f)); -} - -void primitive_float_to_str(void) -{ - char tmp[33]; - snprintf(tmp,32,"%.16g",untag_float(dpop())); - tmp[32] = '\0'; - box_char_string(tmp); -} - -#define POP_FLOATS(x,y) \ - double y = untag_float_fast(dpop()); \ - double x = untag_float_fast(dpop()); - -void primitive_float_eq(void) -{ - POP_FLOATS(x,y); - box_boolean(x == y); -} - -void primitive_float_add(void) -{ - POP_FLOATS(x,y); - box_double(x + y); -} - -void primitive_float_subtract(void) -{ - POP_FLOATS(x,y); - box_double(x - y); -} - -void primitive_float_multiply(void) -{ - POP_FLOATS(x,y); - box_double(x * y); -} - -void primitive_float_divfloat(void) -{ - POP_FLOATS(x,y); - box_double(x / y); -} - -void primitive_float_mod(void) -{ - POP_FLOATS(x,y); - box_double(fmod(x,y)); -} - -void primitive_float_less(void) -{ - POP_FLOATS(x,y); - box_boolean(x < y); -} - -void primitive_float_lesseq(void) -{ - POP_FLOATS(x,y); - box_boolean(x <= y); -} - -void primitive_float_greater(void) -{ - POP_FLOATS(x,y); - box_boolean(x > y); -} - -void primitive_float_greatereq(void) -{ - POP_FLOATS(x,y); - box_boolean(x >= y); -} - -void primitive_float_bits(void) -{ - box_unsigned_4(float_bits(untag_float(dpop()))); -} - -void primitive_bits_float(void) -{ - box_float(bits_float(to_cell(dpop()))); -} - -void primitive_double_bits(void) -{ - box_unsigned_8(double_bits(untag_float(dpop()))); -} - -void primitive_bits_double(void) -{ - box_double(bits_double(to_unsigned_8(dpop()))); -} - -float to_float(CELL value) -{ - return untag_float(value); -} - -double to_double(CELL value) -{ - return untag_float(value); -} - -void box_float(float flo) -{ - dpush(allot_float(flo)); -} - -void box_double(double flo) -{ - dpush(allot_float(flo)); -} diff --git a/vmpp/math.cpp b/vm/math.cpp similarity index 100% rename from vmpp/math.cpp rename to vm/math.cpp diff --git a/vm/math.h b/vm/math.h deleted file mode 100644 index 4a18888549..0000000000 --- a/vm/math.h +++ /dev/null @@ -1,151 +0,0 @@ -#define CELL_MAX (CELL)(-1) -#define FIXNUM_MAX (((F_FIXNUM)1 << (WORD_SIZE - TAG_BITS - 1)) - 1) -#define FIXNUM_MIN (-((F_FIXNUM)1 << (WORD_SIZE - TAG_BITS - 1))) -#define ARRAY_SIZE_MAX ((CELL)1 << (WORD_SIZE - TAG_BITS - 2)) - -DLLEXPORT F_FIXNUM to_fixnum(CELL tagged); -DLLEXPORT CELL to_cell(CELL tagged); - -void primitive_bignum_to_fixnum(void); -void primitive_float_to_fixnum(void); - -void primitive_fixnum_add(void); -void primitive_fixnum_subtract(void); -void primitive_fixnum_multiply(void); - -DLLEXPORT F_FASTCALL void overflow_fixnum_add(F_FIXNUM x, F_FIXNUM y); -DLLEXPORT F_FASTCALL void overflow_fixnum_subtract(F_FIXNUM x, F_FIXNUM y); -DLLEXPORT F_FASTCALL void overflow_fixnum_multiply(F_FIXNUM x, F_FIXNUM y); - -void primitive_fixnum_divint(void); -void primitive_fixnum_divmod(void); -void primitive_fixnum_shift(void); - -CELL bignum_zero; -CELL bignum_pos_one; -CELL bignum_neg_one; - -INLINE CELL tag_bignum(F_ARRAY* bignum) -{ - return RETAG(bignum,BIGNUM_TYPE); -} - -void primitive_fixnum_to_bignum(void); -void primitive_float_to_bignum(void); -void primitive_bignum_eq(void); -void primitive_bignum_add(void); -void primitive_bignum_subtract(void); -void primitive_bignum_multiply(void); -void primitive_bignum_divint(void); -void primitive_bignum_divmod(void); -void primitive_bignum_mod(void); -void primitive_bignum_and(void); -void primitive_bignum_or(void); -void primitive_bignum_xor(void); -void primitive_bignum_shift(void); -void primitive_bignum_less(void); -void primitive_bignum_lesseq(void); -void primitive_bignum_greater(void); -void primitive_bignum_greatereq(void); -void primitive_bignum_not(void); -void primitive_bignum_bitp(void); -void primitive_bignum_log2(void); -void primitive_byte_array_to_bignum(void); - -INLINE CELL allot_integer(F_FIXNUM x) -{ - if(x < FIXNUM_MIN || x > FIXNUM_MAX) - return tag_bignum(fixnum_to_bignum(x)); - else - return tag_fixnum(x); -} - -INLINE CELL allot_cell(CELL x) -{ - if(x > (CELL)FIXNUM_MAX) - return tag_bignum(cell_to_bignum(x)); - else - return tag_fixnum(x); -} - -/* FFI calls this */ -DLLEXPORT void box_signed_1(s8 n); -DLLEXPORT void box_unsigned_1(u8 n); -DLLEXPORT void box_signed_2(s16 n); -DLLEXPORT void box_unsigned_2(u16 n); -DLLEXPORT void box_signed_4(s32 n); -DLLEXPORT void box_unsigned_4(u32 n); -DLLEXPORT void box_signed_cell(F_FIXNUM integer); -DLLEXPORT void box_unsigned_cell(CELL cell); -DLLEXPORT void box_signed_8(s64 n); -DLLEXPORT s64 to_signed_8(CELL obj); - -DLLEXPORT void box_unsigned_8(u64 n); -DLLEXPORT u64 to_unsigned_8(CELL obj); - -CELL unbox_array_size(void); - -INLINE double untag_float_fast(CELL tagged) -{ - return ((F_FLOAT*)UNTAG(tagged))->n; -} - -INLINE double untag_float(CELL tagged) -{ - type_check(FLOAT_TYPE,tagged); - return untag_float_fast(tagged); -} - -INLINE CELL allot_float(double n) -{ - F_FLOAT* flo = allot_object(FLOAT_TYPE,sizeof(F_FLOAT)); - flo->n = n; - return RETAG(flo,FLOAT_TYPE); -} - -INLINE F_FIXNUM float_to_fixnum(CELL tagged) -{ - return (F_FIXNUM)untag_float_fast(tagged); -} - -INLINE F_ARRAY *float_to_bignum(CELL tagged) -{ - return double_to_bignum(untag_float_fast(tagged)); -} - -INLINE double fixnum_to_float(CELL tagged) -{ - return (double)untag_fixnum_fast(tagged); -} - -INLINE double bignum_to_float(CELL tagged) -{ - return bignum_to_double(untag_object(tagged)); -} - -DLLEXPORT void box_float(float flo); -DLLEXPORT float to_float(CELL value); -DLLEXPORT void box_double(double flo); -DLLEXPORT double to_double(CELL value); - -void primitive_fixnum_to_float(void); -void primitive_bignum_to_float(void); -void primitive_str_to_float(void); -void primitive_float_to_str(void); -void primitive_float_to_bits(void); - -void primitive_float_eq(void); -void primitive_float_add(void); -void primitive_float_subtract(void); -void primitive_float_multiply(void); -void primitive_float_divfloat(void); -void primitive_float_mod(void); -void primitive_float_less(void); -void primitive_float_lesseq(void); -void primitive_float_greater(void); -void primitive_float_greatereq(void); - -void primitive_float_bits(void); -void primitive_bits_float(void); -void primitive_double_bits(void); -void primitive_bits_double(void); diff --git a/vmpp/math.hpp b/vm/math.hpp similarity index 100% rename from vmpp/math.hpp rename to vm/math.hpp diff --git a/vm/os-freebsd-x86.32.h b/vm/os-freebsd-x86.32.h deleted file mode 100644 index a04755e9dd..0000000000 --- a/vm/os-freebsd-x86.32.h +++ /dev/null @@ -1,9 +0,0 @@ -#include - -INLINE void *ucontext_stack_pointer(void *uap) -{ - ucontext_t *ucontext = (ucontext_t *)uap; - return (void *)ucontext->uc_mcontext.mc_esp; -} - -#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)(ucontext))->uc_mcontext.mc_eip) diff --git a/vmpp/os-freebsd-x86.32.hpp b/vm/os-freebsd-x86.32.hpp similarity index 100% rename from vmpp/os-freebsd-x86.32.hpp rename to vm/os-freebsd-x86.32.hpp diff --git a/vm/os-freebsd-x86.64.h b/vm/os-freebsd-x86.64.h deleted file mode 100644 index 23e1ff5733..0000000000 --- a/vm/os-freebsd-x86.64.h +++ /dev/null @@ -1,9 +0,0 @@ -#include - -INLINE void *ucontext_stack_pointer(void *uap) -{ - ucontext_t *ucontext = (ucontext_t *)uap; - return (void *)ucontext->uc_mcontext.mc_rsp; -} - -#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)(ucontext))->uc_mcontext.mc_rip) diff --git a/vmpp/os-freebsd-x86.64.hpp b/vm/os-freebsd-x86.64.hpp similarity index 100% rename from vmpp/os-freebsd-x86.64.hpp rename to vm/os-freebsd-x86.64.hpp diff --git a/vm/os-freebsd.c b/vm/os-freebsd.c deleted file mode 100644 index 1d43a13001..0000000000 --- a/vm/os-freebsd.c +++ /dev/null @@ -1,34 +0,0 @@ -#include "master.h" - -/* From SBCL */ -const char *vm_executable_path(void) -{ - char path[PATH_MAX + 1]; - - if (getosreldate() >= 600024) - { - /* KERN_PROC_PATHNAME is available */ - size_t len = PATH_MAX + 1; - int mib[4]; - - mib[0] = CTL_KERN; - mib[1] = KERN_PROC; - mib[2] = KERN_PROC_PATHNAME; - mib[3] = -1; - if (sysctl(mib, 4, &path, &len, NULL, 0) != 0) - return NULL; - } - else - { - int size; - size = readlink("/proc/curproc/file", path, sizeof(path) - 1); - if (size < 0) - return NULL; - path[size] = '\0'; - } - - if(strcmp(path, "unknown") == 0) - return NULL; - - return safe_strdup(path); -} diff --git a/vmpp/os-freebsd.cpp b/vm/os-freebsd.cpp similarity index 100% rename from vmpp/os-freebsd.cpp rename to vm/os-freebsd.cpp diff --git a/vm/os-freebsd.h b/vm/os-freebsd.h deleted file mode 100644 index 617a6686c2..0000000000 --- a/vm/os-freebsd.h +++ /dev/null @@ -1,9 +0,0 @@ -#include - -extern int getosreldate(void); - -#include - -#ifndef KERN_PROC_PATHNAME -#define KERN_PROC_PATHNAME 12 -#endif diff --git a/vmpp/os-freebsd.hpp b/vm/os-freebsd.hpp similarity index 100% rename from vmpp/os-freebsd.hpp rename to vm/os-freebsd.hpp diff --git a/vm/os-genunix.c b/vm/os-genunix.c deleted file mode 100755 index f582483ce7..0000000000 --- a/vm/os-genunix.c +++ /dev/null @@ -1,35 +0,0 @@ -#include "master.h" - -void c_to_factor_toplevel(CELL quot) -{ - c_to_factor(quot); -} - -void init_signals(void) -{ - unix_init_signals(); -} - -void early_init(void) { } - -#define SUFFIX ".image" -#define SUFFIX_LEN 6 - -const char *default_image_path(void) -{ - const char *path = vm_executable_path(); - - if(!path) - return "factor.image"; - - /* We can't call strlen() here because with gcc 4.1.2 this - causes an internal compiler error. */ - int len = 0; - const char *iter = path; - while(*iter) { len++; iter++; } - - char *new_path = safe_malloc(PATH_MAX + SUFFIX_LEN + 1); - memcpy(new_path,path,len + 1); - memcpy(new_path + len,SUFFIX,SUFFIX_LEN + 1); - return new_path; -} diff --git a/vmpp/os-genunix.cpp b/vm/os-genunix.cpp similarity index 100% rename from vmpp/os-genunix.cpp rename to vm/os-genunix.cpp diff --git a/vm/os-genunix.h b/vm/os-genunix.h deleted file mode 100644 index 7afc68998d..0000000000 --- a/vm/os-genunix.h +++ /dev/null @@ -1,8 +0,0 @@ -#define DLLEXPORT -#define NULL_DLL NULL - -void c_to_factor_toplevel(CELL quot); -void init_signals(void); -void early_init(void); -const char *vm_executable_path(void); -const char *default_image_path(void); diff --git a/vmpp/os-genunix.hpp b/vm/os-genunix.hpp similarity index 100% rename from vmpp/os-genunix.hpp rename to vm/os-genunix.hpp diff --git a/vm/os-linux-arm.c b/vm/os-linux-arm.c deleted file mode 100644 index 39a3da0b3f..0000000000 --- a/vm/os-linux-arm.c +++ /dev/null @@ -1,26 +0,0 @@ -#include "master.h" - -void flush_icache(CELL start, CELL len) -{ - int result; - - /* XXX: why doesn't this work on Nokia n800? It should behave - identically to the below assembly. */ - /* result = syscall(__ARM_NR_cacheflush,start,start + len,0); */ - - /* Assembly swiped from - http://lists.arm.linux.org.uk/pipermail/linux-arm/2002-July/003931.html - */ - __asm__ __volatile__ ( - "mov r0, %1\n" - "sub r1, %2, #1\n" - "mov r2, #0\n" - "swi " __sys1(__ARM_NR_cacheflush) "\n" - "mov %0, r0\n" - : "=r" (result) - : "r" (start), "r" (start + len) - : "r0","r1","r2"); - - if(result < 0) - critical_error("flush_icache() failed",result); -} diff --git a/vmpp/os-linux-arm.cpp b/vm/os-linux-arm.cpp similarity index 100% rename from vmpp/os-linux-arm.cpp rename to vm/os-linux-arm.cpp diff --git a/vm/os-linux-arm.h b/vm/os-linux-arm.h deleted file mode 100644 index 6e078b014d..0000000000 --- a/vm/os-linux-arm.h +++ /dev/null @@ -1,14 +0,0 @@ -#include -#include -#include - -INLINE void *ucontext_stack_pointer(void *uap) -{ - ucontext_t *ucontext = (ucontext_t *)uap; - return (void *)ucontext->uc_mcontext.arm_sp; -} - -#define UAP_PROGRAM_COUNTER(ucontext) \ - (((ucontext_t *)(ucontext))->uc_mcontext.arm_pc) - -void flush_icache(CELL start, CELL len); diff --git a/vmpp/os-linux-arm.hpp b/vm/os-linux-arm.hpp similarity index 100% rename from vmpp/os-linux-arm.hpp rename to vm/os-linux-arm.hpp diff --git a/vm/os-linux-ppc.h b/vm/os-linux-ppc.h deleted file mode 100644 index eb28af53e4..0000000000 --- a/vm/os-linux-ppc.h +++ /dev/null @@ -1,12 +0,0 @@ -#include - -#define FRAME_RETURN_ADDRESS(frame) *((XT *)(frame_successor(frame) + 1) + 1) - -INLINE void *ucontext_stack_pointer(void *uap) -{ - ucontext_t *ucontext = (ucontext_t *)uap; - return (void *)ucontext->uc_mcontext.uc_regs->gregs[PT_R1]; -} - -#define UAP_PROGRAM_COUNTER(ucontext) \ - (((ucontext_t *)(ucontext))->uc_mcontext.uc_regs->gregs[PT_NIP]) diff --git a/vmpp/os-linux-ppc.hpp b/vm/os-linux-ppc.hpp similarity index 100% rename from vmpp/os-linux-ppc.hpp rename to vm/os-linux-ppc.hpp diff --git a/vm/os-linux-x86.32.h b/vm/os-linux-x86.32.h deleted file mode 100644 index b458fcbe21..0000000000 --- a/vm/os-linux-x86.32.h +++ /dev/null @@ -1,10 +0,0 @@ -#include - -INLINE void *ucontext_stack_pointer(void *uap) -{ - ucontext_t *ucontext = (ucontext_t *)uap; - return (void *)ucontext->uc_mcontext.gregs[7]; -} - -#define UAP_PROGRAM_COUNTER(ucontext) \ - (((ucontext_t *)(ucontext))->uc_mcontext.gregs[14]) diff --git a/vmpp/os-linux-x86.32.hpp b/vm/os-linux-x86.32.hpp similarity index 100% rename from vmpp/os-linux-x86.32.hpp rename to vm/os-linux-x86.32.hpp diff --git a/vm/os-linux-x86.64.h b/vm/os-linux-x86.64.h deleted file mode 100644 index 911c2f1749..0000000000 --- a/vm/os-linux-x86.64.h +++ /dev/null @@ -1,10 +0,0 @@ -#include - -INLINE void *ucontext_stack_pointer(void *uap) -{ - ucontext_t *ucontext = (ucontext_t *)uap; - return (void *)ucontext->uc_mcontext.gregs[15]; -} - -#define UAP_PROGRAM_COUNTER(ucontext) \ - (((ucontext_t *)(ucontext))->uc_mcontext.gregs[16]) diff --git a/vmpp/os-linux-x86.64.hpp b/vm/os-linux-x86.64.hpp similarity index 100% rename from vmpp/os-linux-x86.64.hpp rename to vm/os-linux-x86.64.hpp diff --git a/vm/os-linux.c b/vm/os-linux.c deleted file mode 100644 index 91017fc3f8..0000000000 --- a/vm/os-linux.c +++ /dev/null @@ -1,58 +0,0 @@ -#include "master.h" - -/* Snarfed from SBCL linux-so.c. You must free() this yourself. */ -const char *vm_executable_path(void) -{ - char *path = safe_malloc(PATH_MAX + 1); - - int size = readlink("/proc/self/exe", path, PATH_MAX); - if (size < 0) - { - fatal_error("Cannot read /proc/self/exe",0); - return NULL; - } - else - { - path[size] = '\0'; - return safe_strdup(path); - } -} - -#ifdef SYS_inotify_init - -int inotify_init(void) -{ - return syscall(SYS_inotify_init); -} - -int inotify_add_watch(int fd, const char *name, u32 mask) -{ - return syscall(SYS_inotify_add_watch, fd, name, mask); -} - -int inotify_rm_watch(int fd, u32 wd) -{ - return syscall(SYS_inotify_rm_watch, fd, wd); -} - -#else - -int inotify_init(void) -{ - not_implemented_error(); - return -1; -} - -int inotify_add_watch(int fd, const char *name, u32 mask) -{ - not_implemented_error(); - return -1; -} - -int inotify_rm_watch(int fd, u32 wd) -{ - not_implemented_error(); - return -1; -} - -#endif diff --git a/vmpp/os-linux.cpp b/vm/os-linux.cpp similarity index 100% rename from vmpp/os-linux.cpp rename to vm/os-linux.cpp diff --git a/vm/os-linux.h b/vm/os-linux.h deleted file mode 100644 index 8e78595687..0000000000 --- a/vm/os-linux.h +++ /dev/null @@ -1,5 +0,0 @@ -#include - -int inotify_init(void); -int inotify_add_watch(int fd, const char *name, u32 mask); -int inotify_rm_watch(int fd, u32 wd); diff --git a/vmpp/os-linux.hpp b/vm/os-linux.hpp similarity index 100% rename from vmpp/os-linux.hpp rename to vm/os-linux.hpp diff --git a/vm/os-macosx-ppc.h b/vm/os-macosx-ppc.h deleted file mode 100644 index 13213acbbc..0000000000 --- a/vm/os-macosx-ppc.h +++ /dev/null @@ -1,39 +0,0 @@ -/* Fault handler information. MacOSX version. -Copyright (C) 1993-1999, 2002-2003 Bruno Haible -Copyright (C) 2003 Paolo Bonzini - -Used under BSD license with permission from Paolo Bonzini and Bruno Haible, -2005-03-10: - -http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org - -Modified for Factor by Slava Pestov */ -#include - -#define FRAME_RETURN_ADDRESS(frame) *((XT *)(frame_successor(frame) + 1) + 2) - -#define MACH_EXC_STATE_TYPE ppc_exception_state_t -#define MACH_EXC_STATE_FLAVOR PPC_EXCEPTION_STATE -#define MACH_EXC_STATE_COUNT PPC_EXCEPTION_STATE_COUNT -#define MACH_THREAD_STATE_TYPE ppc_thread_state_t -#define MACH_THREAD_STATE_FLAVOR PPC_THREAD_STATE -#define MACH_THREAD_STATE_COUNT PPC_THREAD_STATE_COUNT - -#if __DARWIN_UNIX03 - #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__dar - #define MACH_STACK_POINTER(thr_state) (thr_state)->__r1 - #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__srr0 - #define UAP_PROGRAM_COUNTER(ucontext) \ - MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->__ss)) -#else - #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->dar - #define MACH_STACK_POINTER(thr_state) (thr_state)->r1 - #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->srr0 - #define UAP_PROGRAM_COUNTER(ucontext) \ - MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss)) -#endif - -INLINE CELL fix_stack_pointer(CELL sp) -{ - return sp; -} diff --git a/vmpp/os-macosx-ppc.hpp b/vm/os-macosx-ppc.hpp similarity index 100% rename from vmpp/os-macosx-ppc.hpp rename to vm/os-macosx-ppc.hpp diff --git a/vm/os-macosx-x86.32.h b/vm/os-macosx-x86.32.h deleted file mode 100644 index 7c830c775d..0000000000 --- a/vm/os-macosx-x86.32.h +++ /dev/null @@ -1,37 +0,0 @@ -/* Fault handler information. MacOSX version. -Copyright (C) 1993-1999, 2002-2003 Bruno Haible -Copyright (C) 2003 Paolo Bonzini - -Used under BSD license with permission from Paolo Bonzini and Bruno Haible, -2005-03-10: - -http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org - -Modified for Factor by Slava Pestov */ -#include - -#define MACH_EXC_STATE_TYPE i386_exception_state_t -#define MACH_EXC_STATE_FLAVOR i386_EXCEPTION_STATE -#define MACH_EXC_STATE_COUNT i386_EXCEPTION_STATE_COUNT -#define MACH_THREAD_STATE_TYPE i386_thread_state_t -#define MACH_THREAD_STATE_FLAVOR i386_THREAD_STATE -#define MACH_THREAD_STATE_COUNT i386_THREAD_STATE_COUNT - -#if __DARWIN_UNIX03 - #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__faultvaddr - #define MACH_STACK_POINTER(thr_state) (thr_state)->__esp - #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__eip - #define UAP_PROGRAM_COUNTER(ucontext) \ - MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->__ss)) -#else - #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->faultvaddr - #define MACH_STACK_POINTER(thr_state) (thr_state)->esp - #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->eip - #define UAP_PROGRAM_COUNTER(ucontext) \ - MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss)) -#endif - -INLINE CELL fix_stack_pointer(CELL sp) -{ - return ((sp + 4) & ~15) - 4; -} diff --git a/vmpp/os-macosx-x86.32.hpp b/vm/os-macosx-x86.32.hpp similarity index 100% rename from vmpp/os-macosx-x86.32.hpp rename to vm/os-macosx-x86.32.hpp diff --git a/vm/os-macosx-x86.64.h b/vm/os-macosx-x86.64.h deleted file mode 100644 index b11aa80ce8..0000000000 --- a/vm/os-macosx-x86.64.h +++ /dev/null @@ -1,37 +0,0 @@ -/* Fault handler information. MacOSX version. -Copyright (C) 1993-1999, 2002-2003 Bruno Haible -Copyright (C) 2003 Paolo Bonzini - -Used under BSD license with permission from Paolo Bonzini and Bruno Haible, -2005-03-10: - -http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org - -Modified for Factor by Slava Pestov and Daniel Ehrenberg */ -#include - -#define MACH_EXC_STATE_TYPE x86_exception_state64_t -#define MACH_EXC_STATE_FLAVOR x86_EXCEPTION_STATE64 -#define MACH_EXC_STATE_COUNT x86_EXCEPTION_STATE64_COUNT -#define MACH_THREAD_STATE_TYPE x86_thread_state64_t -#define MACH_THREAD_STATE_FLAVOR x86_THREAD_STATE64 -#define MACH_THREAD_STATE_COUNT MACHINE_THREAD_STATE_COUNT - -#if __DARWIN_UNIX03 - #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__faultvaddr - #define MACH_STACK_POINTER(thr_state) (thr_state)->__rsp - #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__rip - #define UAP_PROGRAM_COUNTER(ucontext) \ - MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->__ss)) -#else - #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->faultvaddr - #define MACH_STACK_POINTER(thr_state) (thr_state)->rsp - #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->rip - #define UAP_PROGRAM_COUNTER(ucontext) \ - MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss)) -#endif - -INLINE CELL fix_stack_pointer(CELL sp) -{ - return ((sp + 8) & ~15) - 8; -} diff --git a/vmpp/os-macosx-x86.64.hpp b/vm/os-macosx-x86.64.hpp similarity index 100% rename from vmpp/os-macosx-x86.64.hpp rename to vm/os-macosx-x86.64.hpp diff --git a/vm/os-macosx.h b/vm/os-macosx.h deleted file mode 100644 index 216212e973..0000000000 --- a/vm/os-macosx.h +++ /dev/null @@ -1,17 +0,0 @@ -#define DLLEXPORT __attribute__((visibility("default"))) -#define FACTOR_OS_STRING "macosx" -#define NULL_DLL "libfactor.dylib" - -void init_signals(void); -void early_init(void); - -const char *vm_executable_path(void); -const char *default_image_path(void); - -DLLEXPORT void c_to_factor_toplevel(CELL quot); - -INLINE void *ucontext_stack_pointer(void *uap) -{ - ucontext_t *ucontext = (ucontext_t *)uap; - return ucontext->uc_stack.ss_sp; -} diff --git a/vmpp/os-macosx.hpp b/vm/os-macosx.hpp similarity index 100% rename from vmpp/os-macosx.hpp rename to vm/os-macosx.hpp diff --git a/vm/os-macosx.m b/vm/os-macosx.m deleted file mode 100644 index 9b0366ff75..0000000000 --- a/vm/os-macosx.m +++ /dev/null @@ -1,82 +0,0 @@ -#import - -#include "master.h" - -void c_to_factor_toplevel(CELL quot) -{ - for(;;) - { -NS_DURING - c_to_factor(quot); - NS_VOIDRETURN; -NS_HANDLER - dpush(allot_alien(F,(CELL)localException)); - quot = userenv[COCOA_EXCEPTION_ENV]; - if(type_of(quot) != QUOTATION_TYPE) - { - /* No Cocoa exception handler was registered, so - extra/cocoa/ is not loaded. So we pass the exception - along. */ - [localException raise]; - } -NS_ENDHANDLER - } -} - -void early_init(void) -{ - SInt32 version; - Gestalt(gestaltSystemVersion,&version); - if(version <= 0x1050) - { - printf("Factor requires Mac OS X 10.5 or later.\n"); - exit(1); - } - - [[NSAutoreleasePool alloc] init]; -} - -const char *vm_executable_path(void) -{ - return [[[NSBundle mainBundle] executablePath] UTF8String]; -} - -const char *default_image_path(void) -{ - NSBundle *bundle = [NSBundle mainBundle]; - NSString *path = [bundle bundlePath]; - NSString *executable = [[bundle executablePath] lastPathComponent]; - NSString *image = [executable stringByAppendingString:@".image"]; - - NSString *returnVal; - - if([path hasSuffix:@".app"] || [path hasSuffix:@".app/"]) - { - NSFileManager *mgr = [NSFileManager defaultManager]; - - NSString *imageInBundle = [[path stringByAppendingPathComponent:@"Contents/Resources"] stringByAppendingPathComponent:image]; - NSString *imageAlongBundle = [[path stringByDeletingLastPathComponent] stringByAppendingPathComponent:image]; - - returnVal = ([mgr fileExistsAtPath:imageInBundle] - ? imageInBundle : imageAlongBundle); - } - else - returnVal = [path stringByAppendingPathComponent:image]; - - return [returnVal UTF8String]; -} - -void init_signals(void) -{ - unix_init_signals(); - mach_initialize(); -} - -/* Amateurs at Apple: implement this function, properly! */ -Protocol *objc_getProtocol(char *name) -{ - if(strcmp(name,"NSTextInput") == 0) - return @protocol(NSTextInput); - else - return nil; -} diff --git a/vmpp/os-macosx.mm b/vm/os-macosx.mm similarity index 100% rename from vmpp/os-macosx.mm rename to vm/os-macosx.mm diff --git a/vm/os-netbsd-x86.32.h b/vm/os-netbsd-x86.32.h deleted file mode 100644 index ca4a9f88f5..0000000000 --- a/vm/os-netbsd-x86.32.h +++ /dev/null @@ -1,3 +0,0 @@ -#include - -#define ucontext_stack_pointer(uap) ((void *)_UC_MACHINE_SP((ucontext_t *)uap)) diff --git a/vmpp/os-netbsd-x86.32.hpp b/vm/os-netbsd-x86.32.hpp similarity index 100% rename from vmpp/os-netbsd-x86.32.hpp rename to vm/os-netbsd-x86.32.hpp diff --git a/vm/os-netbsd-x86.64.h b/vm/os-netbsd-x86.64.h deleted file mode 100644 index 587dc85ec7..0000000000 --- a/vm/os-netbsd-x86.64.h +++ /dev/null @@ -1,4 +0,0 @@ -#include - -#define ucontext_stack_pointer(uap) \ - ((void *)(((ucontext_t *)(uap))->uc_mcontext.__gregs[_REG_URSP])) diff --git a/vmpp/os-netbsd-x86.64.hpp b/vm/os-netbsd-x86.64.hpp similarity index 100% rename from vmpp/os-netbsd-x86.64.hpp rename to vm/os-netbsd-x86.64.hpp diff --git a/vm/os-netbsd.c b/vm/os-netbsd.c deleted file mode 100755 index c33b4ad69c..0000000000 --- a/vm/os-netbsd.c +++ /dev/null @@ -1,11 +0,0 @@ -#include "master.h" - -extern int main(); - -const char *vm_executable_path(void) -{ - static Dl_info info = {0}; - if (!info.dli_fname) - dladdr(main, &info); - return info.dli_fname; -} diff --git a/vmpp/os-netbsd.cpp b/vm/os-netbsd.cpp similarity index 100% rename from vmpp/os-netbsd.cpp rename to vm/os-netbsd.cpp diff --git a/vm/os-netbsd.h b/vm/os-netbsd.h deleted file mode 100644 index 6486acda4a..0000000000 --- a/vm/os-netbsd.h +++ /dev/null @@ -1,5 +0,0 @@ -#include - -#define UAP_PROGRAM_COUNTER(uap) _UC_MACHINE_PC((ucontext_t *)uap) - -#define DIRECTORY_P(file) ((file)->d_type == DT_DIR) diff --git a/vmpp/os-netbsd.hpp b/vm/os-netbsd.hpp similarity index 100% rename from vmpp/os-netbsd.hpp rename to vm/os-netbsd.hpp diff --git a/vm/os-openbsd-x86.32.h b/vm/os-openbsd-x86.32.h deleted file mode 100644 index 0617e62c0d..0000000000 --- a/vm/os-openbsd-x86.32.h +++ /dev/null @@ -1,10 +0,0 @@ -#include - -INLINE void *openbsd_stack_pointer(void *uap) -{ - struct sigcontext *sc = (struct sigcontext*) uap; - return (void *)sc->sc_esp; -} - -#define ucontext_stack_pointer openbsd_stack_pointer -#define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_eip) diff --git a/vmpp/os-openbsd-x86.32.hpp b/vm/os-openbsd-x86.32.hpp similarity index 100% rename from vmpp/os-openbsd-x86.32.hpp rename to vm/os-openbsd-x86.32.hpp diff --git a/vm/os-openbsd-x86.64.h b/vm/os-openbsd-x86.64.h deleted file mode 100644 index 3386e80a4b..0000000000 --- a/vm/os-openbsd-x86.64.h +++ /dev/null @@ -1,10 +0,0 @@ -#include - -INLINE void *openbsd_stack_pointer(void *uap) -{ - struct sigcontext *sc = (struct sigcontext*) uap; - return (void *)sc->sc_rsp; -} - -#define ucontext_stack_pointer openbsd_stack_pointer -#define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_rip) diff --git a/vmpp/os-openbsd-x86.64.hpp b/vm/os-openbsd-x86.64.hpp similarity index 100% rename from vmpp/os-openbsd-x86.64.hpp rename to vm/os-openbsd-x86.64.hpp diff --git a/vm/os-openbsd.c b/vm/os-openbsd.c deleted file mode 100644 index b9238b7877..0000000000 --- a/vm/os-openbsd.c +++ /dev/null @@ -1,6 +0,0 @@ -#include "master.h" - -const char *vm_executable_path(void) -{ - return NULL; -} diff --git a/vmpp/os-openbsd.cpp b/vm/os-openbsd.cpp similarity index 100% rename from vmpp/os-openbsd.cpp rename to vm/os-openbsd.cpp diff --git a/vm/os-solaris-x86.32.h b/vm/os-solaris-x86.32.h deleted file mode 100644 index 1f4ec74e17..0000000000 --- a/vm/os-solaris-x86.32.h +++ /dev/null @@ -1,10 +0,0 @@ -#include - -INLINE void *ucontext_stack_pointer(void *uap) -{ - ucontext_t *ucontext = (ucontext_t *)uap; - return (void *)ucontext->uc_mcontext.gregs[ESP]; -} - -#define UAP_PROGRAM_COUNTER(ucontext) \ - (((ucontext_t *)(ucontext))->uc_mcontext.gregs[EIP]) diff --git a/vmpp/os-solaris-x86.32.hpp b/vm/os-solaris-x86.32.hpp similarity index 100% rename from vmpp/os-solaris-x86.32.hpp rename to vm/os-solaris-x86.32.hpp diff --git a/vm/os-solaris-x86.64.h b/vm/os-solaris-x86.64.h deleted file mode 100644 index 54d1866d50..0000000000 --- a/vm/os-solaris-x86.64.h +++ /dev/null @@ -1,10 +0,0 @@ -#include - -INLINE void *ucontext_stack_pointer(void *uap) -{ - ucontext_t *ucontext = (ucontext_t *)uap; - return (void *)ucontext->uc_mcontext.gregs[RSP]; -} - -#define UAP_PROGRAM_COUNTER(ucontext) \ - (((ucontext_t *)(ucontext))->uc_mcontext.gregs[RIP]) diff --git a/vmpp/os-solaris-x86.64.hpp b/vm/os-solaris-x86.64.hpp similarity index 100% rename from vmpp/os-solaris-x86.64.hpp rename to vm/os-solaris-x86.64.hpp diff --git a/vm/os-solaris.c b/vm/os-solaris.c deleted file mode 100644 index b9238b7877..0000000000 --- a/vm/os-solaris.c +++ /dev/null @@ -1,6 +0,0 @@ -#include "master.h" - -const char *vm_executable_path(void) -{ - return NULL; -} diff --git a/vmpp/os-solaris.cpp b/vm/os-solaris.cpp similarity index 100% rename from vmpp/os-solaris.cpp rename to vm/os-solaris.cpp diff --git a/vm/os-unix.c b/vm/os-unix.c deleted file mode 100755 index 97c29d8c6e..0000000000 --- a/vm/os-unix.c +++ /dev/null @@ -1,313 +0,0 @@ -#include "master.h" - -void start_thread(void *(*start_routine)(void *)) -{ - pthread_attr_t attr; - pthread_t thread; - - if (pthread_attr_init (&attr) != 0) - fatal_error("pthread_attr_init() failed",0); - if (pthread_attr_setdetachstate (&attr, PTHREAD_CREATE_DETACHED) != 0) - fatal_error("pthread_attr_setdetachstate() failed",0); - if (pthread_create (&thread, &attr, start_routine, NULL) != 0) - fatal_error("pthread_create() failed",0); - pthread_attr_destroy (&attr); -} - -static void *null_dll; - -s64 current_micros(void) -{ - struct timeval t; - gettimeofday(&t,NULL); - return (s64)t.tv_sec * 1000000 + t.tv_usec; -} - -void sleep_micros(CELL usec) -{ - usleep(usec); -} - -void init_ffi(void) -{ - /* NULL_DLL is "libfactor.dylib" for OS X and NULL for generic unix */ - null_dll = dlopen(NULL_DLL,RTLD_LAZY); -} - -void ffi_dlopen(F_DLL *dll) -{ - dll->dll = dlopen(alien_offset(dll->path), RTLD_LAZY); -} - -void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol) -{ - void *handle = (dll == NULL ? null_dll : dll->dll); - return dlsym(handle,symbol); -} - -void ffi_dlclose(F_DLL *dll) -{ - if(dlclose(dll->dll)) - { - general_error(ERROR_FFI,tag_object( - from_char_string(dlerror())),F,NULL); - } - dll->dll = NULL; -} - -void primitive_existsp(void) -{ - struct stat sb; - box_boolean(stat(unbox_char_string(),&sb) >= 0); -} - -F_SEGMENT *alloc_segment(CELL size) -{ - int pagesize = getpagesize(); - - char *array = mmap(NULL,pagesize + size + pagesize, - PROT_READ | PROT_WRITE | PROT_EXEC, - MAP_ANON | MAP_PRIVATE,-1,0); - - if(array == (char*)-1) - out_of_memory(); - - if(mprotect(array,pagesize,PROT_NONE) == -1) - fatal_error("Cannot protect low guard page",(CELL)array); - - if(mprotect(array + pagesize + size,pagesize,PROT_NONE) == -1) - fatal_error("Cannot protect high guard page",(CELL)array); - - F_SEGMENT *retval = safe_malloc(sizeof(F_SEGMENT)); - - retval->start = (CELL)(array + pagesize); - retval->size = size; - retval->end = retval->start + size; - - return retval; -} - -void dealloc_segment(F_SEGMENT *block) -{ - int pagesize = getpagesize(); - - int retval = munmap((void*)(block->start - pagesize), - pagesize + block->size + pagesize); - - if(retval) - fatal_error("dealloc_segment failed",0); - - free(block); -} - -INLINE F_STACK_FRAME *uap_stack_pointer(void *uap) -{ - /* There is a race condition here, but in practice a signal - delivered during stack frame setup/teardown or while transitioning - from Factor to C is a sign of things seriously gone wrong, not just - a divide by zero or stack underflow in the listener */ - if(in_code_heap_p(UAP_PROGRAM_COUNTER(uap))) - { - F_STACK_FRAME *ptr = ucontext_stack_pointer(uap); - if(!ptr) - critical_error("Invalid uap",(CELL)uap); - return ptr; - } - else - return NULL; -} - -void memory_signal_handler(int signal, siginfo_t *siginfo, void *uap) -{ - signal_fault_addr = (CELL)siginfo->si_addr; - signal_callstack_top = uap_stack_pointer(uap); - UAP_PROGRAM_COUNTER(uap) = (CELL)memory_signal_handler_impl; -} - -void misc_signal_handler(int signal, siginfo_t *siginfo, void *uap) -{ - signal_number = signal; - signal_callstack_top = uap_stack_pointer(uap); - UAP_PROGRAM_COUNTER(uap) = (CELL)misc_signal_handler_impl; -} - -static void sigaction_safe(int signum, const struct sigaction *act, struct sigaction *oldact) -{ - int ret; - do - { - ret = sigaction(signum, act, oldact); - } - while(ret == -1 && errno == EINTR); - - if(ret == -1) - fatal_error("sigaction failed", 0); -} - -void unix_init_signals(void) -{ - struct sigaction memory_sigaction; - struct sigaction misc_sigaction; - struct sigaction ignore_sigaction; - - memset(&memory_sigaction,0,sizeof(struct sigaction)); - sigemptyset(&memory_sigaction.sa_mask); - memory_sigaction.sa_sigaction = memory_signal_handler; - memory_sigaction.sa_flags = SA_SIGINFO; - - sigaction_safe(SIGBUS,&memory_sigaction,NULL); - sigaction_safe(SIGSEGV,&memory_sigaction,NULL); - - memset(&misc_sigaction,0,sizeof(struct sigaction)); - sigemptyset(&misc_sigaction.sa_mask); - misc_sigaction.sa_sigaction = misc_signal_handler; - misc_sigaction.sa_flags = SA_SIGINFO; - - sigaction_safe(SIGABRT,&misc_sigaction,NULL); - sigaction_safe(SIGFPE,&misc_sigaction,NULL); - sigaction_safe(SIGQUIT,&misc_sigaction,NULL); - sigaction_safe(SIGILL,&misc_sigaction,NULL); - - memset(&ignore_sigaction,0,sizeof(struct sigaction)); - sigemptyset(&ignore_sigaction.sa_mask); - ignore_sigaction.sa_handler = SIG_IGN; - sigaction_safe(SIGPIPE,&ignore_sigaction,NULL); -} - -/* On Unix, shared fds such as stdin cannot be set to non-blocking mode -(http://homepages.tesco.net/J.deBoynePollard/FGA/dont-set-shared-file-descriptors-to-non-blocking-mode.html) -so we kludge around this by spawning a thread, which waits on a control pipe -for a signal, upon receiving this signal it reads one block of data from stdin -and writes it to a data pipe. Upon completion, it writes a 4-byte integer to -the size pipe, indicating how much data was written to the data pipe. - -The read end of the size pipe can be set to non-blocking. */ -__attribute__((visibility("default"))) int stdin_read; -__attribute__((visibility("default"))) int stdin_write; - -__attribute__((visibility("default"))) int control_read; -__attribute__((visibility("default"))) int control_write; - -__attribute__((visibility("default"))) int size_read; -__attribute__((visibility("default"))) int size_write; - -void safe_close(int fd) -{ - if(close(fd) < 0) - fatal_error("error closing fd",errno); -} - -bool check_write(int fd, void *data, size_t size) -{ - if(write(fd,data,size) == size) - return true; - else - { - if(errno == EINTR) - return check_write(fd,data,size); - else - return false; - } -} - -void safe_write(int fd, void *data, size_t size) -{ - if(!check_write(fd,data,size)) - fatal_error("error writing fd",errno); -} - -bool safe_read(int fd, void *data, size_t size) -{ - ssize_t bytes = read(fd,data,size); - if(bytes < 0) - { - if(errno == EINTR) - return safe_read(fd,data,size); - else - { - fatal_error("error reading fd",errno); - return false; - } - } - else - return (bytes == size); -} - -void *stdin_loop(void *arg) -{ - unsigned char buf[4096]; - bool loop_running = true; - - while(loop_running) - { - if(!safe_read(control_read,buf,1)) - break; - - if(buf[0] != 'X') - fatal_error("stdin_loop: bad data on control fd",buf[0]); - - for(;;) - { - ssize_t bytes = read(0,buf,sizeof(buf)); - if(bytes < 0) - { - if(errno == EINTR) - continue; - else - { - loop_running = false; - break; - } - } - else if(bytes >= 0) - { - safe_write(size_write,&bytes,sizeof(bytes)); - - if(!check_write(stdin_write,buf,bytes)) - loop_running = false; - break; - } - } - } - - safe_close(stdin_write); - safe_close(control_read); - - return NULL; -} - -void open_console(void) -{ - int filedes[2]; - - if(pipe(filedes) < 0) - fatal_error("Error opening control pipe",errno); - - control_read = filedes[0]; - control_write = filedes[1]; - - if(pipe(filedes) < 0) - fatal_error("Error opening size pipe",errno); - - size_read = filedes[0]; - size_write = filedes[1]; - - if(pipe(filedes) < 0) - fatal_error("Error opening stdin pipe",errno); - - stdin_read = filedes[0]; - stdin_write = filedes[1]; - - start_thread(stdin_loop); -} - -DLLEXPORT void wait_for_stdin(void) -{ - if(write(control_write,"X",1) != 1) - { - if(errno == EINTR) - wait_for_stdin(); - else - fatal_error("Error writing control fd",errno); - } -} diff --git a/vmpp/os-unix.cpp b/vm/os-unix.cpp similarity index 100% rename from vmpp/os-unix.cpp rename to vm/os-unix.cpp diff --git a/vm/os-unix.h b/vm/os-unix.h deleted file mode 100755 index 35abfee41c..0000000000 --- a/vm/os-unix.h +++ /dev/null @@ -1,59 +0,0 @@ -#include -#include -#include -#include -#include -#include -#include -#include -#include - -typedef char F_CHAR; -typedef char F_SYMBOL; - -#define from_native_string from_char_string -#define unbox_native_string unbox_char_string -#define string_to_native_alien(string) string_to_char_alien(string,true) -#define unbox_symbol_string unbox_char_string - -#define STRING_LITERAL(string) string - -#define SSCANF sscanf -#define STRCMP strcmp -#define STRNCMP strncmp -#define STRDUP strdup - -#define FSEEK fseeko - -#define FIXNUM_FORMAT "%ld" -#define CELL_FORMAT "%lu" -#define CELL_HEX_FORMAT "%lx" - -#ifdef FACTOR_64 - #define CELL_HEX_PAD_FORMAT "%016lx" -#else - #define CELL_HEX_PAD_FORMAT "%08lx" -#endif - -#define FIXNUM_FORMAT "%ld" - -#define OPEN_READ(path) fopen(path,"rb") -#define OPEN_WRITE(path) fopen(path,"wb") - -#define print_native_string(string) print_string(string) - -void start_thread(void *(*start_routine)(void *)); - -void init_ffi(void); -void ffi_dlopen(F_DLL *dll); -void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol); -void ffi_dlclose(F_DLL *dll); - -void unix_init_signals(void); -void signal_handler(int signal, siginfo_t* siginfo, void* uap); -void dump_stack_signal(int signal, siginfo_t* siginfo, void* uap); - -s64 current_micros(void); -void sleep_micros(CELL usec); - -void open_console(void); diff --git a/vmpp/os-unix.hpp b/vm/os-unix.hpp similarity index 100% rename from vmpp/os-unix.hpp rename to vm/os-unix.hpp diff --git a/vm/os-windows-ce.c b/vm/os-windows-ce.c deleted file mode 100755 index 621198ff7d..0000000000 --- a/vm/os-windows-ce.c +++ /dev/null @@ -1,40 +0,0 @@ -#include "master.h" - -s64 current_micros(void) -{ - SYSTEMTIME st; - FILETIME ft; - GetSystemTime(&st); - SystemTimeToFileTime(&st, &ft); - return (((s64)ft.dwLowDateTime - | (s64)ft.dwHighDateTime<<32) - EPOCH_OFFSET) / 10; -} - -char *strerror(int err) -{ - /* strerror() is not defined on WinCE */ - return "strerror() is not defined on WinCE. Use native I/O."; -} - -void flush_icache(CELL start, CELL end) -{ - FlushInstructionCache(GetCurrentProcess(), 0, 0); -} - -char *getenv(char *name) -{ - not_implemented_error(); - return 0; /* unreachable */ -} - -void primitive_os_envs(void) -{ - not_implemented_error(); -} - -void c_to_factor_toplevel(CELL quot) -{ - c_to_factor(quot); -} - -void open_console(void) { } diff --git a/vmpp/os-windows-ce.cpp b/vm/os-windows-ce.cpp similarity index 100% rename from vmpp/os-windows-ce.cpp rename to vm/os-windows-ce.cpp diff --git a/vm/os-windows-ce.h b/vm/os-windows-ce.h deleted file mode 100755 index a2be5fe475..0000000000 --- a/vm/os-windows-ce.h +++ /dev/null @@ -1,27 +0,0 @@ -#ifndef UNICODE -#define UNICODE -#endif - -#include -#include - -typedef wchar_t F_SYMBOL; - -#define unbox_symbol_string unbox_u16_string -#define from_symbol_string from_u16_string - -#define FACTOR_OS_STRING "wince" -#define FACTOR_DLL L"factor-ce.dll" -#define FACTOR_DLL_NAME "factor-ce.dll" - -int errno; -char *strerror(int err); -void flush_icache(CELL start, CELL end); -char *getenv(char *name); - -#define snprintf _snprintf -#define snwprintf _snwprintf - -s64 current_micros(void); -void c_to_factor_toplevel(CELL quot); -void open_console(void); diff --git a/vmpp/os-windows-ce.hpp b/vm/os-windows-ce.hpp similarity index 100% rename from vmpp/os-windows-ce.hpp rename to vm/os-windows-ce.hpp diff --git a/vm/os-windows-nt.32.h b/vm/os-windows-nt.32.h deleted file mode 100644 index 9b10671ba0..0000000000 --- a/vm/os-windows-nt.32.h +++ /dev/null @@ -1,2 +0,0 @@ -#define ESP Esp -#define EIP Eip diff --git a/vmpp/os-windows-nt.32.hpp b/vm/os-windows-nt.32.hpp similarity index 100% rename from vmpp/os-windows-nt.32.hpp rename to vm/os-windows-nt.32.hpp diff --git a/vm/os-windows-nt.64.h b/vm/os-windows-nt.64.h deleted file mode 100644 index 1f61c2335f..0000000000 --- a/vm/os-windows-nt.64.h +++ /dev/null @@ -1,2 +0,0 @@ -#define ESP Rsp -#define EIP Rip diff --git a/vmpp/os-windows-nt.64.hpp b/vm/os-windows-nt.64.hpp similarity index 100% rename from vmpp/os-windows-nt.64.hpp rename to vm/os-windows-nt.64.hpp diff --git a/vm/os-windows-nt.c b/vm/os-windows-nt.c deleted file mode 100755 index 501463378a..0000000000 --- a/vm/os-windows-nt.c +++ /dev/null @@ -1,51 +0,0 @@ -#include "master.h" - -s64 current_micros(void) -{ - FILETIME t; - GetSystemTimeAsFileTime(&t); - return (((s64)t.dwLowDateTime | (s64)t.dwHighDateTime<<32) - - EPOCH_OFFSET) / 10; -} - -long exception_handler(PEXCEPTION_POINTERS pe) -{ - PEXCEPTION_RECORD e = (PEXCEPTION_RECORD)pe->ExceptionRecord; - CONTEXT *c = (CONTEXT*)pe->ContextRecord; - - if(in_code_heap_p(c->EIP)) - signal_callstack_top = (void *)c->ESP; - else - signal_callstack_top = NULL; - - if(e->ExceptionCode == EXCEPTION_ACCESS_VIOLATION) - { - signal_fault_addr = e->ExceptionInformation[1]; - c->EIP = (CELL)memory_signal_handler_impl; - } - /* If the Widcomm bluetooth stack is installed, the BTTray.exe process - injects code into running programs. For some reason this results in - random SEH exceptions with this (undocumented) exception code being - raised. The workaround seems to be ignoring this altogether, since that - is what happens if SEH is not enabled. Don't really have any idea what - this exception means. */ - else if(e->ExceptionCode != 0x40010006) - { - signal_number = e->ExceptionCode; - c->EIP = (CELL)misc_signal_handler_impl; - } - - return EXCEPTION_CONTINUE_EXECUTION; -} - -void c_to_factor_toplevel(CELL quot) -{ - if(!AddVectoredExceptionHandler(0, (void*)exception_handler)) - fatal_error("AddVectoredExceptionHandler failed", 0); - c_to_factor(quot); - RemoveVectoredExceptionHandler((void*)exception_handler); -} - -void open_console(void) -{ -} diff --git a/vmpp/os-windows-nt.cpp b/vm/os-windows-nt.cpp similarity index 100% rename from vmpp/os-windows-nt.cpp rename to vm/os-windows-nt.cpp diff --git a/vm/os-windows-nt.h b/vm/os-windows-nt.h deleted file mode 100755 index 4e047b497c..0000000000 --- a/vm/os-windows-nt.h +++ /dev/null @@ -1,21 +0,0 @@ -#undef _WIN32_WINNT -#define _WIN32_WINNT 0x0501 // For AddVectoredExceptionHandler - -#ifndef UNICODE -#define UNICODE -#endif - -#include - -typedef char F_SYMBOL; - -#define unbox_symbol_string unbox_char_string -#define from_symbol_string from_char_string - -#define FACTOR_OS_STRING "winnt" -#define FACTOR_DLL L"factor.dll" -#define FACTOR_DLL_NAME "factor.dll" - -void c_to_factor_toplevel(CELL quot); -long exception_handler(PEXCEPTION_POINTERS pe); -void open_console(void); diff --git a/vmpp/os-windows-nt.hpp b/vm/os-windows-nt.hpp similarity index 100% rename from vmpp/os-windows-nt.hpp rename to vm/os-windows-nt.hpp diff --git a/vm/os-windows.c b/vm/os-windows.c deleted file mode 100755 index c917cd804d..0000000000 --- a/vm/os-windows.c +++ /dev/null @@ -1,147 +0,0 @@ -#include "master.h" - -HMODULE hFactorDll; - -void init_ffi(void) -{ - hFactorDll = GetModuleHandle(FACTOR_DLL); - if(!hFactorDll) - fatal_error("GetModuleHandle(\"" FACTOR_DLL_NAME "\") failed", 0); -} - -void ffi_dlopen(F_DLL *dll) -{ - dll->dll = LoadLibraryEx(alien_offset(dll->path), NULL, 0); -} - -void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol) -{ - return GetProcAddress(dll ? (HMODULE)dll->dll : hFactorDll, symbol); -} - -void ffi_dlclose(F_DLL *dll) -{ - FreeLibrary((HMODULE)dll->dll); - dll->dll = NULL; -} - -bool windows_stat(F_CHAR *path) -{ - BY_HANDLE_FILE_INFORMATION bhfi; - HANDLE h = CreateFileW(path, - GENERIC_READ, - FILE_SHARE_READ, - NULL, - OPEN_EXISTING, - FILE_FLAG_BACKUP_SEMANTICS, - NULL); - - if(h == INVALID_HANDLE_VALUE) - { - // FindFirstFile is the only call that can stat c:\pagefile.sys - WIN32_FIND_DATA st; - HANDLE h; - - if(INVALID_HANDLE_VALUE == (h = FindFirstFile(path, &st))) - return false; - FindClose(h); - return true; - } - bool ret; - ret = GetFileInformationByHandle(h, &bhfi); - CloseHandle(h); - return ret; -} - -void windows_image_path(F_CHAR *full_path, F_CHAR *temp_path, unsigned int length) -{ - snwprintf(temp_path, length-1, L"%s.image", full_path); - temp_path[sizeof(temp_path) - 1] = 0; -} - -/* You must free() this yourself. */ -const F_CHAR *default_image_path(void) -{ - F_CHAR full_path[MAX_UNICODE_PATH]; - F_CHAR *ptr; - F_CHAR temp_path[MAX_UNICODE_PATH]; - - if(!GetModuleFileName(NULL, full_path, MAX_UNICODE_PATH)) - fatal_error("GetModuleFileName() failed", 0); - - if((ptr = wcsrchr(full_path, '.'))) - *ptr = 0; - - snwprintf(temp_path, sizeof(temp_path)-1, L"%s.image", full_path); - temp_path[sizeof(temp_path) - 1] = 0; - - return safe_strdup(temp_path); -} - -/* You must free() this yourself. */ -const F_CHAR *vm_executable_path(void) -{ - F_CHAR full_path[MAX_UNICODE_PATH]; - if(!GetModuleFileName(NULL, full_path, MAX_UNICODE_PATH)) - fatal_error("GetModuleFileName() failed", 0); - return safe_strdup(full_path); -} - - -void primitive_existsp(void) -{ - - F_CHAR *path = unbox_u16_string(); - box_boolean(windows_stat(path)); -} - -F_SEGMENT *alloc_segment(CELL size) -{ - char *mem; - DWORD ignore; - - if((mem = (char *)VirtualAlloc(NULL, getpagesize() * 2 + size, - MEM_COMMIT, PAGE_EXECUTE_READWRITE)) == 0) - out_of_memory(); - - if (!VirtualProtect(mem, getpagesize(), PAGE_NOACCESS, &ignore)) - fatal_error("Cannot allocate low guard page", (CELL)mem); - - if (!VirtualProtect(mem + size + getpagesize(), - getpagesize(), PAGE_NOACCESS, &ignore)) - fatal_error("Cannot allocate high guard page", (CELL)mem); - - F_SEGMENT *block = safe_malloc(sizeof(F_SEGMENT)); - - block->start = (CELL)mem + getpagesize(); - block->size = size; - block->end = block->start + size; - - return block; -} - -void dealloc_segment(F_SEGMENT *block) -{ - SYSTEM_INFO si; - GetSystemInfo(&si); - if(!VirtualFree((void*)(block->start - si.dwPageSize), 0, MEM_RELEASE)) - fatal_error("dealloc_segment failed",0); - free(block); -} - -long getpagesize(void) -{ - static long g_pagesize = 0; - if (! g_pagesize) - { - SYSTEM_INFO system_info; - GetSystemInfo (&system_info); - g_pagesize = system_info.dwPageSize; - } - return g_pagesize; -} - -void sleep_micros(u64 usec) -{ - Sleep((DWORD)(usec / 1000)); -} diff --git a/vmpp/os-windows.cpp b/vm/os-windows.cpp similarity index 100% rename from vmpp/os-windows.cpp rename to vm/os-windows.cpp diff --git a/vm/os-windows.h b/vm/os-windows.h deleted file mode 100755 index 95d41ca9a2..0000000000 --- a/vm/os-windows.h +++ /dev/null @@ -1,59 +0,0 @@ -#include - -#ifndef wcslen - /* for cygwin */ - #include -#endif - -typedef wchar_t F_CHAR; - -#define from_native_string from_u16_string -#define unbox_native_string unbox_u16_string -#define string_to_native_alien(string) string_to_u16_alien(string,true) - -#define STRING_LITERAL(string) L##string - -#define MAX_UNICODE_PATH 32768 -#define DLLEXPORT __declspec(dllexport) -#define SSCANF swscanf -#define STRCMP wcscmp -#define STRNCMP wcsncmp -#define STRDUP _wcsdup -#define MIN(a,b) ((a)>(b)?(b):(a)) -#define FSEEK fseek - -#ifdef WIN64 - #define CELL_FORMAT "%Iu" - #define CELL_HEX_FORMAT "%Ix" - #define CELL_HEX_PAD_FORMAT "%016Ix" - #define FIXNUM_FORMAT "%Id" -#else - #define CELL_FORMAT "%lu" - #define CELL_HEX_FORMAT "%lx" - #define CELL_HEX_PAD_FORMAT "%08lx" - #define FIXNUM_FORMAT "%ld" -#endif - -#define OPEN_READ(path) _wfopen(path,L"rb") -#define OPEN_WRITE(path) _wfopen(path,L"wb") - -#define print_native_string(string) wprintf(L"%s",string) - -/* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */ -#define EPOCH_OFFSET 0x019db1ded53e8000LL - -void init_ffi(void); -void ffi_dlopen(F_DLL *dll); -void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol); -void ffi_dlclose(F_DLL *dll); - -void sleep_micros(u64 msec); - -INLINE void init_signals(void) {} -INLINE void early_init(void) {} -const F_CHAR *vm_executable_path(void); -const F_CHAR *default_image_path(void); -long getpagesize (void); - -s64 current_micros(void); - diff --git a/vmpp/os-windows.hpp b/vm/os-windows.hpp similarity index 100% rename from vmpp/os-windows.hpp rename to vm/os-windows.hpp diff --git a/vm/platform.h b/vm/platform.h deleted file mode 100644 index 70804542b4..0000000000 --- a/vm/platform.h +++ /dev/null @@ -1,122 +0,0 @@ -#if defined(__arm__) - #define FACTOR_ARM -#elif defined(__amd64__) || defined(__x86_64__) - #define FACTOR_AMD64 -#elif defined(i386) || defined(__i386) || defined(__i386__) || defined(WIN32) - #define FACTOR_X86 -#elif defined(__POWERPC__) || defined(__ppc__) || defined(_ARCH_PPC) - #define FACTOR_PPC -#else - #error "Unsupported architecture" -#endif - -#if defined(WINDOWS) - #if defined(WINCE) - #include "os-windows-ce.h" - #else - #include "os-windows-nt.h" - #endif - - #include "os-windows.h" - #if defined(FACTOR_AMD64) - #include "os-windows-nt.64.h" - #elif defined(FACTOR_X86) - #include "os-windows-nt.32.h" - #endif -#else - #include "os-unix.h" - - #ifdef __APPLE__ - #include "os-macosx.h" - #include "mach_signal.h" - - #ifdef FACTOR_X86 - #include "os-macosx-x86.32.h" - #elif defined(FACTOR_PPC) - #include "os-macosx-ppc.h" - #elif defined(FACTOR_AMD64) - #include "os-macosx-x86.64.h" - #else - #error "Unsupported Mac OS X flavor" - #endif - #else - #include "os-genunix.h" - - #ifdef __FreeBSD__ - #define FACTOR_OS_STRING "freebsd" - #include "os-freebsd.h" - - #if defined(FACTOR_X86) - #include "os-freebsd-x86.32.h" - #elif defined(FACTOR_AMD64) - #include "os-freebsd-x86.64.h" - #else - #error "Unsupported FreeBSD flavor" - #endif - #elif defined(__OpenBSD__) - #define FACTOR_OS_STRING "openbsd" - - #if defined(FACTOR_X86) - #include "os-openbsd-x86.32.h" - #elif defined(FACTOR_AMD64) - #include "os-openbsd-x86.64.h" - #else - #error "Unsupported OpenBSD flavor" - #endif - #elif defined(__NetBSD__) - #define FACTOR_OS_STRING "netbsd" - - #if defined(FACTOR_X86) - #include "os-netbsd-x86.32.h" - #elif defined(FACTOR_AMD64) - #include "os-netbsd-x86.64.h" - #else - #error "Unsupported NetBSD flavor" - #endif - - #include "os-netbsd.h" - #elif defined(linux) - #define FACTOR_OS_STRING "linux" - #include "os-linux.h" - - #if defined(FACTOR_X86) - #include "os-linux-x86.32.h" - #elif defined(FACTOR_PPC) - #include "os-linux-ppc.h" - #elif defined(FACTOR_ARM) - #include "os-linux-arm.h" - #elif defined(FACTOR_AMD64) - #include "os-linux-x86.64.h" - #else - #error "Unsupported Linux flavor" - #endif - #elif defined(__SVR4) && defined(sun) - #define FACTOR_OS_STRING "solaris" - - #if defined(FACTOR_X86) - #include "os-solaris-x86.32.h" - #elif defined(FACTOR_AMD64) - #include "os-solaris-x86.64.h" - #else - #error "Unsupported Solaris flavor" - #endif - - #else - #error "Unsupported OS" - #endif - #endif -#endif - -#if defined(FACTOR_X86) - #include "cpu-x86.32.h" - #include "cpu-x86.h" -#elif defined(FACTOR_AMD64) - #include "cpu-x86.64.h" - #include "cpu-x86.h" -#elif defined(FACTOR_PPC) - #include "cpu-ppc.h" -#elif defined(FACTOR_ARM) - #include "cpu-arm.h" -#else - #error "Unsupported CPU" -#endif diff --git a/vmpp/platform.hpp b/vm/platform.hpp similarity index 100% rename from vmpp/platform.hpp rename to vm/platform.hpp diff --git a/vm/primitives.c b/vm/primitives.c deleted file mode 100755 index cb5161693a..0000000000 --- a/vm/primitives.c +++ /dev/null @@ -1,154 +0,0 @@ -#include "master.h" - -void *primitives[] = { - primitive_bignum_to_fixnum, - primitive_float_to_fixnum, - primitive_fixnum_to_bignum, - primitive_float_to_bignum, - primitive_fixnum_to_float, - primitive_bignum_to_float, - primitive_str_to_float, - primitive_float_to_str, - primitive_float_bits, - primitive_double_bits, - primitive_bits_float, - primitive_bits_double, - primitive_fixnum_add, - primitive_fixnum_subtract, - primitive_fixnum_multiply, - primitive_fixnum_divint, - primitive_fixnum_divmod, - primitive_fixnum_shift, - primitive_bignum_eq, - primitive_bignum_add, - primitive_bignum_subtract, - primitive_bignum_multiply, - primitive_bignum_divint, - primitive_bignum_mod, - primitive_bignum_divmod, - primitive_bignum_and, - primitive_bignum_or, - primitive_bignum_xor, - primitive_bignum_not, - primitive_bignum_shift, - primitive_bignum_less, - primitive_bignum_lesseq, - primitive_bignum_greater, - primitive_bignum_greatereq, - primitive_bignum_bitp, - primitive_bignum_log2, - primitive_byte_array_to_bignum, - primitive_float_eq, - primitive_float_add, - primitive_float_subtract, - primitive_float_multiply, - primitive_float_divfloat, - primitive_float_mod, - primitive_float_less, - primitive_float_lesseq, - primitive_float_greater, - primitive_float_greatereq, - primitive_word, - primitive_word_xt, - primitive_getenv, - primitive_setenv, - primitive_existsp, - primitive_gc, - primitive_gc_stats, - primitive_save_image, - primitive_save_image_and_exit, - primitive_datastack, - primitive_retainstack, - primitive_callstack, - primitive_set_datastack, - primitive_set_retainstack, - primitive_set_callstack, - primitive_exit, - primitive_data_room, - primitive_code_room, - primitive_micros, - primitive_modify_code_heap, - primitive_dlopen, - primitive_dlsym, - primitive_dlclose, - primitive_byte_array, - primitive_uninitialized_byte_array, - primitive_displaced_alien, - primitive_alien_signed_cell, - primitive_set_alien_signed_cell, - primitive_alien_unsigned_cell, - primitive_set_alien_unsigned_cell, - primitive_alien_signed_8, - primitive_set_alien_signed_8, - primitive_alien_unsigned_8, - primitive_set_alien_unsigned_8, - primitive_alien_signed_4, - primitive_set_alien_signed_4, - primitive_alien_unsigned_4, - primitive_set_alien_unsigned_4, - primitive_alien_signed_2, - primitive_set_alien_signed_2, - primitive_alien_unsigned_2, - primitive_set_alien_unsigned_2, - primitive_alien_signed_1, - primitive_set_alien_signed_1, - primitive_alien_unsigned_1, - primitive_set_alien_unsigned_1, - primitive_alien_float, - primitive_set_alien_float, - primitive_alien_double, - primitive_set_alien_double, - primitive_alien_cell, - primitive_set_alien_cell, - primitive_alien_address, - primitive_set_slot, - primitive_string_nth, - primitive_set_string_nth_fast, - primitive_set_string_nth_slow, - primitive_resize_array, - primitive_resize_string, - primitive_array, - primitive_begin_scan, - primitive_next_object, - primitive_end_scan, - primitive_size, - primitive_die, - primitive_fopen, - primitive_fgetc, - primitive_fread, - primitive_fputc, - primitive_fwrite, - primitive_fflush, - primitive_fseek, - primitive_fclose, - primitive_wrapper, - primitive_clone, - primitive_string, - primitive_array_to_quotation, - primitive_quotation_xt, - primitive_tuple, - primitive_profiling, - primitive_become, - primitive_sleep, - primitive_tuple_boa, - primitive_callstack_to_array, - primitive_innermost_stack_frame_quot, - primitive_innermost_stack_frame_scan, - primitive_set_innermost_stack_frame_quot, - primitive_call_clear, - primitive_resize_byte_array, - primitive_dll_validp, - primitive_unimplemented, - primitive_clear_gc_stats, - primitive_jit_compile, - primitive_load_locals, - primitive_check_datastack, - primitive_inline_cache_miss, - primitive_mega_cache_miss, - primitive_lookup_method, - primitive_reset_dispatch_stats, - primitive_dispatch_stats, - primitive_reset_inline_cache_stats, - primitive_inline_cache_stats, - primitive_optimized_p, -}; diff --git a/vmpp/primitives.cpp b/vm/primitives.cpp similarity index 100% rename from vmpp/primitives.cpp rename to vm/primitives.cpp diff --git a/vm/primitives.h b/vm/primitives.h deleted file mode 100644 index 30e0a4af96..0000000000 --- a/vm/primitives.h +++ /dev/null @@ -1 +0,0 @@ -extern void *primitives[]; diff --git a/vmpp/primitives.hpp b/vm/primitives.hpp similarity index 100% rename from vmpp/primitives.hpp rename to vm/primitives.hpp diff --git a/vm/profiler.c b/vm/profiler.c deleted file mode 100755 index 5578854d6d..0000000000 --- a/vm/profiler.c +++ /dev/null @@ -1,51 +0,0 @@ -#include "master.h" - -/* Allocates memory */ -F_CODE_BLOCK *compile_profiling_stub(CELL word) -{ - REGISTER_ROOT(word); - F_JIT jit; - jit_init(&jit,WORD_TYPE,word); - jit_emit_with(&jit,userenv[JIT_PROFILING],word); - F_CODE_BLOCK *block = jit_make_code_block(&jit); - jit_dispose(&jit); - UNREGISTER_ROOT(word); - return block; -} - -/* Allocates memory */ -static void set_profiling(bool profiling) -{ - if(profiling == profiling_p) - return; - - profiling_p = profiling; - - /* Push everything to tenured space so that we can heap scan - and allocate profiling blocks if necessary */ - gc(); - - CELL words = find_all_words(); - - REGISTER_ROOT(words); - - CELL i; - CELL length = array_capacity(untag_object(words)); - for(i = 0; i < length; i++) - { - F_WORD *word = untag_word(array_nth(untag_array(words),i)); - if(profiling) - word->counter = tag_fixnum(0); - update_word_xt(word); - } - - UNREGISTER_ROOT(words); - - /* Update XTs in code heap */ - iterate_code_heap(relocate_code_block); -} - -void primitive_profiling(void) -{ - set_profiling(to_boolean(dpop())); -} diff --git a/vmpp/profiler.cpp b/vm/profiler.cpp similarity index 100% rename from vmpp/profiler.cpp rename to vm/profiler.cpp diff --git a/vm/profiler.h b/vm/profiler.h deleted file mode 100755 index 40daab429c..0000000000 --- a/vm/profiler.h +++ /dev/null @@ -1,3 +0,0 @@ -bool profiling_p; -F_CODE_BLOCK *compile_profiling_stub(CELL word); -void primitive_profiling(void); diff --git a/vmpp/profiler.hpp b/vm/profiler.hpp similarity index 100% rename from vmpp/profiler.hpp rename to vm/profiler.hpp diff --git a/vm/quotations.c b/vm/quotations.c deleted file mode 100755 index 29ab8537d1..0000000000 --- a/vm/quotations.c +++ /dev/null @@ -1,374 +0,0 @@ -#include "master.h" - -/* Simple non-optimizing compiler. - -This is one of the two compilers implementing Factor; the second one is written -in Factor and performs advanced optimizations. See core/compiler/compiler.factor. - -The non-optimizing compiler compiles a quotation at a time by concatenating -machine code chunks; prolog, epilog, call word, jump to word, etc. These machine -code chunks are generated from Factor code in core/cpu/.../bootstrap.factor. - -Calls to words and constant quotations (referenced by conditionals and dips) -are direct jumps to machine code blocks. Literals are also referenced directly -without going through the literal table. - -It actually does do a little bit of very simple optimization: - -1) Tail call optimization. - -2) If a quotation is determined to not call any other words (except for a few -special words which are open-coded, see below), then no prolog/epilog is -generated. - -3) When in tail position and immediately preceded by literal arguments, the -'if' is generated inline, instead of as a call to the 'if' word. - -4) When preceded by a quotation, calls to 'dip', '2dip' and '3dip' are -open-coded as retain stack manipulation surrounding a subroutine call. - -5) Sub-primitives are primitive words which are implemented in assembly and not -in the VM. They are open-coded and no subroutine call is generated. This -includes stack shufflers, some fixnum arithmetic words, and words such as tag, -slot and eq?. A primitive call is relatively expensive (two subroutine calls) -so this results in a big speedup for relatively little effort. */ - -static bool jit_primitive_call_p(F_ARRAY *array, CELL i) -{ - return (i + 2) == array_capacity(array) - && type_of(array_nth(array,i)) == FIXNUM_TYPE - && array_nth(array,i + 1) == userenv[JIT_PRIMITIVE_WORD]; -} - -static bool jit_fast_if_p(F_ARRAY *array, CELL i) -{ - return (i + 3) == array_capacity(array) - && type_of(array_nth(array,i)) == QUOTATION_TYPE - && type_of(array_nth(array,i + 1)) == QUOTATION_TYPE - && array_nth(array,i + 2) == userenv[JIT_IF_WORD]; -} - -static bool jit_fast_dip_p(F_ARRAY *array, CELL i) -{ - return (i + 2) <= array_capacity(array) - && type_of(array_nth(array,i)) == QUOTATION_TYPE - && array_nth(array,i + 1) == userenv[JIT_DIP_WORD]; -} - -static bool jit_fast_2dip_p(F_ARRAY *array, CELL i) -{ - return (i + 2) <= array_capacity(array) - && type_of(array_nth(array,i)) == QUOTATION_TYPE - && array_nth(array,i + 1) == userenv[JIT_2DIP_WORD]; -} - -static bool jit_fast_3dip_p(F_ARRAY *array, CELL i) -{ - return (i + 2) <= array_capacity(array) - && type_of(array_nth(array,i)) == QUOTATION_TYPE - && array_nth(array,i + 1) == userenv[JIT_3DIP_WORD]; -} - -static bool jit_mega_lookup_p(F_ARRAY *array, CELL i) -{ - return (i + 3) < array_capacity(array) - && type_of(array_nth(array,i)) == ARRAY_TYPE - && type_of(array_nth(array,i + 1)) == FIXNUM_TYPE - && type_of(array_nth(array,i + 2)) == ARRAY_TYPE - && array_nth(array,i + 3) == userenv[MEGA_LOOKUP_WORD]; -} - -static bool jit_stack_frame_p(F_ARRAY *array) -{ - F_FIXNUM length = array_capacity(array); - F_FIXNUM i; - - for(i = 0; i < length - 1; i++) - { - CELL obj = array_nth(array,i); - if(type_of(obj) == WORD_TYPE) - { - F_WORD *word = untag_object(obj); - if(word->subprimitive == F) - return true; - } - else if(type_of(obj) == QUOTATION_TYPE) - { - if(jit_fast_dip_p(array,i) - || jit_fast_2dip_p(array,i) - || jit_fast_3dip_p(array,i)) - return true; - } - } - - return false; -} - -#define TAIL_CALL { \ - if(stack_frame) jit_emit(jit,userenv[JIT_EPILOG]); \ - tail_call = true; \ - } - -/* Allocates memory */ -static void jit_iterate_quotation(F_JIT *jit, CELL array, CELL compiling, CELL relocate) -{ - REGISTER_ROOT(array); - - bool stack_frame = jit_stack_frame_p(untag_object(array)); - - jit_set_position(jit,0); - - if(stack_frame) - jit_emit(jit,userenv[JIT_PROLOG]); - - CELL i; - CELL length = array_capacity(untag_object(array)); - bool tail_call = false; - - for(i = 0; i < length; i++) - { - jit_set_position(jit,i); - - CELL obj = array_nth(untag_object(array),i); - REGISTER_ROOT(obj); - - F_WORD *word; - F_WRAPPER *wrapper; - - switch(type_of(obj)) - { - case WORD_TYPE: - word = untag_object(obj); - - /* Intrinsics */ - if(word->subprimitive != F) - jit_emit_subprimitive(jit,word); - /* The (execute) primitive is special-cased */ - else if(obj == userenv[JIT_EXECUTE_WORD]) - { - if(i == length - 1) - { - TAIL_CALL; - jit_emit(jit,userenv[JIT_EXECUTE_JUMP]); - } - else - jit_emit(jit,userenv[JIT_EXECUTE_CALL]); - } - /* Everything else */ - else - { - if(i == length - 1) - { - TAIL_CALL; - jit_word_jump(jit,obj); - } - else - jit_word_call(jit,obj); - } - break; - case WRAPPER_TYPE: - wrapper = untag_object(obj); - jit_push(jit,wrapper->object); - break; - case FIXNUM_TYPE: - /* Primitive calls */ - if(jit_primitive_call_p(untag_object(array),i)) - { - jit_emit(jit,userenv[JIT_SAVE_STACK]); - jit_emit_with(jit,userenv[JIT_PRIMITIVE],obj); - - i++; - - tail_call = true; - break; - } - case QUOTATION_TYPE: - /* 'if' preceeded by two literal quotations (this is why if and ? are - mutually recursive in the library, but both still work) */ - if(jit_fast_if_p(untag_object(array),i)) - { - TAIL_CALL; - - if(compiling) - { - jit_compile(array_nth(untag_object(array),i),relocate); - jit_compile(array_nth(untag_object(array),i + 1),relocate); - } - - jit_emit_with(jit,userenv[JIT_IF_1],array_nth(untag_object(array),i)); - jit_emit_with(jit,userenv[JIT_IF_2],array_nth(untag_object(array),i + 1)); - - i += 2; - - break; - } - /* dip */ - else if(jit_fast_dip_p(untag_object(array),i)) - { - if(compiling) - jit_compile(obj,relocate); - jit_emit_with(jit,userenv[JIT_DIP],obj); - i++; - break; - } - /* 2dip */ - else if(jit_fast_2dip_p(untag_object(array),i)) - { - if(compiling) - jit_compile(obj,relocate); - jit_emit_with(jit,userenv[JIT_2DIP],obj); - i++; - break; - } - /* 3dip */ - else if(jit_fast_3dip_p(untag_object(array),i)) - { - if(compiling) - jit_compile(obj,relocate); - jit_emit_with(jit,userenv[JIT_3DIP],obj); - i++; - break; - } - case ARRAY_TYPE: - /* Method dispatch */ - if(jit_mega_lookup_p(untag_object(array),i)) - { - jit_emit_mega_cache_lookup(jit, - array_nth(untag_object(array),i), - untag_fixnum_fast(array_nth(untag_object(array),i + 1)), - array_nth(untag_object(array),i + 2)); - i += 3; - tail_call = true; - break; - } - default: - jit_push(jit,obj); - break; - } - - UNREGISTER_ROOT(obj); - } - - if(!tail_call) - { - jit_set_position(jit,length); - - if(stack_frame) - jit_emit(jit,userenv[JIT_EPILOG]); - jit_emit(jit,userenv[JIT_RETURN]); - } - - UNREGISTER_ROOT(array); -} - -void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code) -{ - if(code->block.type != QUOTATION_TYPE) - critical_error("Bad param to set_quot_xt",(CELL)code); - - quot->code = code; - quot->xt = (XT)(code + 1); - quot->compiledp = T; -} - -/* Allocates memory */ -void jit_compile(CELL quot, bool relocate) -{ - if(untag_quotation(quot)->compiledp != F) - return; - - CELL array = untag_quotation(quot)->array; - - REGISTER_ROOT(quot); - REGISTER_ROOT(array); - - F_JIT jit; - jit_init(&jit,QUOTATION_TYPE,quot); - - jit_iterate_quotation(&jit,array,true,relocate); - - F_CODE_BLOCK *compiled = jit_make_code_block(&jit); - - set_quot_xt(untag_object(quot),compiled); - - if(relocate) relocate_code_block(compiled); - - jit_dispose(&jit); - - UNREGISTER_ROOT(array); - UNREGISTER_ROOT(quot); -} - -F_FIXNUM quot_code_offset_to_scan(CELL quot, CELL offset) -{ - CELL array = untag_quotation(quot)->array; - REGISTER_ROOT(array); - - F_JIT jit; - jit_init(&jit,QUOTATION_TYPE,quot); - jit_compute_position(&jit,offset); - jit_iterate_quotation(&jit,array,false,false); - jit_dispose(&jit); - - UNREGISTER_ROOT(array); - - return jit_get_position(&jit); -} - -F_FASTCALL CELL lazy_jit_compile_impl(CELL quot, F_STACK_FRAME *stack) -{ - stack_chain->callstack_top = stack; - REGISTER_ROOT(quot); - jit_compile(quot,true); - UNREGISTER_ROOT(quot); - return quot; -} - -void primitive_jit_compile(void) -{ - jit_compile(dpop(),true); -} - -/* push a new quotation on the stack */ -void primitive_array_to_quotation(void) -{ - F_QUOTATION *quot = allot_object(QUOTATION_TYPE,sizeof(F_QUOTATION)); - quot->array = dpeek(); - quot->xt = lazy_jit_compile; - quot->compiledp = F; - quot->cached_effect = F; - quot->cache_counter = F; - drepl(tag_quotation(quot)); -} - -void primitive_quotation_xt(void) -{ - F_QUOTATION *quot = untag_quotation(dpeek()); - drepl(allot_cell((CELL)quot->xt)); -} - -void compile_all_words(void) -{ - CELL words = find_all_words(); - - REGISTER_ROOT(words); - - CELL i; - CELL length = array_capacity(untag_object(words)); - for(i = 0; i < length; i++) - { - F_WORD *word = untag_word(array_nth(untag_array(words),i)); - REGISTER_UNTAGGED(word); - - if(!word->code || !word_optimized_p(word)) - jit_compile_word(word,word->def,false); - - UNREGISTER_UNTAGGED(word); - update_word_xt(word); - - } - - UNREGISTER_ROOT(words); - - iterate_code_heap(relocate_code_block); -} diff --git a/vmpp/quotations.cpp b/vm/quotations.cpp similarity index 100% rename from vmpp/quotations.cpp rename to vm/quotations.cpp diff --git a/vm/quotations.h b/vm/quotations.h deleted file mode 100755 index 6509dfe5ed..0000000000 --- a/vm/quotations.h +++ /dev/null @@ -1,15 +0,0 @@ -DEFINE_UNTAG(F_QUOTATION,QUOTATION_TYPE,quotation) - -INLINE CELL tag_quotation(F_QUOTATION *quotation) -{ - return RETAG(quotation,QUOTATION_TYPE); -} - -void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code); -void jit_compile(CELL quot, bool relocate); -F_FASTCALL CELL lazy_jit_compile_impl(CELL quot, F_STACK_FRAME *stack); -F_FIXNUM quot_code_offset_to_scan(CELL quot, CELL offset); -void primitive_array_to_quotation(void); -void primitive_quotation_xt(void); -void primitive_jit_compile(void); -void compile_all_words(void); diff --git a/vmpp/quotations.hpp b/vm/quotations.hpp similarity index 100% rename from vmpp/quotations.hpp rename to vm/quotations.hpp diff --git a/vm/run.c b/vm/run.c deleted file mode 100755 index f5e45c2d5a..0000000000 --- a/vm/run.c +++ /dev/null @@ -1,248 +0,0 @@ -#include "master.h" - -void reset_datastack(void) -{ - ds = ds_bot - CELLS; -} - -void reset_retainstack(void) -{ - rs = rs_bot - CELLS; -} - -#define RESERVED (64 * CELLS) - -void fix_stacks(void) -{ - if(ds + CELLS < ds_bot || ds + RESERVED >= ds_top) reset_datastack(); - if(rs + CELLS < rs_bot || rs + RESERVED >= rs_top) reset_retainstack(); -} - -/* called before entry into foreign C code. Note that ds and rs might -be stored in registers, so callbacks must save and restore the correct values */ -void save_stacks(void) -{ - if(stack_chain) - { - stack_chain->datastack = ds; - stack_chain->retainstack = rs; - } -} - -F_CONTEXT *alloc_context(void) -{ - F_CONTEXT *context; - - if(unused_contexts) - { - context = unused_contexts; - unused_contexts = unused_contexts->next; - } - else - { - context = safe_malloc(sizeof(F_CONTEXT)); - context->datastack_region = alloc_segment(ds_size); - context->retainstack_region = alloc_segment(rs_size); - } - - return context; -} - -void dealloc_context(F_CONTEXT *context) -{ - context->next = unused_contexts; - unused_contexts = context; -} - -/* called on entry into a compiled callback */ -void nest_stacks(void) -{ - F_CONTEXT *new_stacks = alloc_context(); - - new_stacks->callstack_bottom = (F_STACK_FRAME *)-1; - new_stacks->callstack_top = (F_STACK_FRAME *)-1; - - /* note that these register values are not necessarily valid stack - pointers. they are merely saved non-volatile registers, and are - restored in unnest_stacks(). consider this scenario: - - factor code calls C function - - C function saves ds/cs registers (since they're non-volatile) - - C function clobbers them - - C function calls Factor callback - - Factor callback returns - - C function restores registers - - C function returns to Factor code */ - new_stacks->datastack_save = ds; - new_stacks->retainstack_save = rs; - - /* save per-callback userenv */ - new_stacks->current_callback_save = userenv[CURRENT_CALLBACK_ENV]; - new_stacks->catchstack_save = userenv[CATCHSTACK_ENV]; - - new_stacks->next = stack_chain; - stack_chain = new_stacks; - - reset_datastack(); - reset_retainstack(); -} - -/* called when leaving a compiled callback */ -void unnest_stacks(void) -{ - ds = stack_chain->datastack_save; - rs = stack_chain->retainstack_save; - - /* restore per-callback userenv */ - userenv[CURRENT_CALLBACK_ENV] = stack_chain->current_callback_save; - userenv[CATCHSTACK_ENV] = stack_chain->catchstack_save; - - F_CONTEXT *old_stacks = stack_chain; - stack_chain = old_stacks->next; - dealloc_context(old_stacks); -} - -/* called on startup */ -void init_stacks(CELL ds_size_, CELL rs_size_) -{ - ds_size = ds_size_; - rs_size = rs_size_; - stack_chain = NULL; - unused_contexts = NULL; -} - -bool stack_to_array(CELL bottom, CELL top) -{ - F_FIXNUM depth = (F_FIXNUM)(top - bottom + CELLS); - - if(depth < 0) - return false; - else - { - F_ARRAY *a = allot_array_internal(ARRAY_TYPE,depth / CELLS); - memcpy(a + 1,(void*)bottom,depth); - dpush(tag_array(a)); - return true; - } -} - -void primitive_datastack(void) -{ - if(!stack_to_array(ds_bot,ds)) - general_error(ERROR_DS_UNDERFLOW,F,F,NULL); -} - -void primitive_retainstack(void) -{ - if(!stack_to_array(rs_bot,rs)) - general_error(ERROR_RS_UNDERFLOW,F,F,NULL); -} - -/* returns pointer to top of stack */ -CELL array_to_stack(F_ARRAY *array, CELL bottom) -{ - CELL depth = array_capacity(array) * CELLS; - memcpy((void*)bottom,array + 1,depth); - return bottom + depth - CELLS; -} - -void primitive_set_datastack(void) -{ - ds = array_to_stack(untag_array(dpop()),ds_bot); -} - -void primitive_set_retainstack(void) -{ - rs = array_to_stack(untag_array(dpop()),rs_bot); -} - -/* Used to implement call( */ -void primitive_check_datastack(void) -{ - F_FIXNUM out = to_fixnum(dpop()); - F_FIXNUM in = to_fixnum(dpop()); - F_FIXNUM height = out - in; - F_ARRAY *array = untag_array(dpop()); - F_FIXNUM length = array_capacity(array); - F_FIXNUM depth = (ds - ds_bot + CELLS) / CELLS; - if(depth - height != length) - dpush(F); - else - { - F_FIXNUM i; - for(i = 0; i < length - in; i++) - { - if(get(ds_bot + i * CELLS) != array_nth(array,i)) - { - dpush(F); - return; - } - } - dpush(T); - } -} - -void primitive_getenv(void) -{ - F_FIXNUM e = untag_fixnum_fast(dpeek()); - drepl(userenv[e]); -} - -void primitive_setenv(void) -{ - F_FIXNUM e = untag_fixnum_fast(dpop()); - CELL value = dpop(); - userenv[e] = value; -} - -void primitive_exit(void) -{ - exit(to_fixnum(dpop())); -} - -void primitive_micros(void) -{ - box_unsigned_8(current_micros()); -} - -void primitive_sleep(void) -{ - sleep_micros(to_cell(dpop())); -} - -void primitive_set_slot(void) -{ - F_FIXNUM slot = untag_fixnum_fast(dpop()); - CELL obj = dpop(); - CELL value = dpop(); - set_slot(obj,slot,value); -} - -void primitive_load_locals(void) -{ - F_FIXNUM count = untag_fixnum_fast(dpop()); - memcpy((CELL *)(rs + CELLS),(CELL *)(ds - CELLS * (count - 1)),CELLS * count); - ds -= CELLS * count; - rs += CELLS * count; -} - -static CELL clone_object(CELL object) -{ - CELL size = object_size(object); - if(size == 0) - return object; - else - { - REGISTER_ROOT(object); - void *new_obj = allot_object(type_of(object),size); - UNREGISTER_ROOT(object); - - CELL tag = TAG(object); - memcpy(new_obj,(void*)UNTAG(object),size); - return RETAG(new_obj,tag); - } -} - -void primitive_clone(void) -{ - drepl(clone_object(dpeek())); -} diff --git a/vmpp/run.cpp b/vm/run.cpp similarity index 100% rename from vmpp/run.cpp rename to vm/run.cpp diff --git a/vm/run.h b/vm/run.h deleted file mode 100755 index b31fc3a2e1..0000000000 --- a/vm/run.h +++ /dev/null @@ -1,277 +0,0 @@ -#define USER_ENV 70 - -typedef enum { - NAMESTACK_ENV, /* used by library only */ - CATCHSTACK_ENV, /* used by library only, per-callback */ - - CURRENT_CALLBACK_ENV = 2, /* used by library only, per-callback */ - WALKER_HOOK_ENV, /* non-local exit hook, used by library only */ - CALLCC_1_ENV, /* used to pass the value in callcc1 */ - - BREAK_ENV = 5, /* quotation called by throw primitive */ - ERROR_ENV, /* a marker consed onto kernel errors */ - - CELL_SIZE_ENV = 7, /* sizeof(CELL) */ - CPU_ENV, /* CPU architecture */ - OS_ENV, /* operating system name */ - - ARGS_ENV = 10, /* command line arguments */ - STDIN_ENV, /* stdin FILE* handle */ - STDOUT_ENV, /* stdout FILE* handle */ - - IMAGE_ENV = 13, /* image path name */ - EXECUTABLE_ENV, /* runtime executable path name */ - - EMBEDDED_ENV = 15, /* are we embedded in another app? */ - EVAL_CALLBACK_ENV, /* used when Factor is embedded in a C app */ - YIELD_CALLBACK_ENV, /* used when Factor is embedded in a C app */ - SLEEP_CALLBACK_ENV, /* used when Factor is embedded in a C app */ - - COCOA_EXCEPTION_ENV = 19, /* Cocoa exception handler quotation */ - - BOOT_ENV = 20, /* boot quotation */ - GLOBAL_ENV, /* global namespace */ - - /* Quotation compilation in quotations.c */ - JIT_PROLOG = 23, - JIT_PRIMITIVE_WORD, - JIT_PRIMITIVE, - JIT_WORD_JUMP, - JIT_WORD_CALL, - JIT_IF_WORD, - JIT_IF_1, - JIT_IF_2, - JIT_EPILOG = 33, - JIT_RETURN, - JIT_PROFILING, - JIT_PUSH_IMMEDIATE, - JIT_SAVE_STACK = 38, - JIT_DIP_WORD, - JIT_DIP, - JIT_2DIP_WORD, - JIT_2DIP, - JIT_3DIP_WORD, - JIT_3DIP, - JIT_EXECUTE_WORD, - JIT_EXECUTE_JUMP, - JIT_EXECUTE_CALL, - - /* Polymorphic inline cache generation in inline_cache.c */ - PIC_LOAD = 48, - PIC_TAG, - PIC_HI_TAG, - PIC_TUPLE, - PIC_HI_TAG_TUPLE, - PIC_CHECK_TAG, - PIC_CHECK, - PIC_HIT, - PIC_MISS_WORD, - - /* Megamorphic cache generation in dispatch.c */ - MEGA_LOOKUP = 57, - MEGA_LOOKUP_WORD, - MEGA_MISS_WORD, - - UNDEFINED_ENV = 60, /* default quotation for undefined words */ - - STDERR_ENV = 61, /* stderr FILE* handle */ - - STAGE2_ENV = 62, /* have we bootstrapped? */ - - CURRENT_THREAD_ENV = 63, - - THREADS_ENV = 64, - RUN_QUEUE_ENV = 65, - SLEEP_QUEUE_ENV = 66, - - STACK_TRACES_ENV = 67, -} F_ENVTYPE; - -#define FIRST_SAVE_ENV BOOT_ENV -#define LAST_SAVE_ENV STAGE2_ENV - -/* TAGGED user environment data; see getenv/setenv prims */ -DLLEXPORT CELL userenv[USER_ENV]; - -/* macros for reading/writing memory, useful when working around -C's type system */ -INLINE CELL get(CELL where) -{ - return *((CELL*)where); -} - -INLINE void put(CELL where, CELL what) -{ - *((CELL*)where) = what; -} - -INLINE CELL cget(CELL where) -{ - return *((u16 *)where); -} - -INLINE void cput(CELL where, CELL what) -{ - *((u16 *)where) = what; -} - -INLINE CELL bget(CELL where) -{ - return *((u8 *)where); -} - -INLINE void bput(CELL where, CELL what) -{ - *((u8 *)where) = what; -} - -INLINE CELL align(CELL a, CELL b) -{ - return (a + (b-1)) & ~(b-1); -} - -#define align8(a) align(a,8) -#define align_page(a) align(a,getpagesize()) - -/* Canonical T object. It's just a word */ -CELL T; - -INLINE CELL tag_header(CELL cell) -{ - return cell << TAG_BITS; -} - -INLINE void check_header(CELL cell) -{ -#ifdef FACTOR_DEBUG - assert(TAG(cell) == FIXNUM_TYPE && untag_fixnum_fast(cell) < TYPE_COUNT); -#endif -} - -INLINE CELL untag_header(CELL cell) -{ - check_header(cell); - return cell >> TAG_BITS; -} - -INLINE CELL hi_tag(CELL tagged) -{ - return untag_header(get(UNTAG(tagged))); -} - -INLINE CELL tag_object(void *cell) -{ -#ifdef FACTOR_DEBUG - assert(hi_tag((CELL)cell) >= HEADER_TYPE); -#endif - return RETAG(cell,OBJECT_TYPE); -} - -INLINE CELL type_of(CELL tagged) -{ - CELL tag = TAG(tagged); - if(tag == OBJECT_TYPE) - return hi_tag(tagged); - else - return tag; -} - -#define DEFPUSHPOP(prefix,ptr) \ - INLINE CELL prefix##pop(void) \ - { \ - CELL value = get(ptr); \ - ptr -= CELLS; \ - return value; \ - } \ - INLINE void prefix##push(CELL tagged) \ - { \ - ptr += CELLS; \ - put(ptr,tagged); \ - } \ - INLINE void prefix##repl(CELL tagged) \ - { \ - put(ptr,tagged); \ - } \ - INLINE CELL prefix##peek() \ - { \ - return get(ptr); \ - } - -DEFPUSHPOP(d,ds) -DEFPUSHPOP(r,rs) - -typedef struct { - CELL start; - CELL size; - CELL end; -} F_SEGMENT; - -/* Assembly code makes assumptions about the layout of this struct: - - callstack_top field is 0 - - callstack_bottom field is 1 - - datastack field is 2 - - retainstack field is 3 */ -typedef struct _F_CONTEXT { - /* C stack pointer on entry */ - F_STACK_FRAME *callstack_top; - F_STACK_FRAME *callstack_bottom; - - /* current datastack top pointer */ - CELL datastack; - - /* current retain stack top pointer */ - CELL retainstack; - - /* saved contents of ds register on entry to callback */ - CELL datastack_save; - - /* saved contents of rs register on entry to callback */ - CELL retainstack_save; - - /* memory region holding current datastack */ - F_SEGMENT *datastack_region; - - /* memory region holding current retain stack */ - F_SEGMENT *retainstack_region; - - /* saved userenv slots on entry to callback */ - CELL catchstack_save; - CELL current_callback_save; - - struct _F_CONTEXT *next; -} F_CONTEXT; - -DLLEXPORT F_CONTEXT *stack_chain; - -F_CONTEXT *unused_contexts; - -CELL ds_size, rs_size; - -#define ds_bot (stack_chain->datastack_region->start) -#define ds_top (stack_chain->datastack_region->end) -#define rs_bot (stack_chain->retainstack_region->start) -#define rs_top (stack_chain->retainstack_region->end) - -void reset_datastack(void); -void reset_retainstack(void); -void fix_stacks(void); -DLLEXPORT void save_stacks(void); -DLLEXPORT void nest_stacks(void); -DLLEXPORT void unnest_stacks(void); -void init_stacks(CELL ds_size, CELL rs_size); - -void primitive_datastack(void); -void primitive_retainstack(void); -void primitive_set_datastack(void); -void primitive_set_retainstack(void); -void primitive_check_datastack(void); -void primitive_getenv(void); -void primitive_setenv(void); -void primitive_exit(void); -void primitive_micros(void); -void primitive_sleep(void); -void primitive_set_slot(void); -void primitive_load_locals(void); -void primitive_clone(void); - -bool stage2; diff --git a/vmpp/run.hpp b/vm/run.hpp similarity index 100% rename from vmpp/run.hpp rename to vm/run.hpp diff --git a/vm/strings.c b/vm/strings.c deleted file mode 100644 index f08a2e8866..0000000000 --- a/vm/strings.c +++ /dev/null @@ -1,294 +0,0 @@ -#include "master.h" - -CELL string_nth(F_STRING* string, CELL index) -{ - /* If high bit is set, the most significant 16 bits of the char - come from the aux vector. The least significant bit of the - corresponding aux vector entry is negated, so that we can - XOR the two components together and get the original code point - back. */ - CELL ch = bget(SREF(string,index)); - if((ch & 0x80) == 0) - return ch; - else - { - F_BYTE_ARRAY *aux = untag_object(string->aux); - return (cget(BREF(aux,index * sizeof(u16))) << 7) ^ ch; - } -} - -void set_string_nth_fast(F_STRING* string, CELL index, CELL ch) -{ - bput(SREF(string,index),ch); -} - -void set_string_nth_slow(F_STRING* string, CELL index, CELL ch) -{ - F_BYTE_ARRAY *aux; - - bput(SREF(string,index),(ch & 0x7f) | 0x80); - - if(string->aux == F) - { - REGISTER_UNTAGGED(string); - /* We don't need to pre-initialize the - byte array with any data, since we - only ever read from the aux vector - if the most significant bit of a - character is set. Initially all of - the bits are clear. */ - aux = allot_byte_array_internal( - untag_fixnum_fast(string->length) - * sizeof(u16)); - UNREGISTER_UNTAGGED(string); - - write_barrier((CELL)string); - string->aux = tag_object(aux); - } - else - aux = untag_object(string->aux); - - cput(BREF(aux,index * sizeof(u16)),(ch >> 7) ^ 1); -} - -/* allocates memory */ -void set_string_nth(F_STRING* string, CELL index, CELL ch) -{ - if(ch <= 0x7f) - set_string_nth_fast(string,index,ch); - else - set_string_nth_slow(string,index,ch); -} - -/* untagged */ -F_STRING* allot_string_internal(CELL capacity) -{ - F_STRING *string = allot_object(STRING_TYPE,string_size(capacity)); - - string->length = tag_fixnum(capacity); - string->hashcode = F; - string->aux = F; - - return string; -} - -/* allocates memory */ -void fill_string(F_STRING *string, CELL start, CELL capacity, CELL fill) -{ - if(fill <= 0x7f) - memset((void *)SREF(string,start),fill,capacity - start); - else - { - CELL i; - - for(i = start; i < capacity; i++) - { - REGISTER_UNTAGGED(string); - set_string_nth(string,i,fill); - UNREGISTER_UNTAGGED(string); - } - } -} - -/* untagged */ -F_STRING *allot_string(CELL capacity, CELL fill) -{ - F_STRING* string = allot_string_internal(capacity); - REGISTER_UNTAGGED(string); - fill_string(string,0,capacity,fill); - UNREGISTER_UNTAGGED(string); - return string; -} - -void primitive_string(void) -{ - CELL initial = to_cell(dpop()); - CELL length = unbox_array_size(); - dpush(tag_object(allot_string(length,initial))); -} - -static bool reallot_string_in_place_p(F_STRING *string, CELL capacity) -{ - return in_zone(&nursery,(CELL)string) && capacity <= string_capacity(string); -} - -F_STRING* reallot_string(F_STRING* string, CELL capacity) -{ - if(reallot_string_in_place_p(string,capacity)) - { - string->length = tag_fixnum(capacity); - - if(string->aux != F) - { - F_BYTE_ARRAY *aux = untag_object(string->aux); - aux->capacity = tag_fixnum(capacity * 2); - } - - return string; - } - else - { - CELL to_copy = string_capacity(string); - if(capacity < to_copy) - to_copy = capacity; - - REGISTER_UNTAGGED(string); - F_STRING *new_string = allot_string_internal(capacity); - UNREGISTER_UNTAGGED(string); - - memcpy(new_string + 1,string + 1,to_copy); - - if(string->aux != F) - { - REGISTER_UNTAGGED(string); - REGISTER_UNTAGGED(new_string); - F_BYTE_ARRAY *new_aux = allot_byte_array(capacity * sizeof(u16)); - UNREGISTER_UNTAGGED(new_string); - UNREGISTER_UNTAGGED(string); - - write_barrier((CELL)new_string); - new_string->aux = tag_object(new_aux); - - F_BYTE_ARRAY *aux = untag_object(string->aux); - memcpy(new_aux + 1,aux + 1,to_copy * sizeof(u16)); - } - - REGISTER_UNTAGGED(string); - REGISTER_UNTAGGED(new_string); - fill_string(new_string,to_copy,capacity,'\0'); - UNREGISTER_UNTAGGED(new_string); - UNREGISTER_UNTAGGED(string); - - return new_string; - } -} - -void primitive_resize_string(void) -{ - F_STRING* string = untag_string(dpop()); - CELL capacity = unbox_array_size(); - dpush(tag_object(reallot_string(string,capacity))); -} - -/* Some ugly macros to prevent a 2x code duplication */ - -#define MEMORY_TO_STRING(type,utype) \ - F_STRING *memory_to_##type##_string(const type *string, CELL length) \ - { \ - REGISTER_C_STRING(string); \ - F_STRING* s = allot_string_internal(length); \ - UNREGISTER_C_STRING(string); \ - CELL i; \ - for(i = 0; i < length; i++) \ - { \ - REGISTER_UNTAGGED(s); \ - set_string_nth(s,i,(utype)*string); \ - UNREGISTER_UNTAGGED(s); \ - string++; \ - } \ - return s; \ - } \ - F_STRING *from_##type##_string(const type *str) \ - { \ - CELL length = 0; \ - const type *scan = str; \ - while(*scan++) length++; \ - return memory_to_##type##_string(str,length); \ - } \ - void box_##type##_string(const type *str) \ - { \ - dpush(str ? tag_object(from_##type##_string(str)) : F); \ - } - -MEMORY_TO_STRING(char,u8) -MEMORY_TO_STRING(u16,u16) -MEMORY_TO_STRING(u32,u32) - -bool check_string(F_STRING *s, CELL max) -{ - CELL capacity = string_capacity(s); - CELL i; - for(i = 0; i < capacity; i++) - { - CELL ch = string_nth(s,i); - if(ch == '\0' || ch >= (1 << (max * 8))) - return false; - } - return true; -} - -F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size) -{ - return allot_byte_array((capacity + 1) * size); -} - -#define STRING_TO_MEMORY(type) \ - void type##_string_to_memory(F_STRING *s, type *string) \ - { \ - CELL i; \ - CELL capacity = string_capacity(s); \ - for(i = 0; i < capacity; i++) \ - string[i] = string_nth(s,i); \ - } \ - void primitive_##type##_string_to_memory(void) \ - { \ - type *address = unbox_alien(); \ - F_STRING *str = untag_string(dpop()); \ - type##_string_to_memory(str,address); \ - } \ - F_BYTE_ARRAY *string_to_##type##_alien(F_STRING *s, bool check) \ - { \ - CELL capacity = string_capacity(s); \ - F_BYTE_ARRAY *_c_str; \ - if(check && !check_string(s,sizeof(type))) \ - general_error(ERROR_C_STRING,tag_object(s),F,NULL); \ - REGISTER_UNTAGGED(s); \ - _c_str = allot_c_string(capacity,sizeof(type)); \ - UNREGISTER_UNTAGGED(s); \ - type *c_str = (type*)(_c_str + 1); \ - type##_string_to_memory(s,c_str); \ - c_str[capacity] = 0; \ - return _c_str; \ - } \ - type *to_##type##_string(F_STRING *s, bool check) \ - { \ - return (type*)(string_to_##type##_alien(s,check) + 1); \ - } \ - type *unbox_##type##_string(void) \ - { \ - return to_##type##_string(untag_string(dpop()),true); \ - } - -STRING_TO_MEMORY(char); -STRING_TO_MEMORY(u16); - -void primitive_string_nth(void) -{ - F_STRING *string = untag_object(dpop()); - CELL index = untag_fixnum_fast(dpop()); - dpush(tag_fixnum(string_nth(string,index))); -} - -void primitive_set_string_nth(void) -{ - F_STRING *string = untag_object(dpop()); - CELL index = untag_fixnum_fast(dpop()); - CELL value = untag_fixnum_fast(dpop()); - set_string_nth(string,index,value); -} - -void primitive_set_string_nth_fast(void) -{ - F_STRING *string = untag_object(dpop()); - CELL index = untag_fixnum_fast(dpop()); - CELL value = untag_fixnum_fast(dpop()); - set_string_nth_fast(string,index,value); -} - -void primitive_set_string_nth_slow(void) -{ - F_STRING *string = untag_object(dpop()); - CELL index = untag_fixnum_fast(dpop()); - CELL value = untag_fixnum_fast(dpop()); - set_string_nth_slow(string,index,value); -} diff --git a/vmpp/strings.cpp b/vm/strings.cpp similarity index 100% rename from vmpp/strings.cpp rename to vm/strings.cpp diff --git a/vm/strings.h b/vm/strings.h deleted file mode 100644 index d16a85ebea..0000000000 --- a/vm/strings.h +++ /dev/null @@ -1,50 +0,0 @@ -INLINE CELL string_capacity(F_STRING* str) -{ - return untag_fixnum_fast(str->length); -} - -INLINE CELL string_size(CELL size) -{ - return sizeof(F_STRING) + size; -} - -#define BREF(byte_array,index) ((CELL)byte_array + sizeof(F_BYTE_ARRAY) + (index)) -#define SREF(string,index) ((CELL)string + sizeof(F_STRING) + (index)) - -INLINE F_STRING* untag_string(CELL tagged) -{ - type_check(STRING_TYPE,tagged); - return untag_object(tagged); -} - -F_STRING* allot_string_internal(CELL capacity); -F_STRING* allot_string(CELL capacity, CELL fill); -void primitive_string(void); -F_STRING *reallot_string(F_STRING *string, CELL capacity); -void primitive_resize_string(void); - -F_STRING *memory_to_char_string(const char *string, CELL length); -F_STRING *from_char_string(const char *c_string); -DLLEXPORT void box_char_string(const char *c_string); - -F_STRING *memory_to_u16_string(const u16 *string, CELL length); -F_STRING *from_u16_string(const u16 *c_string); -DLLEXPORT void box_u16_string(const u16 *c_string); - -void char_string_to_memory(F_STRING *s, char *string); -F_BYTE_ARRAY *string_to_char_alien(F_STRING *s, bool check); -char* to_char_string(F_STRING *s, bool check); -DLLEXPORT char *unbox_char_string(void); - -void u16_string_to_memory(F_STRING *s, u16 *string); -F_BYTE_ARRAY *string_to_u16_alien(F_STRING *s, bool check); -u16* to_u16_string(F_STRING *s, bool check); -DLLEXPORT u16 *unbox_u16_string(void); - -/* String getters and setters */ -CELL string_nth(F_STRING* string, CELL index); -void set_string_nth(F_STRING* string, CELL index, CELL value); - -void primitive_string_nth(void); -void primitive_set_string_nth_slow(void); -void primitive_set_string_nth_fast(void); diff --git a/vmpp/strings.hpp b/vm/strings.hpp similarity index 100% rename from vmpp/strings.hpp rename to vm/strings.hpp diff --git a/vmpp/tagged.hpp b/vm/tagged.hpp similarity index 100% rename from vmpp/tagged.hpp rename to vm/tagged.hpp diff --git a/vm/test.cpp b/vm/test.cpp new file mode 100644 index 0000000000..694416031d --- /dev/null +++ b/vm/test.cpp @@ -0,0 +1,16 @@ +#include "master.hpp" + + +template struct blah { + const T *x_; + blah(T *x) : x_(x) {} + + blah& operator=(const T *x) { x_ = x; } +}; + +CELL test() +{ + int x = 100; + blah u(&x); + u = &x; +} diff --git a/vm/tuples.c b/vm/tuples.c deleted file mode 100644 index c93bdf4669..0000000000 --- a/vm/tuples.c +++ /dev/null @@ -1,35 +0,0 @@ -#include "master.h" - -/* push a new tuple on the stack */ -F_TUPLE *allot_tuple(F_TUPLE_LAYOUT *layout) -{ - REGISTER_UNTAGGED(layout); - F_TUPLE *tuple = allot_object(TUPLE_TYPE,tuple_size(layout)); - UNREGISTER_UNTAGGED(layout); - tuple->layout = tag_array((F_ARRAY *)layout); - return tuple; -} - -void primitive_tuple(void) -{ - F_TUPLE_LAYOUT *layout = untag_object(dpop()); - F_FIXNUM size = untag_fixnum_fast(layout->size); - - F_TUPLE *tuple = allot_tuple(layout); - F_FIXNUM i; - for(i = size - 1; i >= 0; i--) - put(AREF(tuple,i),F); - - dpush(tag_tuple(tuple)); -} - -/* push a new tuple on the stack, filling its slots from the stack */ -void primitive_tuple_boa(void) -{ - F_TUPLE_LAYOUT *layout = untag_object(dpop()); - F_FIXNUM size = untag_fixnum_fast(layout->size); - F_TUPLE *tuple = allot_tuple(layout); - memcpy(tuple + 1,(CELL *)(ds - CELLS * (size - 1)),CELLS * size); - ds -= CELLS * size; - dpush(tag_tuple(tuple)); -} diff --git a/vmpp/tuples.cpp b/vm/tuples.cpp similarity index 100% rename from vmpp/tuples.cpp rename to vm/tuples.cpp diff --git a/vm/tuples.h b/vm/tuples.h deleted file mode 100644 index 64b62e2539..0000000000 --- a/vm/tuples.h +++ /dev/null @@ -1,25 +0,0 @@ -INLINE CELL tag_tuple(F_TUPLE *tuple) -{ - return RETAG(tuple,TUPLE_TYPE); -} - -INLINE CELL tuple_size(F_TUPLE_LAYOUT *layout) -{ - CELL size = untag_fixnum_fast(layout->size); - return sizeof(F_TUPLE) + size * CELLS; -} - -INLINE CELL tuple_nth(F_TUPLE *tuple, CELL slot) -{ - return get(AREF(tuple,slot)); -} - -INLINE void set_tuple_nth(F_TUPLE *tuple, CELL slot, CELL value) -{ - put(AREF(tuple,slot),value); - write_barrier((CELL)tuple); -} - -void primitive_tuple(void); -void primitive_tuple_boa(void); -void primitive_tuple_layout(void); diff --git a/vmpp/tuples.hpp b/vm/tuples.hpp similarity index 100% rename from vmpp/tuples.hpp rename to vm/tuples.hpp diff --git a/vm/utilities.c b/vm/utilities.c deleted file mode 100755 index ac52772b4e..0000000000 --- a/vm/utilities.c +++ /dev/null @@ -1,55 +0,0 @@ -#include "master.h" - -/* If memory allocation fails, bail out */ -void *safe_malloc(size_t size) -{ - void *ptr = malloc(size); - if(!ptr) fatal_error("Out of memory in safe_malloc", 0); - return ptr; -} - -F_CHAR *safe_strdup(const F_CHAR *str) -{ - F_CHAR *ptr = STRDUP(str); - if(!ptr) fatal_error("Out of memory in safe_strdup", 0); - return ptr; -} - -/* We don't use printf directly, because format directives are not portable. -Instead we define the common cases here. */ -void nl(void) -{ - fputs("\n",stdout); -} - -void print_string(const char *str) -{ - fputs(str,stdout); -} - -void print_cell(CELL x) -{ - printf(CELL_FORMAT,x); -} - -void print_cell_hex(CELL x) -{ - printf(CELL_HEX_FORMAT,x); -} - -void print_cell_hex_pad(CELL x) -{ - printf(CELL_HEX_PAD_FORMAT,x); -} - -void print_fixnum(F_FIXNUM x) -{ - printf(FIXNUM_FORMAT,x); -} - -CELL read_cell_hex(void) -{ - CELL cell; - if(scanf(CELL_HEX_FORMAT,&cell) < 0) exit(1); - return cell; -}; diff --git a/vmpp/utilities.cpp b/vm/utilities.cpp similarity index 100% rename from vmpp/utilities.cpp rename to vm/utilities.cpp diff --git a/vm/utilities.h b/vm/utilities.h deleted file mode 100755 index d2b3223ce4..0000000000 --- a/vm/utilities.h +++ /dev/null @@ -1,10 +0,0 @@ -void *safe_malloc(size_t size); -F_CHAR *safe_strdup(const F_CHAR *str); - -void nl(void); -void print_string(const char *str); -void print_cell(CELL x); -void print_cell_hex(CELL x); -void print_cell_hex_pad(CELL x); -void print_fixnum(F_FIXNUM x); -CELL read_cell_hex(void); diff --git a/vmpp/utilities.hpp b/vm/utilities.hpp similarity index 100% rename from vmpp/utilities.hpp rename to vm/utilities.hpp diff --git a/vm/words.c b/vm/words.c deleted file mode 100644 index 615c11e5af..0000000000 --- a/vm/words.c +++ /dev/null @@ -1,82 +0,0 @@ -#include "master.h" - -F_WORD *allot_word(CELL vocab, CELL name) -{ - REGISTER_ROOT(vocab); - REGISTER_ROOT(name); - F_WORD *word = allot_object(WORD_TYPE,sizeof(F_WORD)); - UNREGISTER_ROOT(name); - UNREGISTER_ROOT(vocab); - - word->hashcode = tag_fixnum((rand() << 16) ^ rand()); - word->vocabulary = vocab; - word->name = name; - word->def = userenv[UNDEFINED_ENV]; - word->props = F; - word->counter = tag_fixnum(0); - word->direct_entry_def = F; - word->subprimitive = F; - word->profiling = NULL; - word->code = NULL; - - REGISTER_UNTAGGED(word); - jit_compile_word(word,word->def,true); - UNREGISTER_UNTAGGED(word); - - REGISTER_UNTAGGED(word); - update_word_xt(word); - UNREGISTER_UNTAGGED(word); - - if(profiling_p) - relocate_code_block(word->profiling); - - return word; -} - -/* ( name vocabulary -- word ) */ -void primitive_word(void) -{ - CELL vocab = dpop(); - CELL name = dpop(); - dpush(tag_object(allot_word(vocab,name))); -} - -/* word-xt ( word -- start end ) */ -void primitive_word_xt(void) -{ - F_WORD *word = untag_word(dpop()); - F_CODE_BLOCK *code = (profiling_p ? word->profiling : word->code); - dpush(allot_cell((CELL)code + sizeof(F_CODE_BLOCK))); - dpush(allot_cell((CELL)code + code->block.size)); -} - -/* Allocates memory */ -void update_word_xt(F_WORD *word) -{ - if(profiling_p) - { - if(!word->profiling) - { - REGISTER_UNTAGGED(word); - F_CODE_BLOCK *profiling = compile_profiling_stub(tag_object(word)); - UNREGISTER_UNTAGGED(word); - word->profiling = profiling; - } - - word->xt = (XT)(word->profiling + 1); - } - else - word->xt = (XT)(word->code + 1); -} - -void primitive_optimized_p(void) -{ - drepl(tag_boolean(word_optimized_p(untag_word(dpeek())))); -} - -void primitive_wrapper(void) -{ - F_WRAPPER *wrapper = allot_object(WRAPPER_TYPE,sizeof(F_WRAPPER)); - wrapper->object = dpeek(); - drepl(tag_object(wrapper)); -} diff --git a/vmpp/words.cpp b/vm/words.cpp similarity index 100% rename from vmpp/words.cpp rename to vm/words.cpp diff --git a/vm/words.h b/vm/words.h deleted file mode 100644 index aa86c87ae1..0000000000 --- a/vm/words.h +++ /dev/null @@ -1,16 +0,0 @@ -DEFINE_UNTAG(F_WORD,WORD_TYPE,word) - -F_WORD *allot_word(CELL vocab, CELL name); - -void primitive_word(void); -void primitive_word_xt(void); -void update_word_xt(F_WORD *word); - -INLINE bool word_optimized_p(F_WORD *word) -{ - return word->code->block.type == WORD_TYPE; -} - -void primitive_optimized_p(void); - -void primitive_wrapper(void); diff --git a/vmpp/words.hpp b/vm/words.hpp similarity index 100% rename from vmpp/words.hpp rename to vm/words.hpp diff --git a/vmpp/write_barrier.cpp b/vm/write_barrier.cpp similarity index 100% rename from vmpp/write_barrier.cpp rename to vm/write_barrier.cpp diff --git a/vm/write_barrier.h b/vm/write_barrier.h deleted file mode 100644 index be75d189de..0000000000 --- a/vm/write_barrier.h +++ /dev/null @@ -1,66 +0,0 @@ -/* card marking write barrier. a card is a byte storing a mark flag, -and the offset (in cells) of the first object in the card. - -the mark flag is set by the write barrier when an object in the -card has a slot written to. - -the offset of the first object is set by the allocator. */ - -/* if CARD_POINTS_TO_NURSERY is set, CARD_POINTS_TO_AGING must also be set. */ -#define CARD_POINTS_TO_NURSERY 0x80 -#define CARD_POINTS_TO_AGING 0x40 -#define CARD_MARK_MASK (CARD_POINTS_TO_NURSERY | CARD_POINTS_TO_AGING) -typedef u8 F_CARD; - -#define CARD_BITS 8 -#define CARD_SIZE (1<> CARD_BITS) + cards_offset) -#define CARD_TO_ADDR(c) (CELL*)(((CELL)(c) - cards_offset)<> DECK_BITS) + decks_offset) -#define DECK_TO_ADDR(c) (CELL*)(((CELL)(c) - decks_offset) << DECK_BITS) - -#define DECK_TO_CARD(d) (F_CARD*)((((CELL)(d) - decks_offset) << (DECK_BITS - CARD_BITS)) + cards_offset) - -#define ADDR_TO_ALLOT_MARKER(a) (F_CARD*)(((CELL)(a) >> CARD_BITS) + allot_markers_offset) -#define CARD_OFFSET(c) (*((c) - (CELL)data_heap->cards + (CELL)data_heap->allot_markers)) - -#define INVALID_ALLOT_MARKER 0xff - -DLLEXPORT CELL allot_markers_offset; - -/* the write barrier must be called any time we are potentially storing a -pointer from an older generation to a younger one */ -INLINE void write_barrier(CELL address) -{ - *ADDR_TO_CARD(address) = CARD_MARK_MASK; - *ADDR_TO_DECK(address) = CARD_MARK_MASK; -} - -#define SLOT(obj,slot) (UNTAG(obj) + (slot) * CELLS) - -INLINE void set_slot(CELL obj, CELL slot, CELL value) -{ - put(SLOT(obj,slot),value); - write_barrier(obj); -} - -/* we need to remember the first object allocated in the card */ -INLINE void allot_barrier(CELL address) -{ - F_CARD *ptr = ADDR_TO_ALLOT_MARKER(address); - if(*ptr == INVALID_ALLOT_MARKER) - *ptr = (address & ADDR_CARD_MASK); -} diff --git a/vmpp/write_barrier.hpp b/vm/write_barrier.hpp similarity index 100% rename from vmpp/write_barrier.hpp rename to vm/write_barrier.hpp diff --git a/vmpp/Config.arm b/vmpp/Config.arm deleted file mode 100644 index 003383aeb9..0000000000 --- a/vmpp/Config.arm +++ /dev/null @@ -1 +0,0 @@ -PLAF_DLL_OBJS += vmpppp/cpu-arm.o diff --git a/vmpp/Config.freebsd b/vmpp/Config.freebsd deleted file mode 100644 index 91f6adf340..0000000000 --- a/vmpp/Config.freebsd +++ /dev/null @@ -1,4 +0,0 @@ -include vmpppp/Config.unix -PLAF_DLL_OBJS += vmpppp/os-genunix.o vmpp/os-freebsd.o -CFLAGS += -export-dynamic -LIBS = -L/usr/local/lib/ -lm $(X11_UI_LIBS) diff --git a/vmpp/Config.freebsd.x86.32 b/vmpp/Config.freebsd.x86.32 deleted file mode 100644 index e5acaccc00..0000000000 --- a/vmpp/Config.freebsd.x86.32 +++ /dev/null @@ -1,2 +0,0 @@ -include vmpp/Config.freebsd -include vmpp/Config.x86.32 diff --git a/vmpp/Config.freebsd.x86.64 b/vmpp/Config.freebsd.x86.64 deleted file mode 100644 index 24d2b894bc..0000000000 --- a/vmpp/Config.freebsd.x86.64 +++ /dev/null @@ -1,3 +0,0 @@ -include vmpp/Config.freebsd -include vmpp/Config.x86.64 -LIBS += -lpthread diff --git a/vmpp/Config.linux b/vmpp/Config.linux deleted file mode 100644 index 57622af687..0000000000 --- a/vmpp/Config.linux +++ /dev/null @@ -1,4 +0,0 @@ -include vmpp/Config.unix -PLAF_DLL_OBJS += vmpp/os-genunix.o vm/os-linux.o -CFLAGS += -export-dynamic -LIBS = -ldl -lm -lpthread $(X11_UI_LIBS) diff --git a/vmpp/Config.linux.arm b/vmpp/Config.linux.arm deleted file mode 100644 index 926638d51b..0000000000 --- a/vmpp/Config.linux.arm +++ /dev/null @@ -1,3 +0,0 @@ -include vmpp/Config.linux -include vmpp/Config.arm -PLAF_DLL_OBJS += vmpp/os-linux-arm.o diff --git a/vmpp/Config.linux.ppc b/vmpp/Config.linux.ppc deleted file mode 100644 index 439b2284f9..0000000000 --- a/vmpp/Config.linux.ppc +++ /dev/null @@ -1,3 +0,0 @@ -include vmpp/Config.linux -include vmpp/Config.ppc -CFLAGS += -mregnames diff --git a/vmpp/Config.linux.x86.32 b/vmpp/Config.linux.x86.32 deleted file mode 100644 index 95b5baf2f8..0000000000 --- a/vmpp/Config.linux.x86.32 +++ /dev/null @@ -1,2 +0,0 @@ -include vmpp/Config.linux -include vmpp/Config.x86.32 diff --git a/vmpp/Config.linux.x86.64 b/vmpp/Config.linux.x86.64 deleted file mode 100644 index fb20de21f2..0000000000 --- a/vmpp/Config.linux.x86.64 +++ /dev/null @@ -1,3 +0,0 @@ -include vmpp/Config.linux -include vmpp/Config.x86.64 -LIBPATH = -L/usr/X11R6/lib64 -L/usr/X11R6/lib diff --git a/vmpp/Config.macosx b/vmpp/Config.macosx deleted file mode 100644 index 221020fb9a..0000000000 --- a/vmpp/Config.macosx +++ /dev/null @@ -1,23 +0,0 @@ -include vmpp/Config.unix -CFLAGS += -fPIC - -PLAF_DLL_OBJS += vmpp/os-macosx.o vmpp/mach_signal.o - -DLL_EXTENSION = .dylib -SHARED_DLL_EXTENSION = .dylib - -SHARED_FLAG = -dynamiclib - -ifdef X11 - LIBS = -lm -framework Cocoa -L/opt/local/lib $(X11_UI_LIBS) -Wl,-dylib_file,/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib:/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib -else - LIBS = -lm -framework Cocoa -framework AppKit -endif - -LINKER = $(CPP) $(CFLAGS) -dynamiclib -single_module -std=gnu99 \ - -current_version $(VERSION) \ - -compatibility_version $(VERSION) \ - -fvisibility=hidden \ - $(LIBS) $(LIBPATH) -o - -LINK_WITH_ENGINE = -lfactor diff --git a/vmpp/Config.macosx.ppc b/vmpp/Config.macosx.ppc deleted file mode 100644 index 8152f0dc97..0000000000 --- a/vmpp/Config.macosx.ppc +++ /dev/null @@ -1,3 +0,0 @@ -include vmpp/Config.macosx -include vmpp/Config.ppc -CFLAGS += -arch ppc diff --git a/vmpp/Config.macosx.x86.32 b/vmpp/Config.macosx.x86.32 deleted file mode 100644 index 3780d0f66d..0000000000 --- a/vmpp/Config.macosx.x86.32 +++ /dev/null @@ -1,2 +0,0 @@ -include vmpp/Config.macosx -include vmpp/Config.x86.32 diff --git a/vmpp/Config.macosx.x86.64 b/vmpp/Config.macosx.x86.64 deleted file mode 100644 index 9528d84889..0000000000 --- a/vmpp/Config.macosx.x86.64 +++ /dev/null @@ -1,3 +0,0 @@ -include vmpp/Config.macosx -include vmpp/Config.x86.64 -CFLAGS += -m64 diff --git a/vmpp/Config.netbsd b/vmpp/Config.netbsd deleted file mode 100644 index 051168affb..0000000000 --- a/vmpp/Config.netbsd +++ /dev/null @@ -1,5 +0,0 @@ -include vmpp/Config.unix -PLAF_DLL_OBJS += vmpp/os-genunix.o vm/os-netbsd.o -CFLAGS += -export-dynamic -LIBPATH = -L/usr/X11R6/lib -Wl,-rpath,/usr/X11R6/lib -L/usr/pkg/lib -Wl,-rpath,/usr/pkg/lib -LIBS = -lm -lopenal -lalut $(X11_UI_LIBS) diff --git a/vmpp/Config.netbsd.x86.32 b/vmpp/Config.netbsd.x86.32 deleted file mode 100644 index 24223f2002..0000000000 --- a/vmpp/Config.netbsd.x86.32 +++ /dev/null @@ -1,2 +0,0 @@ -include vmpp/Config.netbsd -include vmpp/Config.x86.32 diff --git a/vmpp/Config.netbsd.x86.64 b/vmpp/Config.netbsd.x86.64 deleted file mode 100644 index a3399f498d..0000000000 --- a/vmpp/Config.netbsd.x86.64 +++ /dev/null @@ -1,2 +0,0 @@ -include vmpp/Config.netbsd -include vmpp/Config.x86.64 diff --git a/vmpp/Config.openbsd b/vmpp/Config.openbsd deleted file mode 100644 index 36240d93ee..0000000000 --- a/vmpp/Config.openbsd +++ /dev/null @@ -1,5 +0,0 @@ -include vmpp/Config.unix -PLAF_DLL_OBJS += vmpp/os-genunix.o vm/os-openbsd.o -CC = egcc -CFLAGS += -export-dynamic -LIBS = -L/usr/local/lib/ -lm $(X11_UI_LIBS) -lz -lssl -lcrypto -lpthread diff --git a/vmpp/Config.openbsd.x86.32 b/vmpp/Config.openbsd.x86.32 deleted file mode 100644 index 9c15945057..0000000000 --- a/vmpp/Config.openbsd.x86.32 +++ /dev/null @@ -1,2 +0,0 @@ -include vmpp/Config.openbsd -include vmpp/Config.x86.32 diff --git a/vmpp/Config.openbsd.x86.64 b/vmpp/Config.openbsd.x86.64 deleted file mode 100644 index 081c9f39dd..0000000000 --- a/vmpp/Config.openbsd.x86.64 +++ /dev/null @@ -1,2 +0,0 @@ -include vmpp/Config.openbsd -include vmpp/Config.x86.64 diff --git a/vmpp/Config.ppc b/vmpp/Config.ppc deleted file mode 100644 index 1a460e3779..0000000000 --- a/vmpp/Config.ppc +++ /dev/null @@ -1 +0,0 @@ -PLAF_DLL_OBJS += vmpp/cpu-ppc.o diff --git a/vmpp/Config.solaris b/vmpp/Config.solaris deleted file mode 100644 index 732814c65c..0000000000 --- a/vmpp/Config.solaris +++ /dev/null @@ -1,6 +0,0 @@ -include vmpp/Config.unix -PLAF_DLL_OBJS += vmpp/os-genunix.o vm/os-solaris.o -CFLAGS += -D_STDC_C99 -Drestrict="" -export-dynamic -LIBS += -ldl -lsocket -lnsl -lm -R/opt/PM/lib -R/opt/csw/lib \ - -R/usr/local/lib -R/usr/sfw/lib -R/usr/X11R6/lib \ - -R/opt/sfw/lib $(X11_UI_LIBS) diff --git a/vmpp/Config.solaris.x86.32 b/vmpp/Config.solaris.x86.32 deleted file mode 100644 index e7371d0963..0000000000 --- a/vmpp/Config.solaris.x86.32 +++ /dev/null @@ -1,2 +0,0 @@ -include vmpp/Config.solaris -include vmpp/Config.x86.32 diff --git a/vmpp/Config.solaris.x86.64 b/vmpp/Config.solaris.x86.64 deleted file mode 100644 index 8eae9fee26..0000000000 --- a/vmpp/Config.solaris.x86.64 +++ /dev/null @@ -1,2 +0,0 @@ -include vmpp/Config.solaris -include vmpp/Config.x86.64 diff --git a/vmpp/Config.unix b/vmpp/Config.unix deleted file mode 100755 index 705cfaa03c..0000000000 --- a/vmpp/Config.unix +++ /dev/null @@ -1,27 +0,0 @@ -ifndef DEBUG - CFLAGS += -fomit-frame-pointer -endif - -EXE_SUFFIX = -DLL_PREFIX = lib -DLL_EXTENSION = .a -SHARED_DLL_EXTENSION = .so -SHARED_FLAG = -shared - -PLAF_DLL_OBJS = vmpp/os-unix.o -PLAF_EXE_OBJS += vmpp/main-unix.o - -ifdef NO_UI - X11_UI_LIBS = -else - X11_UI_LIBS = -lpango-1.0 -lpangocairo-1.0 -lcairo -lglib-2.0 -lgobject-2.0 -lGL -lX11 -endif - -# CFLAGS += -fPIC -FFI_TEST_CFLAGS = -fPIC - -# LINKER = gcc -shared -o -# LINK_WITH_ENGINE = '-Wl,-rpath,$$ORIGIN' -lfactor - -LINKER = $(AR) rcs -LINK_WITH_ENGINE = -Wl,--whole-archive -lfactor -Wl,-no-whole-archive diff --git a/vmpp/Config.windows b/vmpp/Config.windows deleted file mode 100644 index 2ba6e7d479..0000000000 --- a/vmpp/Config.windows +++ /dev/null @@ -1,10 +0,0 @@ -CFLAGS += -DWINDOWS -mno-cygwin -LIBS = -lm -PLAF_DLL_OBJS += vmpp/os-windows.o -SHARED_FLAG = -shared -EXE_EXTENSION=.exe -CONSOLE_EXTENSION=.com -DLL_EXTENSION=.dll -SHARED_DLL_EXTENSION=.dll -LINKER = $(CC) -shared -mno-cygwin -o -LINK_WITH_ENGINE = -l$(DLL_PREFIX)factor$(DLL_SUFFIX) diff --git a/vmpp/Config.windows.ce b/vmpp/Config.windows.ce deleted file mode 100644 index 36f6918fb7..0000000000 --- a/vmpp/Config.windows.ce +++ /dev/null @@ -1,5 +0,0 @@ -CFLAGS += -DWINCE -LIBS = -lm -PLAF_DLL_OBJS += vmpp/os-windows-ce.o -PLAF_EXE_OBJS += vmpp/main-windows-ce.o -include vmpp/Config.windows diff --git a/vmpp/Config.windows.ce.arm b/vmpp/Config.windows.ce.arm deleted file mode 100755 index d757e316bc..0000000000 --- a/vmpp/Config.windows.ce.arm +++ /dev/null @@ -1,4 +0,0 @@ -CC = arm-wince-mingw32ce-gcc -DLL_SUFFIX=-ce -EXE_SUFFIX=-ce -include vmpp/Config.windows.ce vm/Config.arm diff --git a/vmpp/Config.windows.nt b/vmpp/Config.windows.nt deleted file mode 100644 index 88fd89c630..0000000000 --- a/vmpp/Config.windows.nt +++ /dev/null @@ -1,10 +0,0 @@ -LIBS = -lm -EXE_SUFFIX= -DLL_SUFFIX= -PLAF_DLL_OBJS += vmpp/os-windows-nt.o -PLAF_EXE_OBJS += vmpp/resources.o -PLAF_EXE_OBJS += vmpp/main-windows-nt.o -CFLAGS += -mwindows -CFLAGS_CONSOLE += -mconsole -CONSOLE_EXTENSION = .com -include vmpp/Config.windows diff --git a/vmpp/Config.windows.nt.x86.32 b/vmpp/Config.windows.nt.x86.32 deleted file mode 100644 index 9640d5103c..0000000000 --- a/vmpp/Config.windows.nt.x86.32 +++ /dev/null @@ -1,4 +0,0 @@ -DLL_PATH=http://factorcode.org/dlls -WINDRES=windres -include vmpp/Config.windows.nt -include vmpp/Config.x86.32 diff --git a/vmpp/Config.windows.nt.x86.64 b/vmpp/Config.windows.nt.x86.64 deleted file mode 100644 index 6c34a3cf49..0000000000 --- a/vmpp/Config.windows.nt.x86.64 +++ /dev/null @@ -1,6 +0,0 @@ -#error "lol" -DLL_PATH=http://factorcode.org/dlls/64 -CC=$(WIN64_PATH)-gcc.exe -WINDRES=$(WIN64_PATH)-windres.exe -include vmpp/Config.windows.nt -include vmpp/Config.x86.64 diff --git a/vmpp/Config.x86.32 b/vmpp/Config.x86.32 deleted file mode 100644 index ae2326372d..0000000000 --- a/vmpp/Config.x86.32 +++ /dev/null @@ -1,5 +0,0 @@ -BOOT_ARCH = x86 -PLAF_DLL_OBJS += vmpp/cpu-x86.32.o - -# gcc bug workaround -CFLAGS += -fno-builtin-strlen -fno-builtin-strcat diff --git a/vmpp/Config.x86.64 b/vmpp/Config.x86.64 deleted file mode 100644 index 34e3751969..0000000000 --- a/vmpp/Config.x86.64 +++ /dev/null @@ -1,2 +0,0 @@ -PLAF_DLL_OBJS += vmpp/cpu-x86.64.o -CFLAGS += -DFACTOR_64 diff --git a/vmpp/asm.h b/vmpp/asm.h deleted file mode 100644 index 9719ae8af0..0000000000 --- a/vmpp/asm.h +++ /dev/null @@ -1,16 +0,0 @@ -#if defined(__APPLE__) || (defined(WINDOWS) && !defined(__arm__)) - #define MANGLE(sym) _##sym -#else - #define MANGLE(sym) sym -#endif - -/* Apple's PPC assembler is out of date? */ -#if defined(__APPLE__) && defined(__ppc__) - #define XX @ -#else - #define XX ; -#endif - -/* The returns and args are just for documentation */ -#define DEF(returns,symbol,args) .globl MANGLE(symbol) XX \ -MANGLE(symbol) diff --git a/vmpp/cpu-arm.S b/vmpp/cpu-arm.S deleted file mode 100755 index 09e3331b99..0000000000 --- a/vmpp/cpu-arm.S +++ /dev/null @@ -1,127 +0,0 @@ -#include "asm.h" - -/* Note that the XT is passed to the quotation in r12 */ -#define CALL_QUOT \ - ldr r12,[r0, #9] /* load quotation-xt slot */ ; \ - mov lr,pc ; \ - mov pc,r12 - -#define JUMP_QUOT \ - ldr r12,[r0, #9] /* load quotation-xt slot */ ; \ - mov pc,r12 - -#define SAVED_REGS_SIZE 32 - -#define FRAME (RESERVED_SIZE + SAVED_REGS_SIZE + 8) - -#define LR_SAVE [sp, #-4] -#define RESERVED_SIZE 8 - -#define SAVE_LR str lr,LR_SAVE - -#define LOAD_LR ldr lr,LR_SAVE - -#define SAVE_AT(offset) (RESERVED_SIZE + 4 * offset) - -#define SAVE(register,offset) str register,[sp, #SAVE_AT(offset)] - -#define RESTORE(register,offset) ldr register,[sp, #SAVE_AT(offset)] - -#define PROLOGUE \ - SAVE_LR ; \ - sub sp,sp,#FRAME - -#define EPILOGUE \ - add sp,sp,#FRAME ; \ - LOAD_LR - -DEF(void,c_to_factor,(CELL quot)): - PROLOGUE - - SAVE(r4,0) /* save GPRs */ - /* don't save ds pointer */ - /* don't save rs pointer */ - SAVE(r7,3) - SAVE(r8,4) - SAVE(r9,5) - SAVE(r10,6) - SAVE(r11,7) - SAVE(r0,8) /* save quotation since we're about to mangle it */ - - sub r0,sp,#4 /* pass call stack pointer as an argument */ - bl MANGLE(save_callstack_bottom) - - RESTORE(r0,8) /* restore quotation */ - CALL_QUOT - - RESTORE(r11,7) /* restore GPRs */ - RESTORE(r10,6) - RESTORE(r9,5) - RESTORE(r8,4) - RESTORE(r7,3) - /* don't restore rs pointer */ - /* don't restore ds pointer */ - RESTORE(r4,0) - - EPILOGUE - mov pc,lr - -/* The JIT compiles an 'mov r1',sp in front of every primitive call, since a -word which was defined as a primitive will not change its definition for the -lifetime of the image -- adding new primitives requires a bootstrap. However, -an undefined word can certainly become defined, - -DEFER: foo -... -: foo ... ; - -And calls to non-primitives do not have this one-instruction prologue, so we -set the XT of undefined words to this symbol. */ -DEF(void,undefined,(CELL word)): - sub r1,sp,#4 - b MANGLE(undefined_error) - -/* Here we have two entry points. The first one is taken when profiling is -enabled */ -DEF(void,docol_profiling,(CELL word)): - ldr r1,[r0, #25] /* load profile-count slot */ - add r1,r1,#8 /* increment count */ - str r1,[r0, #25] /* store profile-count slot */ -DEF(void,docol,(CELL word)): - ldr r0,[r0, #13] /* load word-def slot */ - JUMP_QUOT - -/* We must pass the XT to the quotation in r12. */ -DEF(void,primitive_call,(void)): - ldr r0,[r5], #-4 /* load quotation from data stack */ - JUMP_QUOT - -/* We must preserve r1 here in case we're calling a primitive */ -DEF(void,primitive_execute,(void)): - ldr r0,[r5], #-4 /* load word from data stack */ - ldr pc,[r0, #29] /* jump to word-xt */ - -DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length)): - sub sp,r0,r2 /* compute new stack pointer */ - mov r0,sp /* start of destination of memcpy() */ - sub sp,sp,#12 /* alignment */ - bl MANGLE(memcpy) /* go */ - add sp,sp,#16 /* point SP at innermost frame */ - ldr pc,LR_SAVE /* return */ - -DEF(void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)): - add sp,r1,#4 /* compute new stack pointer */ - ldr lr,LR_SAVE /* we have rewound the stack; load return address */ - JUMP_QUOT /* call the quotation */ - -DEF(void,lazy_jit_compile,(CELL quot)): - mov r1,sp /* save stack pointer */ - PROLOGUE - bl MANGLE(lazy_jit_compile_impl) - EPILOGUE - JUMP_QUOT /* call the quotation */ - -#ifdef WINCE - .section .drectve - .ascii " -export:c_to_factor" -#endif diff --git a/vmpp/cpu-ppc.S b/vmpp/cpu-ppc.S deleted file mode 100755 index 5e77c004aa..0000000000 --- a/vmpp/cpu-ppc.S +++ /dev/null @@ -1,236 +0,0 @@ -/* Parts of this file were snarfed from SBCL src/runtime/ppc-assem.S, which is -in the public domain. */ -#include "asm.h" - -#define DS_REG r29 - -DEF(void,primitive_fixnum_add,(void)): - lwz r3,0(DS_REG) - lwz r4,-4(DS_REG) - subi DS_REG,DS_REG,4 - li r0,0 - mtxer r0 - addo. r5,r3,r4 - bso add_overflow - stw r5,0(DS_REG) - blr -add_overflow: - b MANGLE(overflow_fixnum_add) - -DEF(void,primitive_fixnum_subtract,(void)): - lwz r3,-4(DS_REG) - lwz r4,0(DS_REG) - subi DS_REG,DS_REG,4 - li r0,0 - mtxer r0 - subfo. r5,r4,r3 - bso sub_overflow - stw r5,0(DS_REG) - blr -sub_overflow: - b MANGLE(overflow_fixnum_subtract) - -DEF(void,primitive_fixnum_multiply,(void)): - lwz r3,0(DS_REG) - lwz r4,-4(DS_REG) - subi DS_REG,DS_REG,4 - srawi r3,r3,3 - mullwo. r5,r3,r4 - bso multiply_overflow - stw r5,0(DS_REG) - blr -multiply_overflow: - srawi r4,r4,3 - b MANGLE(overflow_fixnum_multiply) - -/* Note that the XT is passed to the quotation in r11 */ -#define CALL_OR_JUMP_QUOT \ - lwz r11,14(r3) /* load quotation-xt slot */ XX \ - -#define CALL_QUOT \ - CALL_OR_JUMP_QUOT XX \ - mtlr r11 /* prepare to call XT with quotation in r3 */ XX \ - blrl /* go */ - -#define JUMP_QUOT \ - CALL_OR_JUMP_QUOT XX \ - mtctr r11 /* prepare to call XT with quotation in r3 */ XX \ - bctr /* go */ - -#define PARAM_SIZE 32 - -#define SAVED_INT_REGS_SIZE 96 - -#define SAVED_FP_REGS_SIZE 144 - -#define FRAME (RESERVED_SIZE + PARAM_SIZE + SAVED_INT_REGS_SIZE + SAVED_FP_REGS_SIZE + 8) - -#if defined( __APPLE__) - #define LR_SAVE 8 - #define RESERVED_SIZE 24 -#else - #define LR_SAVE 4 - #define RESERVED_SIZE 8 -#endif - -#define SAVE_LR(reg) stw reg,(LR_SAVE + FRAME)(r1) - -#define LOAD_LR(reg) lwz reg,(LR_SAVE + FRAME)(r1) - -#define SAVE_AT(offset) (RESERVED_SIZE + PARAM_SIZE + 4 * offset) - -#define SAVE_INT(register,offset) stw register,SAVE_AT(offset)(r1) -#define RESTORE_INT(register,offset) lwz register,SAVE_AT(offset)(r1) - -#define SAVE_FP(register,offset) stfd register,SAVE_AT(offset)(r1) -#define RESTORE_FP(register,offset) lfd register,SAVE_AT(offset)(r1) - -#define PROLOGUE \ - mflr r0 XX /* get caller's return address */ \ - stwu r1,-FRAME(r1) XX /* create a stack frame to hold non-volatile registers */ \ - SAVE_LR(r0) - -#define EPILOGUE \ - LOAD_LR(r0) XX \ - lwz r1,0(r1) XX /* destroy the stack frame */ \ - mtlr r0 /* get ready to return */ - -/* We have to save and restore nonvolatile registers because -the Factor compiler treats the entire register file as volatile. */ -DEF(void,c_to_factor,(CELL quot)): - PROLOGUE - - SAVE_INT(r13,0) /* save GPRs */ - SAVE_INT(r14,1) - SAVE_INT(r15,2) - SAVE_INT(r16,3) - SAVE_INT(r17,4) - SAVE_INT(r18,5) - SAVE_INT(r19,6) - SAVE_INT(r20,7) - SAVE_INT(r21,8) - SAVE_INT(r22,9) - SAVE_INT(r23,10) - SAVE_INT(r24,11) - SAVE_INT(r25,12) - SAVE_INT(r26,13) - SAVE_INT(r27,14) - SAVE_INT(r28,15) - SAVE_INT(r31,16) - - SAVE_FP(f14,20) /* save FPRs */ - SAVE_FP(f15,22) - SAVE_FP(f16,24) - SAVE_FP(f17,26) - SAVE_FP(f18,28) - SAVE_FP(f19,30) - SAVE_FP(f20,32) - SAVE_FP(f21,34) - SAVE_FP(f22,36) - SAVE_FP(f23,38) - SAVE_FP(f24,40) - SAVE_FP(f25,42) - SAVE_FP(f26,44) - SAVE_FP(f27,46) - SAVE_FP(f28,48) - SAVE_FP(f29,50) - SAVE_FP(f30,52) - SAVE_FP(f31,54) - - SAVE_INT(r3,19) /* save quotation since we're about to mangle it */ - - mr r3,r1 /* pass call stack pointer as an argument */ - bl MANGLE(save_callstack_bottom) - - RESTORE_INT(r3,19) /* restore quotation */ - CALL_QUOT - - RESTORE_FP(f31,54) - RESTORE_FP(f30,52) - RESTORE_FP(f29,50) - RESTORE_FP(f28,48) - RESTORE_FP(f27,46) - RESTORE_FP(f26,44) - RESTORE_FP(f25,42) - RESTORE_FP(f24,40) - RESTORE_FP(f23,38) - RESTORE_FP(f22,36) - RESTORE_FP(f21,34) - RESTORE_FP(f20,32) - RESTORE_FP(f19,30) - RESTORE_FP(f18,28) - RESTORE_FP(f17,26) - RESTORE_FP(f16,24) - RESTORE_FP(f15,22) - RESTORE_FP(f14,20) /* save FPRs */ - - RESTORE_INT(r31,16) /* restore GPRs */ - RESTORE_INT(r28,15) - RESTORE_INT(r27,14) - RESTORE_INT(r26,13) - RESTORE_INT(r25,12) - RESTORE_INT(r24,11) - RESTORE_INT(r23,10) - RESTORE_INT(r22,9) - RESTORE_INT(r21,8) - RESTORE_INT(r20,7) - RESTORE_INT(r19,6) - RESTORE_INT(r18,5) - RESTORE_INT(r17,4) - RESTORE_INT(r16,3) - RESTORE_INT(r15,2) - RESTORE_INT(r14,1) - RESTORE_INT(r13,0) - - EPILOGUE - blr - -/* We pass a function pointer to memcpy in r6 to work around a Mac OS X ABI -limitation which would otherwise require us to do a bizzaro PC-relative -trampoline to retrieve the function address */ -DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy)): - sub r1,r3,r5 /* compute new stack pointer */ - mr r3,r1 /* start of destination of memcpy() */ - stwu r1,-64(r1) /* setup fake stack frame for memcpy() */ - mtlr r6 /* prepare to call memcpy() */ - blrl /* go */ - lwz r1,0(r1) /* tear down fake stack frame */ - lwz r0,LR_SAVE(r1) /* we have restored the stack; load return address */ - mtlr r0 /* prepare to return to restored callstack */ - blr /* go */ - -DEF(void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)): - mr r1,r4 /* compute new stack pointer */ - lwz r0,LR_SAVE(r1) /* we have rewound the stack; load return address */ - mtlr r0 - JUMP_QUOT /* call the quotation */ - -DEF(void,lazy_jit_compile,(CELL quot)): - mr r4,r1 /* save stack pointer */ - PROLOGUE - bl MANGLE(lazy_jit_compile_impl) - EPILOGUE - JUMP_QUOT /* call the quotation */ - -/* Thanks to Joshua Grams for this code. - -On PowerPC processors, we must flush the instruction cache manually -after writing to the code heap. */ - -DEF(void,flush_icache,(void *start, int len)): - /* compute number of cache lines to flush */ - add r4,r4,r3 - clrrwi r3,r3,5 /* align addr to next lower cache line boundary */ - sub r4,r4,r3 /* then n_lines = (len + 0x1f) / 0x20 */ - addi r4,r4,0x1f - srwi. r4,r4,5 /* note '.' suffix */ - beqlr /* if n_lines == 0, just return. */ - mtctr r4 /* flush cache lines */ -0: dcbf 0,r3 /* for each line... */ - sync - icbi 0,r3 - addi r3,r3,0x20 - bdnz 0b - sync /* finish up */ - isync - blr diff --git a/vmpp/cpu-x86.32.S b/vmpp/cpu-x86.32.S deleted file mode 100755 index 3c0db36935..0000000000 --- a/vmpp/cpu-x86.32.S +++ /dev/null @@ -1,76 +0,0 @@ -#include "asm.h" - -/* Note that primitive word definitions are compiled with -__attribute__((regparm 2), so the pointer to the word object is passed in EAX, -and the callstack top is passed in EDX */ - -#define ARG0 %eax -#define ARG1 %edx -#define STACK_REG %esp -#define DS_REG %esi -#define RETURN_REG %eax - -#define NV_TEMP_REG %ebx - -#define ARITH_TEMP_1 %ebp -#define ARITH_TEMP_2 %ebx -#define DIV_RESULT %eax - -#define CELL_SIZE 4 -#define STACK_PADDING 12 - -#define PUSH_NONVOLATILE \ - push %ebx ; \ - push %ebp ; \ - push %ebp - -#define POP_NONVOLATILE \ - pop %ebp ; \ - pop %ebp ; \ - pop %ebx - -#define QUOT_XT_OFFSET 16 -#define WORD_XT_OFFSET 30 - -/* We pass a function pointer to memcpy to work around a Mac OS X -ABI limitation which would otherwise require us to do a bizzaro PC-relative -trampoline to retrieve the function address */ -DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy)): - mov 4(%esp),%ebp /* to */ - mov 8(%esp),%edx /* from */ - mov 12(%esp),%ecx /* length */ - mov 16(%esp),%eax /* memcpy */ - sub %ecx,%ebp /* compute new stack pointer */ - mov %ebp,%esp - push %ecx /* pass length */ - push %edx /* pass src */ - push %ebp /* pass dst */ - call *%eax /* call memcpy */ - add $12,%esp /* pop args from the stack */ - ret /* return _with new stack_ */ - -/* cpu.x86.32 calls this */ -DEF(bool,check_sse2,(void)): - push %ebx - mov $1,%eax - cpuid - shr $26,%edx - and $1,%edx - pop %ebx - mov %edx,%eax - ret - -DEF(F_FASTCALL void,primitive_inline_cache_miss,(void)): - mov (%esp),%eax - sub $8,%esp - push %eax - call MANGLE(inline_cache_miss) - add $12,%esp - jmp *%eax - -#include "cpu-x86.S" - -#ifdef WINDOWS - .section .drectve - .ascii " -export:check_sse2" -#endif diff --git a/vmpp/cpu-x86.64.S b/vmpp/cpu-x86.64.S deleted file mode 100644 index a110bf1d51..0000000000 --- a/vmpp/cpu-x86.64.S +++ /dev/null @@ -1,83 +0,0 @@ -#include "asm.h" - -#define STACK_REG %rsp -#define DS_REG %r14 -#define RETURN_REG %rax - -#define CELL_SIZE 8 -#define STACK_PADDING 56 - -#define NV_TEMP_REG %rbp - -#define ARITH_TEMP_1 %r8 -#define ARITH_TEMP_2 %r9 -#define DIV_RESULT %rax - -#ifdef WINDOWS - - #define ARG0 %rcx - #define ARG1 %rdx - #define ARG2 %r8 - #define ARG3 %r9 - - #define PUSH_NONVOLATILE \ - push %r12 ; \ - push %r13 ; \ - push %rdi ; \ - push %rsi ; \ - push %rbx ; \ - push %rbp ; \ - push %rbp - - #define POP_NONVOLATILE \ - pop %rbp ; \ - pop %rbp ; \ - pop %rbx ; \ - pop %rsi ; \ - pop %rdi ; \ - pop %r13 ; \ - pop %r12 - -#else - - #define ARG0 %rdi - #define ARG1 %rsi - #define ARG2 %rdx - #define ARG3 %rcx - - #define PUSH_NONVOLATILE \ - push %rbx ; \ - push %rbp ; \ - push %r12 ; \ - push %r13 ; \ - push %r13 - - #define POP_NONVOLATILE \ - pop %r13 ; \ - pop %r13 ; \ - pop %r12 ; \ - pop %rbp ; \ - pop %rbx - -#endif - -#define QUOT_XT_OFFSET 36 -#define WORD_XT_OFFSET 66 - -/* We pass a function pointer to memcpy to work around a Mac OS X -ABI limitation which would otherwise require us to do a bizzaro PC-relative -trampoline to retrieve the function address */ -DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy)): - sub ARG2,ARG0 /* compute new stack pointer */ - mov ARG0,%rsp - call *ARG3 /* call memcpy */ - ret /* return _with new stack_ */ - -DEF(F_FASTCALL void,primitive_inline_cache_miss,(void)): - mov (%rsp),ARG0 - sub $STACK_PADDING,%rsp - call MANGLE(inline_cache_miss) - add $STACK_PADDING,%rsp - jmp *%rax - -#include "cpu-x86.S" diff --git a/vmpp/cpu-x86.S b/vmpp/cpu-x86.S deleted file mode 100755 index e83bb0fd7d..0000000000 --- a/vmpp/cpu-x86.S +++ /dev/null @@ -1,74 +0,0 @@ -DEF(void,primitive_fixnum_add,(void)): - mov (DS_REG),ARG0 - mov -CELL_SIZE(DS_REG),ARG1 - sub $CELL_SIZE,DS_REG - mov ARG1,ARITH_TEMP_1 - add ARG0,ARITH_TEMP_1 - jo MANGLE(overflow_fixnum_add) - mov ARITH_TEMP_1,(DS_REG) - ret - -DEF(void,primitive_fixnum_subtract,(void)): - mov (DS_REG),ARG1 - mov -CELL_SIZE(DS_REG),ARG0 - sub $CELL_SIZE,DS_REG - mov ARG0,ARITH_TEMP_1 - sub ARG1,ARITH_TEMP_1 - jo MANGLE(overflow_fixnum_subtract) - mov ARITH_TEMP_1,(DS_REG) - ret - -DEF(void,primitive_fixnum_multiply,(void)): - mov (DS_REG),ARITH_TEMP_1 - mov ARITH_TEMP_1,DIV_RESULT - mov -CELL_SIZE(DS_REG),ARITH_TEMP_2 - sar $3,ARITH_TEMP_2 - sub $CELL_SIZE,DS_REG - imul ARITH_TEMP_2 - jo multiply_overflow - mov DIV_RESULT,(DS_REG) - ret -multiply_overflow: - sar $3,ARITH_TEMP_1 - mov ARITH_TEMP_1,ARG0 - mov ARITH_TEMP_2,ARG1 - jmp MANGLE(overflow_fixnum_multiply) - -DEF(F_FASTCALL void,c_to_factor,(CELL quot)): - PUSH_NONVOLATILE - mov ARG0,NV_TEMP_REG - - /* Create register shadow area for Win64 */ - sub $32,STACK_REG - - /* Save stack pointer */ - lea -CELL_SIZE(STACK_REG),ARG0 - call MANGLE(save_callstack_bottom) - - /* Call quot-xt */ - mov NV_TEMP_REG,ARG0 - call *QUOT_XT_OFFSET(ARG0) - - /* Tear down register shadow area */ - add $32,STACK_REG - - POP_NONVOLATILE - ret - -DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)): - /* rewind_to */ - mov ARG1,STACK_REG - jmp *QUOT_XT_OFFSET(ARG0) - -DEF(F_FASTCALL void,lazy_jit_compile,(CELL quot)): - mov STACK_REG,ARG1 /* Save stack pointer */ - sub $STACK_PADDING,STACK_REG - call MANGLE(lazy_jit_compile_impl) - mov RETURN_REG,ARG0 /* No-op on 32-bit */ - add $STACK_PADDING,STACK_REG - jmp *QUOT_XT_OFFSET(ARG0) /* Call the quotation */ - -#ifdef WINDOWS - .section .drectve - .ascii " -export:c_to_factor" -#endif diff --git a/vmpp/data_gc.h b/vmpp/data_gc.h deleted file mode 100644 index 1def24ae73..0000000000 --- a/vmpp/data_gc.h +++ /dev/null @@ -1,159 +0,0 @@ -void gc(void); -DLLEXPORT void minor_gc(void); - -/* used during garbage collection only */ - -F_ZONE *newspace; -bool performing_gc; -bool performing_compaction; -CELL collecting_gen; - -/* if true, we collecting AGING space for the second time, so if it is still -full, we go on to collect TENURED */ -bool collecting_aging_again; - -/* in case a generation fills up in the middle of a gc, we jump back -up to try collecting the next generation. */ -jmp_buf gc_jmp; - -/* statistics */ -typedef struct { - CELL collections; - u64 gc_time; - u64 max_gc_time; - CELL object_count; - u64 bytes_copied; -} F_GC_STATS; - -F_GC_STATS gc_stats[MAX_GEN_COUNT]; -u64 cards_scanned; -u64 decks_scanned; -u64 card_scan_time; -CELL code_heap_scans; - -/* What generation was being collected when copy_code_heap_roots() was last -called? Until the next call to add_code_block(), future -collections of younger generations don't have to touch the code -heap. */ -CELL last_code_heap_scan; - -/* sometimes we grow the heap */ -bool growing_data_heap; -F_DATA_HEAP *old_data_heap; - -INLINE bool collecting_accumulation_gen_p(void) -{ - return ((HAVE_AGING_P - && collecting_gen == AGING - && !collecting_aging_again) - || collecting_gen == TENURED); -} - -/* test if the pointer is in generation being collected, or a younger one. */ -INLINE bool should_copy(CELL untagged) -{ - if(in_zone(newspace,untagged)) - return false; - if(collecting_gen == TENURED) - return true; - else if(HAVE_AGING_P && collecting_gen == AGING) - return !in_zone(&data_heap->generations[TENURED],untagged); - else if(collecting_gen == NURSERY) - return in_zone(&nursery,untagged); - else - { - critical_error("Bug in should_copy",untagged); - return false; - } -} - -void copy_handle(CELL *handle); - -void garbage_collection(volatile CELL gen, - bool growing_data_heap_, - CELL requested_bytes); - -/* We leave this many bytes free at the top of the nursery so that inline -allocation (which does not call GC because of possible roots in volatile -registers) does not run out of memory */ -#define ALLOT_BUFFER_ZONE 1024 - -/* If this is defined, we GC every allocation. This catches missing local roots */ - -/* - * It is up to the caller to fill in the object's fields in a meaningful - * fashion! - */ - -INLINE void *allot_object(CELL type, CELL a) -{ -#ifdef GC_DEBUG - if(!gc_off) - gc(); -#endif - - CELL *object; - - if(nursery.size - ALLOT_BUFFER_ZONE > a) - { - /* If there is insufficient room, collect the nursery */ - if(nursery.here + ALLOT_BUFFER_ZONE + a > nursery.end) - garbage_collection(NURSERY,false,0); - - CELL h = nursery.here; - nursery.here = h + align8(a); - object = (CELL*)h; - } - /* If the object is bigger than the nursery, allocate it in - tenured space */ - else - { - F_ZONE *tenured = &data_heap->generations[TENURED]; - - /* If tenured space does not have enough room, collect */ - if(tenured->here + a > tenured->end) - { - gc(); - tenured = &data_heap->generations[TENURED]; - } - - /* If it still won't fit, grow the heap */ - if(tenured->here + a > tenured->end) - { - garbage_collection(TENURED,true,a); - tenured = &data_heap->generations[TENURED]; - } - - object = (CELL *)allot_zone(tenured,a); - - /* We have to do this */ - allot_barrier((CELL)object); - - /* Allows initialization code to store old->new pointers - without hitting the write barrier in the common case of - a nursery allocation */ - write_barrier((CELL)object); - } - - *object = tag_header(type); - return object; -} - -void copy_reachable_objects(CELL scan, CELL *end); - -void primitive_gc(void); -void primitive_gc_stats(void); -void clear_gc_stats(void); -void primitive_clear_gc_stats(void); -void primitive_become(void); - -INLINE void check_data_pointer(CELL pointer) -{ -#ifdef FACTOR_DEBUG - if(!growing_data_heap) - { - assert(pointer >= data_heap->segment->start - && pointer < data_heap->segment->end); - } -#endif -} diff --git a/vmpp/factor.rs b/vmpp/factor.rs deleted file mode 100644 index 47f899fef6..0000000000 --- a/vmpp/factor.rs +++ /dev/null @@ -1,2 +0,0 @@ -fraptor ICON "misc/icons/Factor.ico" - diff --git a/vmpp/ffi_test.c b/vmpp/ffi_test.c deleted file mode 100755 index 680b144140..0000000000 --- a/vmpp/ffi_test.c +++ /dev/null @@ -1,321 +0,0 @@ -/* This file is linked into the runtime for the sole purpose - * of testing FFI code. */ -#include "ffi_test.h" - -#include -#include - -void ffi_test_0(void) -{ -} - -int ffi_test_1(void) -{ - return 3; -} - -int ffi_test_2(int x, int y) -{ - return x + y; -} - -int ffi_test_3(int x, int y, int z, int t) -{ - return x + y + z * t; -} - -float ffi_test_4(void) -{ - return 1.5; -} - -double ffi_test_5(void) -{ - return 1.5; -} - -double ffi_test_6(float x, float y) -{ - return x * y; -} - -double ffi_test_7(double x, double y) -{ - return x * y; -} - -double ffi_test_8(double x, float y, double z, float t, int w) -{ - return x * y + z * t + w; -} - -int ffi_test_9(int a, int b, int c, int d, int e, int f, int g) -{ - return a + b + c + d + e + f + g; -} - -int ffi_test_10(int a, int b, double c, int d, float e, int f, int g, int h) -{ - return a - b - c - d - e - f - g - h; -} - -int ffi_test_11(int a, struct foo b, int c) -{ - return a * b.x + c * b.y; -} - -int ffi_test_12(int a, int b, struct rect c, int d, int e, int f) -{ - return a + b + c.x + c.y + c.w + c.h + d + e + f; -} - -int ffi_test_13(int a, int b, int c, int d, int e, int f, int g, int h, int i, int j, int k) -{ - return a + b + c + d + e + f + g + h + i + j + k; -} - -struct foo ffi_test_14(int x, int y) -{ - struct foo r; - r.x = x; r.y = y; - return r; -} - -char *ffi_test_15(char *x, char *y) -{ - if(strcmp(x,y)) - return "foo"; - else - return "bar"; -} - -struct bar ffi_test_16(long x, long y, long z) -{ - struct bar r; - r.x = x; r.y = y; r.z = z; - return r; -} - -struct tiny ffi_test_17(int x) -{ - struct tiny r; - r.x = x; - return r; -} - -F_STDCALL int ffi_test_18(int x, int y, int z, int t) -{ - return x + y + z * t; -} - -F_STDCALL struct bar ffi_test_19(long x, long y, long z) -{ - struct bar r; - r.x = x; r.y = y; r.z = z; - return r; -} - -void ffi_test_20(double x1, double x2, double x3, - double y1, double y2, double y3, - double z1, double z2, double z3) -{ -} - -long long ffi_test_21(long x, long y) -{ - return (long long)x * (long long)y; -} - -long ffi_test_22(long x, long long y, long long z) -{ - return x + y / z; -} - -float ffi_test_23(float x[3], float y[3]) -{ - return x[0] * y[0] + x[1] * y[1] + x[2] * y[2]; -} - -struct test_struct_1 ffi_test_24(void) -{ - struct test_struct_1 s; - s.x = 1; - return s; -} - -struct test_struct_2 ffi_test_25(void) -{ - struct test_struct_2 s; - s.x = 1; - s.y = 2; - return s; -} - -struct test_struct_3 ffi_test_26(void) -{ - struct test_struct_3 s; - s.x = 1; - s.y = 2; - s.z = 3; - return s; -} - -struct test_struct_4 ffi_test_27(void) -{ - struct test_struct_4 s; - s.x = 1; - s.y = 2; - s.z = 3; - s.a = 4; - return s; -} - -struct test_struct_5 ffi_test_28(void) -{ - struct test_struct_5 s; - s.x = 1; - s.y = 2; - s.z = 3; - s.a = 4; - s.b = 5; - return s; -} - -struct test_struct_6 ffi_test_29(void) -{ - struct test_struct_6 s; - s.x = 1; - s.y = 2; - s.z = 3; - s.a = 4; - s.b = 5; - s.c = 6; - return s; -} - -struct test_struct_7 ffi_test_30(void) -{ - struct test_struct_7 s; - s.x = 1; - s.y = 2; - s.z = 3; - s.a = 4; - s.b = 5; - s.c = 6; - s.d = 7; - return s; -} - -int ffi_test_31(int x0, int x1, int x2, int x3, int x4, int x5, int x6, int x7, int x8, int x9, int x10, int x11, int x12, int x13, int x14, int x15, int x16, int x17, int x18, int x19, int x20, int x21, int x22, int x23, int x24, int x25, int x26, int x27, int x28, int x29, int x30, int x31, int x32, int x33, int x34, int x35, int x36, int x37, int x38, int x39, int x40, int x41) -{ - return x0 + x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 + x11 + x12 + x13 + x14 + x15 + x16 + x17 + x18 + x19 + x20 + x21 + x22 + x23 + x24 + x25 + x26 + x27 + x28 + x29 + x30 + x31 + x32 + x33 + x34 + x35 + x36 + x37 + x38 + x39 + x40 + x41; -} - -float ffi_test_31_point_5(float x0, float x1, float x2, float x3, float x4, float x5, float x6, float x7, float x8, float x9, float x10, float x11, float x12, float x13, float x14, float x15, float x16, float x17, float x18, float x19, float x20, float x21, float x22, float x23, float x24, float x25, float x26, float x27, float x28, float x29, float x30, float x31, float x32, float x33, float x34, float x35, float x36, float x37, float x38, float x39, float x40, float x41) -{ - return x0 + x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 + x11 + x12 + x13 + x14 + x15 + x16 + x17 + x18 + x19 + x20 + x21 + x22 + x23 + x24 + x25 + x26 + x27 + x28 + x29 + x30 + x31 + x32 + x33 + x34 + x35 + x36 + x37 + x38 + x39 + x40 + x41; -} - -double ffi_test_32(struct test_struct_8 x, int y) -{ - return (x.x + x.y) * y; -} - -double ffi_test_33(struct test_struct_9 x, int y) -{ - return (x.x + x.y) * y; -} - -double ffi_test_34(struct test_struct_10 x, int y) -{ - return (x.x + x.y) * y; -} - -double ffi_test_35(struct test_struct_11 x, int y) -{ - return (x.x + x.y) * y; -} - -double ffi_test_36(struct test_struct_12 x) -{ - return x.x; -} - -static int global_var; - -void ffi_test_36_point_5(void) -{ - global_var = 0; -} - -int ffi_test_37(int (*f)(int, int, int)) -{ - global_var = f(global_var,global_var * 2,global_var * 3); - return global_var; -} - -unsigned long long ffi_test_38(unsigned long long x, unsigned long long y) -{ - return x * y; -} - -int ffi_test_39(long a, long b, struct test_struct_13 s) -{ - assert(a == b); - return s.x1 + s.x2 + s.x3 + s.x4 + s.x5 + s.x6; -} - -struct test_struct_14 ffi_test_40(double x1, double x2) -{ - struct test_struct_14 retval; - retval.x1 = x1; - retval.x2 = x2; - return retval; -} - -struct test_struct_12 ffi_test_41(int a, double x) -{ - struct test_struct_12 retval; - retval.a = a; - retval.x = x; - return retval; -} - -struct test_struct_15 ffi_test_42(float x, float y) -{ - struct test_struct_15 retval; - retval.x = x; - retval.y = y; - return retval; -} - -struct test_struct_16 ffi_test_43(float x, int a) -{ - struct test_struct_16 retval; - retval.x = x; - retval.a = a; - return retval; -} - -struct test_struct_14 ffi_test_44(void) -{ - struct test_struct_14 retval; - retval.x1 = 1.0; - retval.x2 = 2.0; - return retval; -} - -_Complex float ffi_test_45(int x) -{ - return x; -} - -_Complex double ffi_test_46(int x) -{ - return x; -} - -_Complex float ffi_test_47(_Complex float x, _Complex double y) -{ - return x + 2 * y; -} diff --git a/vmpp/ffi_test.h b/vmpp/ffi_test.h deleted file mode 100755 index f16e52e091..0000000000 --- a/vmpp/ffi_test.h +++ /dev/null @@ -1,98 +0,0 @@ -#if defined(FACTOR_X86) - #define F_STDCALL __attribute__((stdcall)) -#else - #define F_STDCALL -#endif - -#define DLLEXPORT - -DLLEXPORT void ffi_test_0(void); -DLLEXPORT int ffi_test_1(void); -DLLEXPORT int ffi_test_2(int x, int y); -DLLEXPORT int ffi_test_3(int x, int y, int z, int t); -DLLEXPORT float ffi_test_4(void); -DLLEXPORT double ffi_test_5(void); -DLLEXPORT double ffi_test_6(float x, float y); -DLLEXPORT double ffi_test_7(double x, double y); -DLLEXPORT double ffi_test_8(double x, float y, double z, float t, int w); -DLLEXPORT int ffi_test_9(int a, int b, int c, int d, int e, int f, int g); -DLLEXPORT int ffi_test_10(int a, int b, double c, int d, float e, int f, int g, int h); -struct foo { int x, y; }; -DLLEXPORT int ffi_test_11(int a, struct foo b, int c); -struct rect { float x, y, w, h; }; -DLLEXPORT int ffi_test_12(int a, int b, struct rect c, int d, int e, int f); -DLLEXPORT int ffi_test_13(int a, int b, int c, int d, int e, int f, int g, int h, int i, int j, int k); -DLLEXPORT struct foo ffi_test_14(int x, int y); -DLLEXPORT char *ffi_test_15(char *x, char *y); -struct bar { long x, y, z; }; -DLLEXPORT struct bar ffi_test_16(long x, long y, long z); -struct tiny { int x; }; -DLLEXPORT struct tiny ffi_test_17(int x); -DLLEXPORT F_STDCALL int ffi_test_18(int x, int y, int z, int t); -DLLEXPORT F_STDCALL struct bar ffi_test_19(long x, long y, long z); -DLLEXPORT void ffi_test_20(double x1, double x2, double x3, - double y1, double y2, double y3, - double z1, double z2, double z3); -DLLEXPORT long long ffi_test_21(long x, long y); -DLLEXPORT long ffi_test_22(long x, long long y, long long z); -DLLEXPORT float ffi_test_23(float x[3], float y[3]); -struct test_struct_1 { char x; }; -DLLEXPORT struct test_struct_1 ffi_test_24(void); -struct test_struct_2 { char x, y; }; -DLLEXPORT struct test_struct_2 ffi_test_25(void); -struct test_struct_3 { char x, y, z; }; -DLLEXPORT struct test_struct_3 ffi_test_26(void); -struct test_struct_4 { char x, y, z, a; }; -DLLEXPORT struct test_struct_4 ffi_test_27(void); -struct test_struct_5 { char x, y, z, a, b; }; -DLLEXPORT struct test_struct_5 ffi_test_28(void); -struct test_struct_6 { char x, y, z, a, b, c; }; -DLLEXPORT struct test_struct_6 ffi_test_29(void); -struct test_struct_7 { char x, y, z, a, b, c, d; }; -DLLEXPORT struct test_struct_7 ffi_test_30(void); -DLLEXPORT int ffi_test_31(int x0, int x1, int x2, int x3, int x4, int x5, int x6, int x7, int x8, int x9, int x10, int x11, int x12, int x13, int x14, int x15, int x16, int x17, int x18, int x19, int x20, int x21, int x22, int x23, int x24, int x25, int x26, int x27, int x28, int x29, int x30, int x31, int x32, int x33, int x34, int x35, int x36, int x37, int x38, int x39, int x40, int x41); -DLLEXPORT float ffi_test_31_point_5(float x0, float x1, float x2, float x3, float x4, float x5, float x6, float x7, float x8, float x9, float x10, float x11, float x12, float x13, float x14, float x15, float x16, float x17, float x18, float x19, float x20, float x21, float x22, float x23, float x24, float x25, float x26, float x27, float x28, float x29, float x30, float x31, float x32, float x33, float x34, float x35, float x36, float x37, float x38, float x39, float x40, float x41); -struct test_struct_8 { double x; double y; }; -DLLEXPORT double ffi_test_32(struct test_struct_8 x, int y); -struct test_struct_9 { float x; float y; }; -DLLEXPORT double ffi_test_33(struct test_struct_9 x, int y); -struct test_struct_10 { float x; int y; }; -DLLEXPORT double ffi_test_34(struct test_struct_10 x, int y); -struct test_struct_11 { int x; int y; }; -DLLEXPORT double ffi_test_35(struct test_struct_11 x, int y); - -struct test_struct_12 { int a; double x; }; - -DLLEXPORT double ffi_test_36(struct test_struct_12 x); - -DLLEXPORT void ffi_test_36_point_5(void); - -DLLEXPORT int ffi_test_37(int (*f)(int, int, int)); - -DLLEXPORT unsigned long long ffi_test_38(unsigned long long x, unsigned long long y); - -struct test_struct_13 { float x1, x2, x3, x4, x5, x6; }; - -DLLEXPORT int ffi_test_39(long a, long b, struct test_struct_13 s); - -struct test_struct_14 { double x1, x2; }; - -DLLEXPORT struct test_struct_14 ffi_test_40(double x1, double x2); - -DLLEXPORT struct test_struct_12 ffi_test_41(int a, double x); - -struct test_struct_15 { float x, y; }; - -DLLEXPORT struct test_struct_15 ffi_test_42(float x, float y); - -struct test_struct_16 { float x; int a; }; - -DLLEXPORT struct test_struct_16 ffi_test_43(float x, int a); - -DLLEXPORT struct test_struct_14 ffi_test_44(); - -DLLEXPORT _Complex float ffi_test_45(int x); - -DLLEXPORT _Complex double ffi_test_46(int x); - -DLLEXPORT _Complex float ffi_test_47(_Complex float x, _Complex double y); From e3592ca8f62afabb20300311f708f64bbb3be41f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 2 May 2009 20:47:29 -0500 Subject: [PATCH 11/44] Clean up untag_* and tag_* inline functions in favor of more idiomatic C++ --- vm/arrays.hpp | 7 --- vm/bignumint.hpp | 6 +-- vm/byte_arrays.cpp | 8 ++-- vm/byte_arrays.hpp | 2 - vm/callstack.cpp | 18 ++++---- vm/callstack.hpp | 2 - vm/code_block.cpp | 20 ++++---- vm/code_heap.cpp | 27 ++++++----- vm/data_heap.cpp | 14 +++--- vm/debug.cpp | 20 ++++---- vm/dispatch.cpp | 26 +++++------ vm/errors.cpp | 9 +--- vm/errors.hpp | 11 ----- vm/inline_cache.cpp | 10 ++-- vm/io.cpp | 4 +- vm/jit.cpp | 8 ++-- vm/jit.hpp | 5 +- vm/layouts.hpp | 10 +++- vm/math.cpp | 108 ++++++++++++++++++++++---------------------- vm/math.hpp | 32 +++++-------- vm/os-unix.cpp | 2 +- vm/quotations.cpp | 8 ++-- vm/quotations.hpp | 7 --- vm/run.cpp | 16 +++---- vm/run.hpp | 10 +--- vm/strings.cpp | 42 ++++++++--------- vm/strings.hpp | 4 +- vm/tagged.hpp | 2 +- vm/tuples.cpp | 4 +- vm/tuples.hpp | 14 +----- vm/words.cpp | 8 ++-- vm/words.hpp | 4 -- 32 files changed, 205 insertions(+), 263 deletions(-) diff --git a/vm/arrays.hpp b/vm/arrays.hpp index ad1112e81c..dc68779dc0 100644 --- a/vm/arrays.hpp +++ b/vm/arrays.hpp @@ -1,10 +1,3 @@ -DEFINE_UNTAG(F_ARRAY,ARRAY_TYPE,array) - -INLINE CELL tag_array(F_ARRAY *array) -{ - return RETAG(array,ARRAY_TYPE); -} - F_ARRAY *allot_array(CELL capacity, CELL fill); CELL allot_array_1(CELL obj); diff --git a/vm/bignumint.hpp b/vm/bignumint.hpp index 5e0b799090..3e591e7436 100644 --- a/vm/bignumint.hpp +++ b/vm/bignumint.hpp @@ -62,7 +62,7 @@ typedef F_FIXNUM bignum_length_type; #define BIGNUM_START_PTR(bignum) \ ((BIGNUM_TO_POINTER (bignum)) + 1) -#define BIGNUM_LENGTH(bignum) (untag_fixnum_fast((bignum)->capacity) - 1) +#define BIGNUM_LENGTH(bignum) (untag_fixnum((bignum)->capacity) - 1) #define BIGNUM_NEGATIVE_P(bignum) (get(AREF(bignum,0)) != 0) #define BIGNUM_SET_NEGATIVE_P(bignum,neg) put(AREF(bignum,0),neg) @@ -75,9 +75,9 @@ typedef F_FIXNUM bignum_length_type; /* These definitions are here to facilitate caching of the constants 0, 1, and -1. */ -#define BIGNUM_ZERO() untag_bignum_fast(bignum_zero) +#define BIGNUM_ZERO() untag(bignum_zero) #define BIGNUM_ONE(neg_p) \ - untag_bignum_fast(neg_p ? bignum_neg_one : bignum_pos_one) + untag(neg_p ? bignum_neg_one : bignum_pos_one) #define HD_LOW(digit) ((digit) & BIGNUM_HALF_DIGIT_MASK) #define HD_HIGH(digit) ((digit) >> BIGNUM_HALF_DIGIT_LENGTH) diff --git a/vm/byte_arrays.cpp b/vm/byte_arrays.cpp index 389576e1ef..303c0f032a 100644 --- a/vm/byte_arrays.cpp +++ b/vm/byte_arrays.cpp @@ -10,20 +10,20 @@ F_BYTE_ARRAY *allot_byte_array(CELL size) void primitive_byte_array(void) { CELL size = unbox_array_size(); - dpush(tag_object(allot_byte_array(size))); + dpush(tag(allot_byte_array(size))); } void primitive_uninitialized_byte_array(void) { CELL size = unbox_array_size(); - dpush(tag_object(allot_array_internal(size))); + dpush(tag(allot_array_internal(size))); } void primitive_resize_byte_array(void) { - F_BYTE_ARRAY *array = untag_byte_array(dpop()); + F_BYTE_ARRAY *array = untag_check(dpop()); CELL capacity = unbox_array_size(); - dpush(tag_object(reallot_array(array,capacity))); + dpush(tag(reallot_array(array,capacity))); } void growable_byte_array::append_bytes(void *elts, CELL len) diff --git a/vm/byte_arrays.hpp b/vm/byte_arrays.hpp index 6b89a16e48..c5b62a96d6 100644 --- a/vm/byte_arrays.hpp +++ b/vm/byte_arrays.hpp @@ -1,5 +1,3 @@ -DEFINE_UNTAG(F_BYTE_ARRAY,BYTE_ARRAY_TYPE,byte_array) - F_BYTE_ARRAY *allot_byte_array(CELL size); void primitive_byte_array(void); diff --git a/vm/callstack.cpp b/vm/callstack.cpp index 1bbcdff9c5..bb995ab20f 100755 --- a/vm/callstack.cpp +++ b/vm/callstack.cpp @@ -29,7 +29,7 @@ void iterate_callstack(CELL top, CELL bottom, CALLSTACK_ITER iterator) void iterate_callstack_object(F_CALLSTACK *stack, CALLSTACK_ITER iterator) { CELL top = (CELL)FIRST_STACK_FRAME(stack); - CELL bottom = top + untag_fixnum_fast(stack->length); + CELL bottom = top + untag_fixnum(stack->length); iterate_callstack(top,bottom,iterator); } @@ -80,16 +80,16 @@ void primitive_callstack(void) F_CALLSTACK *callstack = allot_callstack(size); memcpy(FIRST_STACK_FRAME(callstack),top,size); - dpush(tag_object(callstack)); + dpush(tag(callstack)); } void primitive_set_callstack(void) { - F_CALLSTACK *stack = untag_callstack(dpop()); + F_CALLSTACK *stack = untag_check(dpop()); set_callstack(stack_chain->callstack_bottom, FIRST_STACK_FRAME(stack), - untag_fixnum_fast(stack->length), + untag_fixnum(stack->length), memcpy); /* We cannot return here ... */ @@ -114,7 +114,7 @@ CELL frame_executing(F_STACK_FRAME *frame) return F; else { - F_ARRAY *array = untag_array_fast(compiled->literals); + F_ARRAY *array = untag(compiled->literals); return array_nth(array,0); } } @@ -174,13 +174,13 @@ void primitive_callstack_to_array(void) frame_index = 0; iterate_callstack_object(callstack.untagged(),stack_frame_to_array); - dpush(tag_array(array)); + dpush(tag(array)); } F_STACK_FRAME *innermost_stack_frame(F_CALLSTACK *callstack) { F_STACK_FRAME *top = FIRST_STACK_FRAME(callstack); - CELL bottom = (CELL)top + untag_fixnum_fast(callstack->length); + CELL bottom = (CELL)top + untag_fixnum(callstack->length); F_STACK_FRAME *frame = (F_STACK_FRAME *)bottom - 1; @@ -195,7 +195,7 @@ Used by the single stepper. */ void primitive_innermost_stack_frame_quot(void) { F_STACK_FRAME *inner = innermost_stack_frame( - untag_callstack(dpop())); + untag_check(dpop())); type_check(QUOTATION_TYPE,frame_executing(inner)); dpush(frame_executing(inner)); @@ -204,7 +204,7 @@ void primitive_innermost_stack_frame_quot(void) void primitive_innermost_stack_frame_scan(void) { F_STACK_FRAME *inner = innermost_stack_frame( - untag_callstack(dpop())); + untag_check(dpop())); type_check(QUOTATION_TYPE,frame_executing(inner)); dpush(frame_scan(inner)); diff --git a/vm/callstack.hpp b/vm/callstack.hpp index 36d35960ac..2468ef623a 100755 --- a/vm/callstack.hpp +++ b/vm/callstack.hpp @@ -3,8 +3,6 @@ INLINE CELL callstack_size(CELL size) return sizeof(F_CALLSTACK) + size; } -DEFINE_UNTAG(F_CALLSTACK,CALLSTACK_TYPE,callstack) - #define FIRST_STACK_FRAME(stack) (F_STACK_FRAME *)((stack) + 1) typedef void (*CALLSTACK_ITER)(F_STACK_FRAME *frame); diff --git a/vm/code_block.cpp b/vm/code_block.cpp index 0d696ce430..8a95b46861 100644 --- a/vm/code_block.cpp +++ b/vm/code_block.cpp @@ -9,7 +9,7 @@ void iterate_relocations(F_CODE_BLOCK *compiled, RELOCATION_ITERATOR iter) { if(compiled->relocation != F) { - F_BYTE_ARRAY *relocation = untag_byte_array_fast(compiled->relocation); + F_BYTE_ARRAY *relocation = untag(compiled->relocation); CELL index = stack_traces_p() ? 1 : 0; @@ -114,7 +114,7 @@ void update_literal_references_step(F_REL rel, CELL index, F_CODE_BLOCK *compile if(REL_TYPE(rel) == RT_IMMEDIATE) { CELL offset = REL_OFFSET(rel) + (CELL)(compiled + 1); - F_ARRAY *literals = untag_array_fast(compiled->literals); + F_ARRAY *literals = untag(compiled->literals); F_FIXNUM absolute_value = array_nth(literals,index); store_address_in_code_block(REL_CLASS(rel),offset,absolute_value); } @@ -156,25 +156,25 @@ CELL object_xt(CELL obj) { if(TAG(obj) == QUOTATION_TYPE) { - F_QUOTATION *quot = untag_quotation_fast(obj); + F_QUOTATION *quot = untag(obj); return (CELL)quot->xt; } else { - F_WORD *word = untag_word_fast(obj); + F_WORD *word = untag(obj); return (CELL)word->xt; } } CELL word_direct_xt(CELL obj) { - F_WORD *word = untag_word_fast(obj); + F_WORD *word = untag(obj); CELL quot = word->direct_entry_def; if(quot == F || max_pic_size == 0) return (CELL)word->xt; else { - F_QUOTATION *untagged = untag_quotation_fast(quot); + F_QUOTATION *untagged = untag(quot); if(untagged->compiledp == F) return (CELL)word->xt; else @@ -188,7 +188,7 @@ void update_word_references_step(F_REL rel, CELL index, F_CODE_BLOCK *compiled) if(type == RT_XT || type == RT_XT_DIRECT) { CELL offset = REL_OFFSET(rel) + (CELL)(compiled + 1); - F_ARRAY *literals = untag_array_fast(compiled->literals); + F_ARRAY *literals = untag(compiled->literals); CELL obj = array_nth(literals,index); CELL xt; @@ -313,7 +313,7 @@ void *get_rel_symbol(F_ARRAY *literals, CELL index) CELL symbol = array_nth(literals,index); CELL library = array_nth(literals,index + 1); - F_DLL *dll = (library == F ? NULL : untag_dll(library)); + F_DLL *dll = (library == F ? NULL : untag(library)); if(dll != NULL && !dll->dll) return (void *)undefined_symbol; @@ -329,7 +329,7 @@ void *get_rel_symbol(F_ARRAY *literals, CELL index) else if(type_of(symbol) == ARRAY_TYPE) { CELL i; - F_ARRAY *names = untag_array_fast(symbol); + F_ARRAY *names = untag(symbol); for(i = 0; i < array_capacity(names); i++) { F_SYMBOL *name = alien_offset(array_nth(names,i)); @@ -352,7 +352,7 @@ void relocate_code_block_step(F_REL rel, CELL index, F_CODE_BLOCK *compiled) #endif CELL offset = REL_OFFSET(rel) + (CELL)(compiled + 1); - F_ARRAY *literals = untag_array_fast(compiled->literals); + F_ARRAY *literals = untag(compiled->literals); F_FIXNUM absolute_value; switch(REL_TYPE(rel)) diff --git a/vm/code_heap.cpp b/vm/code_heap.cpp index c1b6cdbc3e..4d7b3fc410 100755 --- a/vm/code_heap.cpp +++ b/vm/code_heap.cpp @@ -136,25 +136,30 @@ void forward_object_xts(void) while((obj = next_object()) != F) { - if(type_of(obj) == WORD_TYPE) + switch(type_of(obj)) { - F_WORD *word = untag_word_fast(obj); + case WORD_TYPE: + F_WORD *word = untag(obj); word->code = forward_xt(word->code); if(word->profiling) word->profiling = forward_xt(word->profiling); - } - else if(type_of(obj) == QUOTATION_TYPE) - { - F_QUOTATION *quot = untag_quotation_fast(obj); + + break; + case QUOTATION_TYPE: + F_QUOTATION *quot = untag(obj); if(quot->compiledp != F) quot->code = forward_xt(quot->code); - } - else if(type_of(obj) == CALLSTACK_TYPE) - { - F_CALLSTACK *stack = untag_callstack_fast(obj); + + break; + case CALLSTACK_TYPE: + F_CALLSTACK *stack = untag(obj); iterate_callstack_object(stack,forward_frame_xt); + + break; + default: + break; } } @@ -175,7 +180,7 @@ void fixup_object_xts(void) update_word_xt(obj); else if(type_of(obj) == QUOTATION_TYPE) { - F_QUOTATION *quot = untag_quotation_fast(obj); + F_QUOTATION *quot = untag(obj); if(quot->compiledp != F) set_quot_xt(quot,quot->code); diff --git a/vm/data_heap.cpp b/vm/data_heap.cpp index a3ba93ee58..4abc37db23 100644 --- a/vm/data_heap.cpp +++ b/vm/data_heap.cpp @@ -184,8 +184,8 @@ void init_data_heap(CELL gens, gc_locals_region = alloc_segment(getpagesize()); gc_locals = gc_locals_region->start - CELLS; - extra_roots_region = alloc_segment(getpagesize()); - extra_roots = extra_roots_region->start - CELLS; + gc_bignums_region = alloc_segment(getpagesize()); + gc_bignums = gc_bignums_region->start - CELLS; secure_gc = secure_gc_; @@ -224,8 +224,8 @@ CELL unaligned_object_size(CELL pointer) case STRING_TYPE: return string_size(string_capacity((F_STRING*)pointer)); case TUPLE_TYPE: - tuple = untag_tuple_fast(pointer); - layout = untag_tuple_layout(tuple->layout); + tuple = untag(pointer); + layout = untag(tuple->layout); return tuple_size(layout); case QUOTATION_TYPE: return sizeof(F_QUOTATION); @@ -241,7 +241,7 @@ CELL unaligned_object_size(CELL pointer) return sizeof(F_WRAPPER); case CALLSTACK_TYPE: return callstack_size( - untag_fixnum_fast(((F_CALLSTACK *)pointer)->length)); + untag_fixnum(((F_CALLSTACK *)pointer)->length)); default: critical_error("Invalid header",pointer); return -1; /* can't happen */ @@ -284,8 +284,8 @@ CELL binary_payload_start(CELL pointer) case ARRAY_TYPE: return array_size(array_capacity((F_ARRAY*)pointer)); case TUPLE_TYPE: - tuple = untag_tuple_fast(pointer); - layout = untag_tuple_layout(tuple->layout); + tuple = untag(pointer); + layout = untag(tuple->layout); return tuple_size(layout); case WRAPPER_TYPE: return sizeof(F_WRAPPER); diff --git a/vm/debug.cpp b/vm/debug.cpp index 270ed9f0dd..2335e4cfb1 100755 --- a/vm/debug.cpp +++ b/vm/debug.cpp @@ -15,12 +15,12 @@ void print_word(F_WORD* word, CELL nesting) if(type_of(word->vocabulary) == STRING_TYPE) { - print_chars(untag_string(word->vocabulary)); + print_chars(untag(word->vocabulary)); print_string(":"); } if(type_of(word->name) == STRING_TYPE) - print_chars(untag_string(word->name)); + print_chars(untag(word->name)); else { print_string("#layout); + F_TUPLE_LAYOUT *layout = untag(tuple->layout); CELL length = to_fixnum(layout->size); print_string(" "); @@ -102,31 +102,31 @@ void print_nested_obj(CELL obj, F_FIXNUM nesting) switch(type_of(obj)) { case FIXNUM_TYPE: - print_fixnum(untag_fixnum_fast(obj)); + print_fixnum(untag_fixnum(obj)); break; case WORD_TYPE: - print_word(untag_word(obj),nesting - 1); + print_word(untag(obj),nesting - 1); break; case STRING_TYPE: - print_factor_string(untag_string(obj)); + print_factor_string(untag(obj)); break; case F_TYPE: print_string("f"); break; case TUPLE_TYPE: print_string("T{"); - print_tuple(untag_tuple_fast(obj),nesting - 1); + print_tuple(untag(obj),nesting - 1); print_string(" }"); break; case ARRAY_TYPE: print_string("{"); - print_array(untag_array_fast(obj),nesting - 1); + print_array(untag(obj),nesting - 1); print_string(" }"); break; case QUOTATION_TYPE: print_string("["); - quot = untag_quotation_fast(obj); - print_array(untag_array_fast(quot->array),nesting - 1); + quot = untag(obj); + print_array(untag(quot->array),nesting - 1); print_string(" ]"); break; default: diff --git a/vm/dispatch.cpp b/vm/dispatch.cpp index fc76d8b34e..87b172c2d3 100644 --- a/vm/dispatch.cpp +++ b/vm/dispatch.cpp @@ -5,11 +5,11 @@ CELL megamorphic_cache_misses; static CELL search_lookup_alist(CELL table, CELL klass) { - F_ARRAY *pairs = untag_array_fast(table); + F_ARRAY *pairs = untag(table); F_FIXNUM index = array_capacity(pairs) - 1; while(index >= 0) { - F_ARRAY *pair = untag_array_fast(array_nth(pairs,index)); + F_ARRAY *pair = untag(array_nth(pairs,index)); if(array_nth(pair,0) == klass) return array_nth(pair,1); else @@ -21,7 +21,7 @@ static CELL search_lookup_alist(CELL table, CELL klass) static CELL search_lookup_hash(CELL table, CELL klass, CELL hashcode) { - F_ARRAY *buckets = untag_array_fast(table); + F_ARRAY *buckets = untag(table); CELL bucket = array_nth(buckets,hashcode & (array_capacity(buckets) - 1)); if(type_of(bucket) == WORD_TYPE || bucket == F) return bucket; @@ -43,12 +43,12 @@ static CELL nth_hashcode(F_TUPLE_LAYOUT *layout, F_FIXNUM echelon) static CELL lookup_tuple_method(CELL object, CELL methods) { - F_TUPLE *tuple = untag_tuple_fast(object); - F_TUPLE_LAYOUT *layout = untag_tuple_layout(tuple->layout); + F_TUPLE *tuple = untag(object); + F_TUPLE_LAYOUT *layout = untag(tuple->layout); - F_ARRAY *echelons = untag_array_fast(methods); + F_ARRAY *echelons = untag(methods); - F_FIXNUM echelon = untag_fixnum_fast(layout->echelon); + F_FIXNUM echelon = untag_fixnum(layout->echelon); F_FIXNUM max_echelon = array_capacity(echelons) - 1; if(echelon > max_echelon) echelon = max_echelon; @@ -61,7 +61,7 @@ static CELL lookup_tuple_method(CELL object, CELL methods) else if(echelon_methods != F) { CELL klass = nth_superclass(layout,echelon); - CELL hashcode = untag_fixnum_fast(nth_hashcode(layout,echelon)); + CELL hashcode = untag_fixnum(nth_hashcode(layout,echelon)); CELL result = search_lookup_hash(echelon_methods,klass,hashcode); if(result != F) return result; @@ -76,7 +76,7 @@ static CELL lookup_tuple_method(CELL object, CELL methods) static CELL lookup_hi_tag_method(CELL object, CELL methods) { - F_ARRAY *hi_tag_methods = untag_array_fast(methods); + F_ARRAY *hi_tag_methods = untag(methods); CELL tag = hi_tag(object) - HEADER_TYPE; #ifdef FACTOR_DEBUG assert(tag < TYPE_COUNT - HEADER_TYPE); @@ -86,7 +86,7 @@ static CELL lookup_hi_tag_method(CELL object, CELL methods) static CELL lookup_hairy_method(CELL object, CELL methods) { - CELL method = array_nth(untag_array_fast(methods),TAG(object)); + CELL method = array_nth(untag(methods),TAG(object)); if(type_of(method) == WORD_TYPE) return method; else @@ -109,7 +109,7 @@ static CELL lookup_hairy_method(CELL object, CELL methods) CELL lookup_method(CELL object, CELL methods) { if(!HI_TAG_OR_TUPLE_P(object)) - return array_nth(untag_array_fast(methods),TAG(object)); + return array_nth(untag(methods),TAG(object)); else return lookup_hairy_method(object,methods); } @@ -137,7 +137,7 @@ static CELL method_cache_hashcode(CELL klass, F_ARRAY *array) static void update_method_cache(CELL cache, CELL klass, CELL method) { - F_ARRAY *array = untag_array_fast(cache); + F_ARRAY *array = untag(cache); CELL hashcode = method_cache_hashcode(klass,array); set_array_nth(array,hashcode,klass); set_array_nth(array,hashcode + 1,method); @@ -148,7 +148,7 @@ void primitive_mega_cache_miss(void) megamorphic_cache_misses++; CELL cache = dpop(); - F_FIXNUM index = untag_fixnum_fast(dpop()); + F_FIXNUM index = untag_fixnum(dpop()); CELL methods = dpop(); CELL object = get(ds - index * CELLS); diff --git a/vm/errors.cpp b/vm/errors.cpp index 260f4e04c3..81a0b0cc03 100755 --- a/vm/errors.cpp +++ b/vm/errors.cpp @@ -39,7 +39,7 @@ void throw_error(CELL error, F_STACK_FRAME *callstack_top) /* Reset local roots */ gc_locals = gc_locals_region->start - CELLS; - extra_roots = extra_roots_region->start - CELLS; + gc_bignums = gc_bignums_region->start - CELLS; /* If we had an underflow or overflow, stack pointers might be out of bounds */ @@ -114,13 +114,6 @@ void memory_protection_error(CELL addr, F_STACK_FRAME *native_stack) else if(in_page(addr, nursery.end, 0, 0)) critical_error("allot_object() missed GC check",0); else if(in_page(addr, gc_locals_region->start, 0, -1)) - critical_error("gc locals underflow",0); - else if(in_page(addr, gc_locals_region->end, 0, 0)) - critical_error("gc locals overflow",0); - else if(in_page(addr, extra_roots_region->start, 0, -1)) - critical_error("extra roots underflow",0); - else if(in_page(addr, extra_roots_region->end, 0, 0)) - critical_error("extra roots overflow",0); else general_error(ERROR_MEMORY,allot_cell(addr),F,native_stack); } diff --git a/vm/errors.hpp b/vm/errors.hpp index 0fc024de5e..39733646f4 100755 --- a/vm/errors.hpp +++ b/vm/errors.hpp @@ -39,17 +39,6 @@ INLINE void type_check(CELL type, CELL tagged) if(type_of(tagged) != type) type_error(type,tagged); } -#define DEFINE_UNTAG(type,check,name) \ - INLINE type *untag_##name##_fast(CELL obj) \ - { \ - return (type *)UNTAG(obj); \ - } \ - INLINE type *untag_##name(CELL obj) \ - { \ - type_check(check,obj); \ - return untag_##name##_fast(obj); \ - } \ - void primitive_unimplemented(void); /* Global variables used to pass fault handler state from signal handler to diff --git a/vm/inline_cache.cpp b/vm/inline_cache.cpp index cfdae972b0..fa672fd058 100644 --- a/vm/inline_cache.cpp +++ b/vm/inline_cache.cpp @@ -47,7 +47,7 @@ static CELL determine_inline_cache_type(F_ARRAY *cache_entries) switch(type_of(klass)) { case FIXNUM_TYPE: - type = untag_fixnum_fast(klass); + type = untag_fixnum(klass); if(type >= HEADER_TYPE) seen_hi_tag = true; break; @@ -86,7 +86,7 @@ struct inline_cache_jit : public jit { void inline_cache_jit::emit_check(CELL klass) { CELL code_template; - if(TAG(klass) == FIXNUM_TYPE && untag_fixnum_fast(klass) < HEADER_TYPE) + if(TAG(klass) == FIXNUM_TYPE && untag_fixnum(klass) < HEADER_TYPE) code_template = userenv[PIC_CHECK_TAG]; else code_template = userenv[PIC_CHECK]; @@ -152,12 +152,12 @@ static F_CODE_BLOCK *compile_inline_cache(F_FIXNUM index, /* A generic word's definition performs general method lookup. Allocates memory */ static XT megamorphic_call_stub(CELL generic_word) { - return untag_word(generic_word)->xt; + return untag(generic_word)->xt; } static CELL inline_cache_size(CELL cache_entries) { - return array_capacity(untag_array(cache_entries)) / 2; + return array_capacity(untag_check(cache_entries)) / 2; } /* Allocates memory */ @@ -196,7 +196,7 @@ XT inline_cache_miss(CELL return_address) deallocate_inline_cache(return_address); gc_root cache_entries(dpop()); - F_FIXNUM index = untag_fixnum_fast(dpop()); + F_FIXNUM index = untag_fixnum(dpop()); gc_root methods(dpop()); gc_root generic_word(dpop()); gc_root object(get(ds - index * CELLS)); diff --git a/vm/io.cpp b/vm/io.cpp index d32f5b7290..179619e1bd 100755 --- a/vm/io.cpp +++ b/vm/io.cpp @@ -81,7 +81,7 @@ void primitive_fread(void) if(size == 0) { - dpush(tag_object(allot_string(0,0))); + dpush(tag(allot_string(0,0))); return; } @@ -135,7 +135,7 @@ void primitive_fputc(void) void primitive_fwrite(void) { FILE *file = (FILE *)unbox_alien(); - F_BYTE_ARRAY *text = untag_byte_array(dpop()); + F_BYTE_ARRAY *text = untag_check(dpop()); CELL length = array_capacity(text); char *string = (char *)(text + 1); diff --git a/vm/jit.cpp b/vm/jit.cpp index e9018af682..fee8c4684b 100644 --- a/vm/jit.cpp +++ b/vm/jit.cpp @@ -22,7 +22,7 @@ jit::jit(CELL type_, CELL owner_) F_REL jit::rel_to_emit(CELL code_template, bool *rel_p) { - F_ARRAY *quadruple = untag_array_fast(code_template); + F_ARRAY *quadruple = untag(code_template); CELL rel_class = array_nth(quadruple,1); CELL rel_type = array_nth(quadruple,2); CELL offset = array_nth(quadruple,3); @@ -35,9 +35,9 @@ F_REL jit::rel_to_emit(CELL code_template, bool *rel_p) else { *rel_p = true; - return (untag_fixnum_fast(rel_type) << 28) - | (untag_fixnum_fast(rel_class) << 24) - | ((code.count + untag_fixnum_fast(offset))); + return (untag_fixnum(rel_type) << 28) + | (untag_fixnum(rel_class) << 24) + | ((code.count + untag_fixnum(offset))); } } diff --git a/vm/jit.hpp b/vm/jit.hpp index a2233aa4fb..07f33ce2e3 100644 --- a/vm/jit.hpp +++ b/vm/jit.hpp @@ -29,8 +29,9 @@ struct jit { emit_with(userenv[JIT_WORD_CALL],word); } - void emit_subprimitive(CELL word) { - gc_root code_template(untagged(word)->subprimitive); + void emit_subprimitive(CELL word_) { + gc_root word(word_); + gc_root code_template(word->subprimitive); if(array_nth(code_template.untagged(),1) != F) literal(T); emit(code_template.value()); } diff --git a/vm/layouts.hpp b/vm/layouts.hpp index 340d9d3f77..80f35d14a5 100755 --- a/vm/layouts.hpp +++ b/vm/layouts.hpp @@ -68,8 +68,11 @@ INLINE bool immediate_p(CELL obj) return (obj == F || TAG(obj) == FIXNUM_TYPE); } -INLINE F_FIXNUM untag_fixnum_fast(CELL tagged) +INLINE F_FIXNUM untag_fixnum(CELL tagged) { +#ifdef FACTOR_DEBUG + assert(TAG(tagged) == FIXNUM_TYPE); +#endif return ((F_FIXNUM)tagged) >> TAG_BITS; } @@ -80,8 +83,10 @@ INLINE CELL tag_fixnum(F_FIXNUM untagged) typedef void *XT; +#define NO_TYPE_CHECK static const CELL type_number = TYPE_COUNT + struct F_OBJECT { - static const CELL type_number = TYPE_COUNT; + NO_TYPE_CHECK; CELL header; }; @@ -96,6 +101,7 @@ struct F_ARRAY : public F_OBJECT { /* These are really just arrays, but certain elements have special significance */ struct F_TUPLE_LAYOUT : public F_ARRAY { + NO_TYPE_CHECK; /* tagged */ CELL klass; /* tagged fixnum */ diff --git a/vm/math.cpp b/vm/math.cpp index 928f7dab7e..5bb8df8198 100644 --- a/vm/math.cpp +++ b/vm/math.cpp @@ -10,9 +10,9 @@ F_FIXNUM to_fixnum(CELL tagged) switch(TAG(tagged)) { case FIXNUM_TYPE: - return untag_fixnum_fast(tagged); + return untag_fixnum(tagged); case BIGNUM_TYPE: - return bignum_to_fixnum(untag_bignum_fast(tagged)); + return bignum_to_fixnum(untag(tagged)); default: type_error(FIXNUM_TYPE,tagged); return -1; /* can't happen */ @@ -26,7 +26,7 @@ CELL to_cell(CELL tagged) void primitive_bignum_to_fixnum(void) { - drepl(tag_fixnum(bignum_to_fixnum(untag_bignum_fast(dpeek())))); + drepl(tag_fixnum(bignum_to_fixnum(untag(dpeek())))); } void primitive_float_to_fixnum(void) @@ -38,14 +38,14 @@ void primitive_float_to_fixnum(void) overflow, they call these functions. */ F_FASTCALL void overflow_fixnum_add(F_FIXNUM x, F_FIXNUM y) { - drepl(tag_bignum(fixnum_to_bignum( - untag_fixnum_fast(x) + untag_fixnum_fast(y)))); + drepl(tag(fixnum_to_bignum( + untag_fixnum(x) + untag_fixnum(y)))); } F_FASTCALL void overflow_fixnum_subtract(F_FIXNUM x, F_FIXNUM y) { - drepl(tag_bignum(fixnum_to_bignum( - untag_fixnum_fast(x) - untag_fixnum_fast(y)))); + drepl(tag(fixnum_to_bignum( + untag_fixnum(x) - untag_fixnum(y)))); } F_FASTCALL void overflow_fixnum_multiply(F_FIXNUM x, F_FIXNUM y) @@ -54,15 +54,15 @@ F_FASTCALL void overflow_fixnum_multiply(F_FIXNUM x, F_FIXNUM y) REGISTER_BIGNUM(bx); F_BIGNUM *by = fixnum_to_bignum(y); UNREGISTER_BIGNUM(bx); - drepl(tag_bignum(bignum_multiply(bx,by))); + drepl(tag(bignum_multiply(bx,by))); } /* Division can only overflow when we are dividing the most negative fixnum by -1. */ void primitive_fixnum_divint(void) { - F_FIXNUM y = untag_fixnum_fast(dpop()); \ - F_FIXNUM x = untag_fixnum_fast(dpeek()); + F_FIXNUM y = untag_fixnum(dpop()); \ + F_FIXNUM x = untag_fixnum(dpeek()); F_FIXNUM result = x / y; if(result == -FIXNUM_MIN) drepl(allot_integer(-FIXNUM_MIN)); @@ -81,7 +81,7 @@ void primitive_fixnum_divmod(void) } else { - put(ds - CELLS,tag_fixnum(untag_fixnum_fast(x) / untag_fixnum_fast(y))); + put(ds - CELLS,tag_fixnum(untag_fixnum(x) / untag_fixnum(y))); put(ds,(F_FIXNUM)x % (F_FIXNUM)y); } } @@ -96,8 +96,8 @@ void primitive_fixnum_divmod(void) void primitive_fixnum_shift(void) { - F_FIXNUM y = untag_fixnum_fast(dpop()); \ - F_FIXNUM x = untag_fixnum_fast(dpeek()); + F_FIXNUM y = untag_fixnum(dpop()); \ + F_FIXNUM x = untag_fixnum(dpeek()); if(x == 0) return; @@ -117,24 +117,24 @@ void primitive_fixnum_shift(void) } } - drepl(tag_bignum(bignum_arithmetic_shift( + drepl(tag(bignum_arithmetic_shift( fixnum_to_bignum(x),y))); } /* Bignums */ void primitive_fixnum_to_bignum(void) { - drepl(tag_bignum(fixnum_to_bignum(untag_fixnum_fast(dpeek())))); + drepl(tag(fixnum_to_bignum(untag_fixnum(dpeek())))); } void primitive_float_to_bignum(void) { - drepl(tag_bignum(float_to_bignum(dpeek()))); + drepl(tag(float_to_bignum(dpeek()))); } #define POP_BIGNUMS(x,y) \ - F_BIGNUM * y = untag_bignum_fast(dpop()); \ - F_BIGNUM * x = untag_bignum_fast(dpop()); + F_BIGNUM * y = untag(dpop()); \ + F_BIGNUM * x = untag(dpop()); void primitive_bignum_eq(void) { @@ -145,25 +145,25 @@ void primitive_bignum_eq(void) void primitive_bignum_add(void) { POP_BIGNUMS(x,y); - dpush(tag_bignum(bignum_add(x,y))); + dpush(tag(bignum_add(x,y))); } void primitive_bignum_subtract(void) { POP_BIGNUMS(x,y); - dpush(tag_bignum(bignum_subtract(x,y))); + dpush(tag(bignum_subtract(x,y))); } void primitive_bignum_multiply(void) { POP_BIGNUMS(x,y); - dpush(tag_bignum(bignum_multiply(x,y))); + dpush(tag(bignum_multiply(x,y))); } void primitive_bignum_divint(void) { POP_BIGNUMS(x,y); - dpush(tag_bignum(bignum_quotient(x,y))); + dpush(tag(bignum_quotient(x,y))); } void primitive_bignum_divmod(void) @@ -171,39 +171,39 @@ void primitive_bignum_divmod(void) F_BIGNUM *q, *r; POP_BIGNUMS(x,y); bignum_divide(x,y,&q,&r); - dpush(tag_bignum(q)); - dpush(tag_bignum(r)); + dpush(tag(q)); + dpush(tag(r)); } void primitive_bignum_mod(void) { POP_BIGNUMS(x,y); - dpush(tag_bignum(bignum_remainder(x,y))); + dpush(tag(bignum_remainder(x,y))); } void primitive_bignum_and(void) { POP_BIGNUMS(x,y); - dpush(tag_bignum(bignum_bitwise_and(x,y))); + dpush(tag(bignum_bitwise_and(x,y))); } void primitive_bignum_or(void) { POP_BIGNUMS(x,y); - dpush(tag_bignum(bignum_bitwise_ior(x,y))); + dpush(tag(bignum_bitwise_ior(x,y))); } void primitive_bignum_xor(void) { POP_BIGNUMS(x,y); - dpush(tag_bignum(bignum_bitwise_xor(x,y))); + dpush(tag(bignum_bitwise_xor(x,y))); } void primitive_bignum_shift(void) { - F_FIXNUM y = untag_fixnum_fast(dpop()); - F_BIGNUM* x = untag_bignum_fast(dpop()); - dpush(tag_bignum(bignum_arithmetic_shift(x,y))); + F_FIXNUM y = untag_fixnum(dpop()); + F_BIGNUM* x = untag(dpop()); + dpush(tag(bignum_arithmetic_shift(x,y))); } void primitive_bignum_less(void) @@ -232,19 +232,19 @@ void primitive_bignum_greatereq(void) void primitive_bignum_not(void) { - drepl(tag_bignum(bignum_bitwise_not(untag_bignum_fast(dpeek())))); + drepl(tag(bignum_bitwise_not(untag(dpeek())))); } void primitive_bignum_bitp(void) { F_FIXNUM bit = to_fixnum(dpop()); - F_BIGNUM *x = untag_bignum_fast(dpop()); + F_BIGNUM *x = untag(dpop()); box_boolean(bignum_logbitp(bit,x)); } void primitive_bignum_log2(void) { - drepl(tag_bignum(bignum_integer_length(untag_bignum_fast(dpeek())))); + drepl(tag(bignum_integer_length(untag(dpeek())))); } unsigned int bignum_producer(unsigned int digit) @@ -255,9 +255,9 @@ unsigned int bignum_producer(unsigned int digit) void primitive_byte_array_to_bignum(void) { - CELL n_digits = array_capacity(untag_byte_array(dpeek())); + CELL n_digits = array_capacity(untag_check(dpeek())); F_BIGNUM * bignum = digit_stream_to_bignum(n_digits,bignum_producer,0x100,0); - drepl(tag_bignum(bignum)); + drepl(tag(bignum)); } void box_signed_1(s8 n) @@ -303,7 +303,7 @@ void box_unsigned_cell(CELL cell) void box_signed_8(s64 n) { if(n < FIXNUM_MIN || n > FIXNUM_MAX) - dpush(tag_bignum(long_long_to_bignum(n))); + dpush(tag(long_long_to_bignum(n))); else dpush(tag_fixnum(n)); } @@ -313,9 +313,9 @@ s64 to_signed_8(CELL obj) switch(type_of(obj)) { case FIXNUM_TYPE: - return untag_fixnum_fast(obj); + return untag_fixnum(obj); case BIGNUM_TYPE: - return bignum_to_long_long(untag_bignum_fast(obj)); + return bignum_to_long_long(untag(obj)); default: type_error(BIGNUM_TYPE,obj); return -1; @@ -325,7 +325,7 @@ s64 to_signed_8(CELL obj) void box_unsigned_8(u64 n) { if(n > FIXNUM_MAX) - dpush(tag_bignum(ulong_long_to_bignum(n))); + dpush(tag(ulong_long_to_bignum(n))); else dpush(tag_fixnum(n)); } @@ -335,9 +335,9 @@ u64 to_unsigned_8(CELL obj) switch(type_of(obj)) { case FIXNUM_TYPE: - return untag_fixnum_fast(obj); + return untag_fixnum(obj); case BIGNUM_TYPE: - return bignum_to_ulong_long(untag_bignum_fast(obj)); + return bignum_to_ulong_long(untag(obj)); default: type_error(BIGNUM_TYPE,obj); return -1; @@ -350,7 +350,7 @@ CELL unbox_array_size(void) { case FIXNUM_TYPE: { - F_FIXNUM n = untag_fixnum_fast(dpeek()); + F_FIXNUM n = untag_fixnum(dpeek()); if(n >= 0 && n < (F_FIXNUM)ARRAY_SIZE_MAX) { dpop(); @@ -360,9 +360,9 @@ CELL unbox_array_size(void) } case BIGNUM_TYPE: { - F_BIGNUM * zero = untag_bignum_fast(bignum_zero); + F_BIGNUM * zero = untag(bignum_zero); F_BIGNUM * max = cell_to_bignum(ARRAY_SIZE_MAX); - F_BIGNUM * n = untag_bignum_fast(dpeek()); + F_BIGNUM * n = untag(dpeek()); if(bignum_compare(n,zero) != bignum_comparison_less && bignum_compare(n,max) == bignum_comparison_less) { @@ -390,7 +390,7 @@ void primitive_bignum_to_float(void) void primitive_str_to_float(void) { - F_BYTE_ARRAY *bytes = untag_byte_array(dpeek()); + F_BYTE_ARRAY *bytes = untag_check(dpeek()); CELL capacity = array_capacity(bytes); char *c_str = (char *)(bytes + 1); @@ -405,13 +405,13 @@ void primitive_str_to_float(void) void primitive_float_to_str(void) { F_BYTE_ARRAY *array = allot_byte_array(33); - snprintf((char *)(array + 1),32,"%.16g",untag_float(dpop())); - dpush(tag_object(array)); + snprintf((char *)(array + 1),32,"%.16g",untag_float_check(dpop())); + dpush(tag(array)); } #define POP_FLOATS(x,y) \ - double y = untag_float_fast(dpop()); \ - double x = untag_float_fast(dpop()); + double y = untag_float(dpop()); \ + double x = untag_float(dpop()); void primitive_float_eq(void) { @@ -475,7 +475,7 @@ void primitive_float_greatereq(void) void primitive_float_bits(void) { - box_unsigned_4(float_bits(untag_float(dpop()))); + box_unsigned_4(float_bits(untag_float_check(dpop()))); } void primitive_bits_float(void) @@ -485,7 +485,7 @@ void primitive_bits_float(void) void primitive_double_bits(void) { - box_unsigned_8(double_bits(untag_float(dpop()))); + box_unsigned_8(double_bits(untag_float_check(dpop()))); } void primitive_bits_double(void) @@ -495,12 +495,12 @@ void primitive_bits_double(void) float to_float(CELL value) { - return untag_float(value); + return untag_float_check(value); } double to_double(CELL value) { - return untag_float(value); + return untag_float_check(value); } void box_float(float flo) diff --git a/vm/math.hpp b/vm/math.hpp index 20c762d485..2302262c9b 100644 --- a/vm/math.hpp +++ b/vm/math.hpp @@ -21,13 +21,6 @@ extern CELL bignum_zero; extern CELL bignum_pos_one; extern CELL bignum_neg_one; -DEFINE_UNTAG(F_BIGNUM,BIGNUM_TYPE,bignum); - -INLINE CELL tag_bignum(F_BIGNUM* bignum) -{ - return RETAG(bignum,BIGNUM_TYPE); -} - void primitive_fixnum_to_bignum(void); void primitive_float_to_bignum(void); void primitive_bignum_eq(void); @@ -53,7 +46,7 @@ void primitive_byte_array_to_bignum(void); INLINE CELL allot_integer(F_FIXNUM x) { if(x < FIXNUM_MIN || x > FIXNUM_MAX) - return tag_bignum(fixnum_to_bignum(x)); + return tag(fixnum_to_bignum(x)); else return tag_fixnum(x); } @@ -61,7 +54,7 @@ INLINE CELL allot_integer(F_FIXNUM x) INLINE CELL allot_cell(CELL x) { if(x > (CELL)FIXNUM_MAX) - return tag_bignum(cell_to_bignum(x)); + return tag(cell_to_bignum(x)); else return tag_fixnum(x); } @@ -83,15 +76,14 @@ DLLEXPORT u64 to_unsigned_8(CELL obj); CELL unbox_array_size(void); -INLINE double untag_float_fast(CELL tagged) -{ - return ((F_FLOAT *)UNTAG(tagged))->n; -} - INLINE double untag_float(CELL tagged) { - type_check(FLOAT_TYPE,tagged); - return untag_float_fast(tagged); + return untag(tagged)->n; +} + +INLINE double untag_float_check(CELL tagged) +{ + return untag_check(tagged)->n; } INLINE CELL allot_float(double n) @@ -103,22 +95,22 @@ INLINE CELL allot_float(double n) INLINE F_FIXNUM float_to_fixnum(CELL tagged) { - return (F_FIXNUM)untag_float_fast(tagged); + return (F_FIXNUM)untag_float(tagged); } INLINE F_BIGNUM *float_to_bignum(CELL tagged) { - return double_to_bignum(untag_float_fast(tagged)); + return double_to_bignum(untag_float(tagged)); } INLINE double fixnum_to_float(CELL tagged) { - return (double)untag_fixnum_fast(tagged); + return (double)untag_fixnum(tagged); } INLINE double bignum_to_float(CELL tagged) { - return bignum_to_double(untag_bignum_fast(tagged)); + return bignum_to_double(untag(tagged)); } DLLEXPORT void box_float(float flo); diff --git a/vm/os-unix.cpp b/vm/os-unix.cpp index d22b23c854..d8fb09836f 100755 --- a/vm/os-unix.cpp +++ b/vm/os-unix.cpp @@ -55,7 +55,7 @@ void ffi_dlclose(F_DLL *dll) void primitive_existsp(void) { struct stat sb; - char *path = (char *)(untag_byte_array(dpop()) + 1); + char *path = (char *)(untag_check(dpop()) + 1); box_boolean(stat(path,&sb) >= 0); } diff --git a/vm/quotations.cpp b/vm/quotations.cpp index e61f8b36ed..25d48decbb 100755 --- a/vm/quotations.cpp +++ b/vm/quotations.cpp @@ -88,7 +88,7 @@ bool quotation_jit::stack_frame_p() CELL obj = array_nth(array.untagged(),i); if(type_of(obj) == WORD_TYPE) { - if(untagged(obj)->subprimitive == F) + if(untag(obj)->subprimitive == F) return true; } else if(type_of(obj) == QUOTATION_TYPE) @@ -221,7 +221,7 @@ void quotation_jit::iterate_quotation() { emit_mega_cache_lookup( array_nth(array.untagged(),i), - untag_fixnum_fast(array_nth(array.untagged(),i + 1)), + untag_fixnum(array_nth(array.untagged(),i + 1)), array_nth(array.untagged(),i + 2)); i += 3; tail_call = true; @@ -290,12 +290,12 @@ void primitive_array_to_quotation(void) quot->compiledp = F; quot->cached_effect = F; quot->cache_counter = F; - drepl(tag_quotation(quot)); + drepl(tag(quot)); } void primitive_quotation_xt(void) { - F_QUOTATION *quot = untag_quotation(dpeek()); + F_QUOTATION *quot = untag_check(dpeek()); drepl(allot_cell((CELL)quot->xt)); } diff --git a/vm/quotations.hpp b/vm/quotations.hpp index f802f46b64..5cdea06031 100755 --- a/vm/quotations.hpp +++ b/vm/quotations.hpp @@ -1,10 +1,3 @@ -DEFINE_UNTAG(F_QUOTATION,QUOTATION_TYPE,quotation) - -INLINE CELL tag_quotation(F_QUOTATION *quotation) -{ - return RETAG(quotation,QUOTATION_TYPE); -} - struct quotation_jit : public jit { gc_root array; bool compiling, relocate; diff --git a/vm/run.cpp b/vm/run.cpp index 9b46e85f7d..e880255dc5 100755 --- a/vm/run.cpp +++ b/vm/run.cpp @@ -126,7 +126,7 @@ bool stack_to_array(CELL bottom, CELL top) { F_ARRAY *a = allot_array_internal(depth / CELLS); memcpy(a + 1,(void*)bottom,depth); - dpush(tag_array(a)); + dpush(tag(a)); return true; } } @@ -153,12 +153,12 @@ CELL array_to_stack(F_ARRAY *array, CELL bottom) void primitive_set_datastack(void) { - ds = array_to_stack(untag_array(dpop()),ds_bot); + ds = array_to_stack(untag_check(dpop()),ds_bot); } void primitive_set_retainstack(void) { - rs = array_to_stack(untag_array(dpop()),rs_bot); + rs = array_to_stack(untag_check(dpop()),rs_bot); } /* Used to implement call( */ @@ -167,7 +167,7 @@ void primitive_check_datastack(void) F_FIXNUM out = to_fixnum(dpop()); F_FIXNUM in = to_fixnum(dpop()); F_FIXNUM height = out - in; - F_ARRAY *array = untag_array(dpop()); + F_ARRAY *array = untag_check(dpop()); F_FIXNUM length = array_capacity(array); F_FIXNUM depth = (ds - ds_bot + CELLS) / CELLS; if(depth - height != length) @@ -189,13 +189,13 @@ void primitive_check_datastack(void) void primitive_getenv(void) { - F_FIXNUM e = untag_fixnum_fast(dpeek()); + F_FIXNUM e = untag_fixnum(dpeek()); drepl(userenv[e]); } void primitive_setenv(void) { - F_FIXNUM e = untag_fixnum_fast(dpop()); + F_FIXNUM e = untag_fixnum(dpop()); CELL value = dpop(); userenv[e] = value; } @@ -217,7 +217,7 @@ void primitive_sleep(void) void primitive_set_slot(void) { - F_FIXNUM slot = untag_fixnum_fast(dpop()); + F_FIXNUM slot = untag_fixnum(dpop()); CELL obj = dpop(); CELL value = dpop(); set_slot(obj,slot,value); @@ -225,7 +225,7 @@ void primitive_set_slot(void) void primitive_load_locals(void) { - F_FIXNUM count = untag_fixnum_fast(dpop()); + F_FIXNUM count = untag_fixnum(dpop()); memcpy((CELL *)(rs + CELLS),(CELL *)(ds - CELLS * (count - 1)),CELLS * count); ds -= CELLS * count; rs += CELLS * count; diff --git a/vm/run.hpp b/vm/run.hpp index 0b54f94980..3fbc0ec9e8 100755 --- a/vm/run.hpp +++ b/vm/run.hpp @@ -144,7 +144,7 @@ INLINE CELL tag_header(CELL cell) INLINE void check_header(CELL cell) { #ifdef FACTOR_DEBUG - assert(TAG(cell) == FIXNUM_TYPE && untag_fixnum_fast(cell) < TYPE_COUNT); + assert(TAG(cell) == FIXNUM_TYPE && untag_fixnum(cell) < TYPE_COUNT); #endif } @@ -159,14 +159,6 @@ INLINE CELL hi_tag(CELL tagged) return untag_header(get(UNTAG(tagged))); } -INLINE CELL tag_object(void *cell) -{ -#ifdef FACTOR_DEBUG - assert(hi_tag((CELL)cell) >= HEADER_TYPE); -#endif - return RETAG(cell,OBJECT_TYPE); -} - INLINE CELL type_of(CELL tagged) { CELL tag = TAG(tagged); diff --git a/vm/strings.cpp b/vm/strings.cpp index a01e9ea4d9..fe8059a996 100644 --- a/vm/strings.cpp +++ b/vm/strings.cpp @@ -12,7 +12,7 @@ CELL string_nth(F_STRING* string, CELL index) return ch; else { - F_BYTE_ARRAY *aux = untag_byte_array_fast(string->aux); + F_BYTE_ARRAY *aux = untag(string->aux); return (cget(BREF(aux,index * sizeof(u16))) << 7) ^ ch; } } @@ -39,14 +39,14 @@ void set_string_nth_slow(F_STRING *string_, CELL index, CELL ch) character is set. Initially all of the bits are clear. */ aux = allot_array_internal( - untag_fixnum_fast(string->length) + untag_fixnum(string->length) * sizeof(u16)); write_barrier(string.value()); - string->aux = tag_object(aux); + string->aux = tag(aux); } else - aux = untag_byte_array_fast(string->aux); + aux = untag(string->aux); cput(BREF(aux,index * sizeof(u16)),(ch >> 7) ^ 1); } @@ -100,7 +100,7 @@ void primitive_string(void) { CELL initial = to_cell(dpop()); CELL length = unbox_array_size(); - dpush(tag_object(allot_string(length,initial))); + dpush(tag(allot_string(length,initial))); } static bool reallot_string_in_place_p(F_STRING *string, CELL capacity) @@ -118,7 +118,7 @@ F_STRING* reallot_string(F_STRING *string_, CELL capacity) if(string->aux != F) { - F_BYTE_ARRAY *aux = untag_byte_array_fast(string->aux); + F_BYTE_ARRAY *aux = untag(string->aux); aux->capacity = tag_fixnum(capacity * 2); } @@ -139,9 +139,9 @@ F_STRING* reallot_string(F_STRING *string_, CELL capacity) F_BYTE_ARRAY *new_aux = allot_byte_array(capacity * sizeof(u16)); write_barrier(new_string.value()); - new_string->aux = tag_object(new_aux); + new_string->aux = tag(new_aux); - F_BYTE_ARRAY *aux = untag_byte_array_fast(string->aux); + F_BYTE_ARRAY *aux = untag(string->aux); memcpy(new_aux + 1,aux + 1,to_copy * sizeof(u16)); } @@ -152,38 +152,38 @@ F_STRING* reallot_string(F_STRING *string_, CELL capacity) void primitive_resize_string(void) { - F_STRING* string = untag_string(dpop()); + F_STRING* string = untag_check(dpop()); CELL capacity = unbox_array_size(); - dpush(tag_object(reallot_string(string,capacity))); + dpush(tag(reallot_string(string,capacity))); } void primitive_string_nth(void) { - F_STRING *string = untag_string_fast(dpop()); - CELL index = untag_fixnum_fast(dpop()); + F_STRING *string = untag(dpop()); + CELL index = untag_fixnum(dpop()); dpush(tag_fixnum(string_nth(string,index))); } void primitive_set_string_nth(void) { - F_STRING *string = untag_string_fast(dpop()); - CELL index = untag_fixnum_fast(dpop()); - CELL value = untag_fixnum_fast(dpop()); + F_STRING *string = untag(dpop()); + CELL index = untag_fixnum(dpop()); + CELL value = untag_fixnum(dpop()); set_string_nth(string,index,value); } void primitive_set_string_nth_fast(void) { - F_STRING *string = untag_string_fast(dpop()); - CELL index = untag_fixnum_fast(dpop()); - CELL value = untag_fixnum_fast(dpop()); + F_STRING *string = untag(dpop()); + CELL index = untag_fixnum(dpop()); + CELL value = untag_fixnum(dpop()); set_string_nth_fast(string,index,value); } void primitive_set_string_nth_slow(void) { - F_STRING *string = untag_string_fast(dpop()); - CELL index = untag_fixnum_fast(dpop()); - CELL value = untag_fixnum_fast(dpop()); + F_STRING *string = untag(dpop()); + CELL index = untag_fixnum(dpop()); + CELL value = untag_fixnum(dpop()); set_string_nth_slow(string,index,value); } diff --git a/vm/strings.hpp b/vm/strings.hpp index 5545e7e3b4..c482595b87 100644 --- a/vm/strings.hpp +++ b/vm/strings.hpp @@ -1,6 +1,6 @@ INLINE CELL string_capacity(F_STRING *str) { - return untag_fixnum_fast(str->length); + return untag_fixnum(str->length); } INLINE CELL string_size(CELL size) @@ -11,8 +11,6 @@ INLINE CELL string_size(CELL size) #define BREF(byte_array,index) ((CELL)byte_array + sizeof(F_BYTE_ARRAY) + (index)) #define SREF(string,index) ((CELL)string + sizeof(F_STRING) + (index)) -DEFINE_UNTAG(F_STRING,STRING_TYPE,string) - F_STRING* allot_string_internal(CELL capacity); F_STRING* allot_string(CELL capacity, CELL fill); void primitive_string(void); diff --git a/vm/tagged.hpp b/vm/tagged.hpp index 86f31f8281..9bf9118d7f 100644 --- a/vm/tagged.hpp +++ b/vm/tagged.hpp @@ -49,7 +49,7 @@ template T *untag_check(CELL value) return tagged(value).untag_check(); } -template T *untagged(CELL value) +template T *untag(CELL value) { return tagged(value).untagged(); } diff --git a/vm/tuples.cpp b/vm/tuples.cpp index 63ea924559..8e77bfaee1 100644 --- a/vm/tuples.cpp +++ b/vm/tuples.cpp @@ -17,7 +17,7 @@ void primitive_tuple(void) for(i = tuple_size(layout.untagged()) - 1; i >= 0; i--) put(AREF(tuple,i),F); - dpush(tag_tuple(tuple)); + dpush(tag(tuple)); } /* push a new tuple on the stack, filling its slots from the stack */ @@ -25,7 +25,7 @@ void primitive_tuple_boa(void) { gc_root layout(dpop()); gc_root tuple(allot_tuple(layout.value())); - CELL size = untag_fixnum_fast(layout.untagged()->size) * CELLS; + CELL size = untag_fixnum(layout.untagged()->size) * CELLS; memcpy(tuple.untagged() + 1,(CELL *)(ds - (size - CELLS)),size); ds -= size; dpush(tuple.value()); diff --git a/vm/tuples.hpp b/vm/tuples.hpp index 832be71b04..1d6317a5ab 100644 --- a/vm/tuples.hpp +++ b/vm/tuples.hpp @@ -1,21 +1,9 @@ -INLINE CELL tag_tuple(F_TUPLE *tuple) -{ - return RETAG(tuple,TUPLE_TYPE); -} - INLINE CELL tuple_size(F_TUPLE_LAYOUT *layout) { - CELL size = untag_fixnum_fast(layout->size); + CELL size = untag_fixnum(layout->size); return sizeof(F_TUPLE) + size * CELLS; } -DEFINE_UNTAG(F_TUPLE,TUPLE_TYPE,tuple) - -INLINE F_TUPLE_LAYOUT *untag_tuple_layout(CELL obj) -{ - return (F_TUPLE_LAYOUT *)UNTAG(obj); -} - INLINE CELL tuple_nth(F_TUPLE *tuple, CELL slot) { return get(AREF(tuple,slot)); diff --git a/vm/words.cpp b/vm/words.cpp index 53d6e4d795..fe5fb327a9 100644 --- a/vm/words.cpp +++ b/vm/words.cpp @@ -32,13 +32,13 @@ void primitive_word(void) { CELL vocab = dpop(); CELL name = dpop(); - dpush(tag_object(allot_word(vocab,name))); + dpush(tag(allot_word(vocab,name))); } /* word-xt ( word -- start end ) */ void primitive_word_xt(void) { - F_WORD *word = untag_word(dpop()); + F_WORD *word = untag_check(dpop()); F_CODE_BLOCK *code = (profiling_p ? word->profiling : word->code); dpush(allot_cell((CELL)code + sizeof(F_CODE_BLOCK))); dpush(allot_cell((CELL)code + code->block.size)); @@ -65,12 +65,12 @@ void update_word_xt(CELL word_) void primitive_optimized_p(void) { - drepl(tag_boolean(word_optimized_p(untag_word(dpeek())))); + drepl(tag_boolean(word_optimized_p(untag_check(dpeek())))); } void primitive_wrapper(void) { F_WRAPPER *wrapper = allot(sizeof(F_WRAPPER)); wrapper->object = dpeek(); - drepl(tag_object(wrapper)); + drepl(tag(wrapper)); } diff --git a/vm/words.hpp b/vm/words.hpp index 94912adc97..aa29d46bd7 100644 --- a/vm/words.hpp +++ b/vm/words.hpp @@ -1,5 +1,3 @@ -DEFINE_UNTAG(F_WORD,WORD_TYPE,word) - F_WORD *allot_word(CELL vocab, CELL name); void primitive_word(void); @@ -13,6 +11,4 @@ INLINE bool word_optimized_p(F_WORD *word) void primitive_optimized_p(void); -DEFINE_UNTAG(F_WRAPPER,WRAPPER_TYPE,wrapper) - void primitive_wrapper(void); From ec28b1ef85f9fdab77aaf449e770dd72e1aefd18 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 3 May 2009 05:48:03 -0500 Subject: [PATCH 12/44] Various VM cleanups, new approach for bignum GC root registration --- Makefile | 5 +- vm/bignum.cpp | 112 ++++++------------ vm/callstack.cpp | 5 +- vm/data_gc.cpp | 275 ++++++++++++++++++++++++--------------------- vm/data_gc.h | 159 -------------------------- vm/data_gc.hpp | 3 - vm/data_heap.cpp | 4 +- vm/errors.cpp | 1 - vm/local_roots.cpp | 4 +- vm/local_roots.hpp | 20 ++-- vm/math.cpp | 4 +- 11 files changed, 211 insertions(+), 381 deletions(-) delete mode 100644 vm/data_gc.h diff --git a/Makefile b/Makefile index a21711b916..8c07a656b8 100755 --- a/Makefile +++ b/Makefile @@ -179,6 +179,9 @@ clean: rm -f vm/*.o rm -f factor*.dll libfactor.{a,so,dylib} libfactor-ffi-test.{a,so,dylib} Factor.app/Contents/Frameworks/libfactor.dylib +tags: + etags vm/*.{cpp,hpp,mm,S,c} + vm/resources.o: $(WINDRES) vm/factor.rs vm/resources.o @@ -197,6 +200,6 @@ vm/ffi_test.o: vm/ffi_test.c .mm.o: $(CPP) -c $(CFLAGS) -o $@ $< -.PHONY: factor +.PHONY: factor tags clean .SUFFIXES: .mm diff --git a/vm/bignum.cpp b/vm/bignum.cpp index 3a665f22d3..72356ff556 100755 --- a/vm/bignum.cpp +++ b/vm/bignum.cpp @@ -505,6 +505,8 @@ bignum_compare_unsigned(F_BIGNUM * x, F_BIGNUM * y) F_BIGNUM * bignum_add_unsigned(F_BIGNUM * x, F_BIGNUM * y, int negative_p) { + GC_BIGNUM(x); GC_BIGNUM(y); + if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x))) { F_BIGNUM * z = x; @@ -514,11 +516,7 @@ bignum_add_unsigned(F_BIGNUM * x, F_BIGNUM * y, int negative_p) { bignum_length_type x_length = (BIGNUM_LENGTH (x)); - REGISTER_BIGNUM(x); - REGISTER_BIGNUM(y); F_BIGNUM * r = (allot_bignum ((x_length + 1), negative_p)); - UNREGISTER_BIGNUM(y); - UNREGISTER_BIGNUM(x); bignum_digit_type sum; bignum_digit_type carry = 0; @@ -575,6 +573,8 @@ bignum_add_unsigned(F_BIGNUM * x, F_BIGNUM * y, int negative_p) F_BIGNUM * bignum_subtract_unsigned(F_BIGNUM * x, F_BIGNUM * y) { + GC_BIGNUM(x); GC_BIGNUM(y); + int negative_p = 0; switch (bignum_compare_unsigned (x, y)) { @@ -595,11 +595,7 @@ bignum_subtract_unsigned(F_BIGNUM * x, F_BIGNUM * y) { bignum_length_type x_length = (BIGNUM_LENGTH (x)); - REGISTER_BIGNUM(x); - REGISTER_BIGNUM(y); F_BIGNUM * r = (allot_bignum (x_length, negative_p)); - UNREGISTER_BIGNUM(y); - UNREGISTER_BIGNUM(x); bignum_digit_type difference; bignum_digit_type borrow = 0; @@ -656,6 +652,8 @@ bignum_subtract_unsigned(F_BIGNUM * x, F_BIGNUM * y) F_BIGNUM * bignum_multiply_unsigned(F_BIGNUM * x, F_BIGNUM * y, int negative_p) { + GC_BIGNUM(x); GC_BIGNUM(y); + if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x))) { F_BIGNUM * z = x; @@ -674,12 +672,8 @@ bignum_multiply_unsigned(F_BIGNUM * x, F_BIGNUM * y, int negative_p) bignum_length_type x_length = (BIGNUM_LENGTH (x)); bignum_length_type y_length = (BIGNUM_LENGTH (y)); - REGISTER_BIGNUM(x); - REGISTER_BIGNUM(y); F_BIGNUM * r = (allot_bignum_zeroed ((x_length + y_length), negative_p)); - UNREGISTER_BIGNUM(y); - UNREGISTER_BIGNUM(x); bignum_digit_type * scan_x = (BIGNUM_START_PTR (x)); bignum_digit_type * end_x = (scan_x + x_length); @@ -731,11 +725,11 @@ F_BIGNUM * bignum_multiply_unsigned_small_factor(F_BIGNUM * x, bignum_digit_type y, int negative_p) { + GC_BIGNUM(x); + bignum_length_type length_x = (BIGNUM_LENGTH (x)); - REGISTER_BIGNUM(x); F_BIGNUM * p = (allot_bignum ((length_x + 1), negative_p)); - UNREGISTER_BIGNUM(x); bignum_destructive_copy (x, p); (BIGNUM_REF (p, length_x)) = 0; @@ -813,24 +807,20 @@ bignum_divide_unsigned_large_denominator(F_BIGNUM * numerator, int q_negative_p, int r_negative_p) { + GC_BIGNUM(numerator); GC_BIGNUM(denominator); + bignum_length_type length_n = ((BIGNUM_LENGTH (numerator)) + 1); bignum_length_type length_d = (BIGNUM_LENGTH (denominator)); - REGISTER_BIGNUM(numerator); - REGISTER_BIGNUM(denominator); - F_BIGNUM * q = ((quotient != ((F_BIGNUM * *) 0)) ? (allot_bignum ((length_n - length_d), q_negative_p)) : BIGNUM_OUT_OF_BAND); - - REGISTER_BIGNUM(q); + GC_BIGNUM(q); + F_BIGNUM * u = (allot_bignum (length_n, r_negative_p)); - UNREGISTER_BIGNUM(q); - - UNREGISTER_BIGNUM(denominator); - UNREGISTER_BIGNUM(numerator); - + GC_BIGNUM(u); + int shift = 0; BIGNUM_ASSERT (length_d > 1); { @@ -849,15 +839,7 @@ bignum_divide_unsigned_large_denominator(F_BIGNUM * numerator, } else { - REGISTER_BIGNUM(numerator); - REGISTER_BIGNUM(denominator); - REGISTER_BIGNUM(u); - REGISTER_BIGNUM(q); F_BIGNUM * v = (allot_bignum (length_d, 0)); - UNREGISTER_BIGNUM(q); - UNREGISTER_BIGNUM(u); - UNREGISTER_BIGNUM(denominator); - UNREGISTER_BIGNUM(numerator); bignum_destructive_normalization (numerator, u, shift); bignum_destructive_normalization (denominator, v, shift); @@ -866,14 +848,10 @@ bignum_divide_unsigned_large_denominator(F_BIGNUM * numerator, bignum_destructive_unnormalization (u, shift); } - REGISTER_BIGNUM(u); if(q) q = bignum_trim (q); - UNREGISTER_BIGNUM(u); - REGISTER_BIGNUM(q); u = bignum_trim (u); - UNREGISTER_BIGNUM(q); if (quotient != ((F_BIGNUM * *) 0)) (*quotient) = q; @@ -1047,9 +1025,13 @@ bignum_divide_unsigned_medium_denominator(F_BIGNUM * numerator, int q_negative_p, int r_negative_p) { + GC_BIGNUM(numerator); + bignum_length_type length_n = (BIGNUM_LENGTH (numerator)); bignum_length_type length_q; - F_BIGNUM * q; + F_BIGNUM * q = NULL; + GC_BIGNUM(q); + int shift = 0; /* Because `bignum_digit_divide' requires a normalized denominator. */ while (denominator < (BIGNUM_RADIX / 2)) @@ -1061,20 +1043,14 @@ bignum_divide_unsigned_medium_denominator(F_BIGNUM * numerator, { length_q = length_n; - REGISTER_BIGNUM(numerator); q = (allot_bignum (length_q, q_negative_p)); - UNREGISTER_BIGNUM(numerator); - bignum_destructive_copy (numerator, q); } else { length_q = (length_n + 1); - REGISTER_BIGNUM(numerator); q = (allot_bignum (length_q, q_negative_p)); - UNREGISTER_BIGNUM(numerator); - bignum_destructive_normalization (numerator, q, shift); } { @@ -1096,9 +1072,7 @@ bignum_divide_unsigned_medium_denominator(F_BIGNUM * numerator, if (shift != 0) r >>= shift; - REGISTER_BIGNUM(q); (*remainder) = (bignum_digit_to_bignum (r, r_negative_p)); - UNREGISTER_BIGNUM(q); } if (quotient != ((F_BIGNUM * *) 0)) @@ -1295,20 +1269,17 @@ bignum_divide_unsigned_small_denominator(F_BIGNUM * numerator, int q_negative_p, int r_negative_p) { - REGISTER_BIGNUM(numerator); + GC_BIGNUM(numerator); + F_BIGNUM * q = (bignum_new_sign (numerator, q_negative_p)); - UNREGISTER_BIGNUM(numerator); + GC_BIGNUM(q); bignum_digit_type r = (bignum_destructive_scale_down (q, denominator)); q = (bignum_trim (q)); if (remainder != ((F_BIGNUM * *) 0)) - { - REGISTER_BIGNUM(q); (*remainder) = (bignum_digit_to_bignum (r, r_negative_p)); - UNREGISTER_BIGNUM(q); - } (*quotient) = q; @@ -1381,6 +1352,7 @@ bignum_digit_to_bignum(bignum_digit_type digit, int negative_p) F_BIGNUM * allot_bignum(bignum_length_type length, int negative_p) { + gc(); BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX)); F_BIGNUM * result = allot_array_internal(length + 1); BIGNUM_SET_NEGATIVE_P (result, negative_p); @@ -1441,10 +1413,8 @@ bignum_trim(F_BIGNUM * bignum) F_BIGNUM * bignum_new_sign(F_BIGNUM * bignum, int negative_p) { - REGISTER_BIGNUM(bignum); - F_BIGNUM * result = - (allot_bignum ((BIGNUM_LENGTH (bignum)), negative_p)); - UNREGISTER_BIGNUM(bignum); + GC_BIGNUM(bignum); + F_BIGNUM * result = (allot_bignum ((BIGNUM_LENGTH (bignum)), negative_p)); bignum_destructive_copy (bignum, result); return (result); @@ -1553,6 +1523,8 @@ bignum_bitwise_xor(F_BIGNUM * arg1, F_BIGNUM * arg2) F_BIGNUM * bignum_magnitude_ash(F_BIGNUM * arg1, F_FIXNUM n) { + GC_BIGNUM(arg1); + F_BIGNUM * result = NULL; bignum_digit_type *scan1; bignum_digit_type *scanr; @@ -1566,10 +1538,8 @@ bignum_magnitude_ash(F_BIGNUM * arg1, F_FIXNUM n) digit_offset = n / BIGNUM_DIGIT_LENGTH; bit_offset = n % BIGNUM_DIGIT_LENGTH; - REGISTER_BIGNUM(arg1); result = allot_bignum_zeroed (BIGNUM_LENGTH (arg1) + digit_offset + 1, - BIGNUM_NEGATIVE_P(arg1)); - UNREGISTER_BIGNUM(arg1); + BIGNUM_NEGATIVE_P(arg1)); scanr = BIGNUM_START_PTR (result) + digit_offset; scan1 = BIGNUM_START_PTR (arg1); @@ -1591,10 +1561,8 @@ bignum_magnitude_ash(F_BIGNUM * arg1, F_FIXNUM n) digit_offset = -n / BIGNUM_DIGIT_LENGTH; bit_offset = -n % BIGNUM_DIGIT_LENGTH; - REGISTER_BIGNUM(arg1); result = allot_bignum_zeroed (BIGNUM_LENGTH (arg1) - digit_offset, - BIGNUM_NEGATIVE_P(arg1)); - UNREGISTER_BIGNUM(arg1); + BIGNUM_NEGATIVE_P(arg1)); scanr = BIGNUM_START_PTR (result); scan1 = BIGNUM_START_PTR (arg1) + digit_offset; @@ -1617,6 +1585,8 @@ bignum_magnitude_ash(F_BIGNUM * arg1, F_FIXNUM n) F_BIGNUM * bignum_pospos_bitwise_op(int op, F_BIGNUM * arg1, F_BIGNUM * arg2) { + GC_BIGNUM(arg1); GC_BIGNUM(arg2); + F_BIGNUM * result; bignum_length_type max_length; @@ -1627,11 +1597,7 @@ bignum_pospos_bitwise_op(int op, F_BIGNUM * arg1, F_BIGNUM * arg2) max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2)) ? BIGNUM_LENGTH(arg1) : BIGNUM_LENGTH(arg2); - REGISTER_BIGNUM(arg1); - REGISTER_BIGNUM(arg2); result = allot_bignum(max_length, 0); - UNREGISTER_BIGNUM(arg2); - UNREGISTER_BIGNUM(arg1); scanr = BIGNUM_START_PTR(result); scan1 = BIGNUM_START_PTR(arg1); @@ -1654,6 +1620,8 @@ bignum_pospos_bitwise_op(int op, F_BIGNUM * arg1, F_BIGNUM * arg2) F_BIGNUM * bignum_posneg_bitwise_op(int op, F_BIGNUM * arg1, F_BIGNUM * arg2) { + GC_BIGNUM(arg1); GC_BIGNUM(arg2); + F_BIGNUM * result; bignum_length_type max_length; @@ -1666,11 +1634,7 @@ bignum_posneg_bitwise_op(int op, F_BIGNUM * arg1, F_BIGNUM * arg2) max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2) + 1) ? BIGNUM_LENGTH(arg1) : BIGNUM_LENGTH(arg2) + 1; - REGISTER_BIGNUM(arg1); - REGISTER_BIGNUM(arg2); result = allot_bignum(max_length, neg_p); - UNREGISTER_BIGNUM(arg2); - UNREGISTER_BIGNUM(arg1); scanr = BIGNUM_START_PTR(result); scan1 = BIGNUM_START_PTR(arg1); @@ -1709,6 +1673,8 @@ bignum_posneg_bitwise_op(int op, F_BIGNUM * arg1, F_BIGNUM * arg2) F_BIGNUM * bignum_negneg_bitwise_op(int op, F_BIGNUM * arg1, F_BIGNUM * arg2) { + GC_BIGNUM(arg1); GC_BIGNUM(arg2); + F_BIGNUM * result; bignum_length_type max_length; @@ -1721,11 +1687,7 @@ bignum_negneg_bitwise_op(int op, F_BIGNUM * arg1, F_BIGNUM * arg2) max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2)) ? BIGNUM_LENGTH(arg1) + 1 : BIGNUM_LENGTH(arg2) + 1; - REGISTER_BIGNUM(arg1); - REGISTER_BIGNUM(arg2); result = allot_bignum(max_length, neg_p); - UNREGISTER_BIGNUM(arg2); - UNREGISTER_BIGNUM(arg1); scanr = BIGNUM_START_PTR(result); scan1 = BIGNUM_START_PTR(arg1); @@ -1800,12 +1762,12 @@ bignum_negate_magnitude(F_BIGNUM * arg) F_BIGNUM * bignum_integer_length(F_BIGNUM * bignum) { + GC_BIGNUM(bignum); + bignum_length_type index = ((BIGNUM_LENGTH (bignum)) - 1); bignum_digit_type digit = (BIGNUM_REF (bignum, index)); - REGISTER_BIGNUM(bignum); F_BIGNUM * result = (allot_bignum (2, 0)); - UNREGISTER_BIGNUM(bignum); (BIGNUM_REF (result, 0)) = index; (BIGNUM_REF (result, 1)) = 0; diff --git a/vm/callstack.cpp b/vm/callstack.cpp index bb995ab20f..f7c56d378c 100755 --- a/vm/callstack.cpp +++ b/vm/callstack.cpp @@ -3,7 +3,7 @@ static void check_frame(F_STACK_FRAME *frame) { #ifdef FACTOR_DEBUG - check_code_pointer(frame->xt); + check_code_pointer((CELL)frame->xt); assert(frame->size != 0); #endif } @@ -20,9 +20,8 @@ void iterate_callstack(CELL top, CELL bottom, CALLSTACK_ITER iterator) while((CELL)frame >= top) { - F_STACK_FRAME *next = frame_successor(frame); iterator(frame); - frame = next; + frame = frame_successor(frame); } } diff --git a/vm/data_gc.cpp b/vm/data_gc.cpp index 634d44ab2c..b6c24ba4f9 100755 --- a/vm/data_gc.cpp +++ b/vm/data_gc.cpp @@ -37,8 +37,109 @@ void init_data_gc(void) collecting_aging_again = false; } +/* Given a pointer to oldspace, copy it to newspace */ +static void *copy_untagged_object(void *pointer, CELL size) +{ + if(newspace->here + size >= newspace->end) + longjmp(gc_jmp,1); + allot_barrier(newspace->here); + void *newpointer = allot_zone(newspace,size); + + F_GC_STATS *s = &gc_stats[collecting_gen]; + s->object_count++; + s->bytes_copied += size; + + memcpy(newpointer,pointer,size); + return newpointer; +} + +static void forward_object(CELL untagged, CELL newpointer) +{ + put(untagged,RETAG(newpointer,GC_COLLECTED)); +} + +static CELL copy_object_impl(CELL untagged) +{ + CELL newpointer = (CELL)copy_untagged_object( + (void*)untagged, + untagged_object_size(untagged)); + forward_object(untagged,newpointer); + return newpointer; +} + +static bool should_copy_p(CELL untagged) +{ + if(in_zone(newspace,untagged)) + return false; + if(collecting_gen == TENURED) + return true; + else if(HAVE_AGING_P && collecting_gen == AGING) + return !in_zone(&data_heap->generations[TENURED],untagged); + else if(collecting_gen == NURSERY) + return in_zone(&nursery,untagged); + else + { + critical_error("Bug in should_copy_p",untagged); + return false; + } +} + +/* Follow a chain of forwarding pointers */ +static CELL resolve_forwarding(CELL untagged, CELL tag) +{ + check_data_pointer(untagged); + + CELL header = get(untagged); + /* another forwarding pointer */ + if(TAG(header) == GC_COLLECTED) + return resolve_forwarding(UNTAG(header),tag); + /* we've found the destination */ + else + { + check_header(header); + CELL pointer = RETAG(untagged,tag); + if(should_copy_p(untagged)) + pointer = RETAG(copy_object_impl(untagged),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. While this preserves the tag, it does +not dispatch on it in any way. */ +static CELL copy_object(CELL pointer) +{ + check_data_pointer(pointer); + + CELL tag = TAG(pointer); + CELL untagged = UNTAG(pointer); + CELL header = get(untagged); + + if(TAG(header) == GC_COLLECTED) + return resolve_forwarding(UNTAG(header),tag); + else + { + check_header(header); + return RETAG(copy_object_impl(untagged),tag); + } +} + +void copy_handle(CELL *handle) +{ + CELL pointer = *handle; + + if(!immediate_p(pointer)) + { + check_data_pointer(pointer); + if(should_copy_p(pointer)) + *handle = copy_object(pointer); + } +} + /* Scan all the objects in the card */ -void copy_card(F_CARD *ptr, CELL gen, CELL here) +static void copy_card(F_CARD *ptr, CELL gen, CELL here) { CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + CARD_OFFSET(ptr); CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1); @@ -51,7 +152,7 @@ void copy_card(F_CARD *ptr, CELL gen, CELL here) cards_scanned++; } -void copy_card_deck(F_DECK *deck, CELL gen, F_CARD mask, F_CARD unmask) +static void copy_card_deck(F_DECK *deck, CELL gen, F_CARD mask, F_CARD unmask) { F_CARD *first_card = DECK_TO_CARD(deck); F_CARD *last_card = DECK_TO_CARD(deck + 1); @@ -83,7 +184,7 @@ void copy_card_deck(F_DECK *deck, CELL gen, F_CARD mask, F_CARD unmask) } /* Copy all newspace objects referenced from marked cards to the destination */ -void copy_gen_cards(CELL gen) +static void copy_gen_cards(CELL gen) { F_DECK *first_deck = ADDR_TO_DECK(data_heap->generations[gen].start); F_DECK *last_deck = ADDR_TO_DECK(data_heap->generations[gen].end); @@ -150,7 +251,7 @@ void copy_gen_cards(CELL gen) /* Scan cards in all generations older than the one being collected, copying old->new references */ -void copy_cards(void) +static void copy_cards(void) { u64 start = current_micros(); @@ -162,7 +263,7 @@ void copy_cards(void) } /* Copy all tagged pointers in a range of memory */ -void copy_stack_elements(F_SEGMENT *region, CELL top) +static void copy_stack_elements(F_SEGMENT *region, CELL top) { CELL ptr = region->start; @@ -170,17 +271,38 @@ void copy_stack_elements(F_SEGMENT *region, CELL top) copy_handle((CELL*)ptr); } -void copy_registered_locals(void) +static void copy_registered_locals(void) { - CELL ptr = gc_locals_region->start; + CELL scan = gc_locals_region->start; - for(; ptr <= gc_locals; ptr += CELLS) - copy_handle(*(CELL **)ptr); + for(; scan <= gc_locals; scan += CELLS) + copy_handle(*(CELL **)scan); +} + +static void copy_registered_bignums(void) +{ + CELL scan = gc_bignums_region->start; + + for(; scan <= gc_bignums; scan += CELLS) + { + CELL *handle = *(CELL **)scan; + CELL pointer = *handle; + + if(pointer) + { + check_data_pointer(pointer); + if(should_copy_p(pointer)) + *handle = copy_object(pointer); +#ifdef FACTOR_DEBUG + assert(hi_tag(*handle) == BIGNUM_TYPE); +#endif + } + } } /* Copy roots over at the start of GC, namely various constants, stacks, the user environment and extra roots registered by local_roots.hpp */ -void copy_roots(void) +static void copy_roots(void) { copy_handle(&T); copy_handle(&bignum_zero); @@ -188,7 +310,7 @@ void copy_roots(void) copy_handle(&bignum_neg_one); copy_registered_locals(); - copy_stack_elements(extra_roots_region,extra_roots); + copy_registered_bignums(); if(!performing_compaction) { @@ -214,107 +336,7 @@ void copy_roots(void) copy_handle(&userenv[i]); } -/* Given a pointer to oldspace, copy it to newspace */ -INLINE void *copy_untagged_object(void *pointer, CELL size) -{ - if(newspace->here + size >= newspace->end) - longjmp(gc_jmp,1); - allot_barrier(newspace->here); - void *newpointer = allot_zone(newspace,size); - - F_GC_STATS *s = &gc_stats[collecting_gen]; - s->object_count++; - s->bytes_copied += size; - - memcpy(newpointer,pointer,size); - return newpointer; -} - -INLINE void forward_object(CELL pointer, CELL newpointer) -{ - if(pointer != newpointer) - put(UNTAG(pointer),RETAG(newpointer,GC_COLLECTED)); -} - -INLINE CELL copy_object_impl(CELL pointer) -{ - CELL newpointer = (CELL)copy_untagged_object( - (void*)UNTAG(pointer), - object_size(pointer)); - forward_object(pointer,newpointer); - return newpointer; -} - -bool should_copy_p(CELL untagged) -{ - if(in_zone(newspace,untagged)) - return false; - if(collecting_gen == TENURED) - return true; - else if(HAVE_AGING_P && collecting_gen == AGING) - return !in_zone(&data_heap->generations[TENURED],untagged); - else if(collecting_gen == NURSERY) - return in_zone(&nursery,untagged); - else - { - critical_error("Bug in should_copy_p",untagged); - return false; - } -} - -/* Follow a chain of forwarding pointers */ -CELL resolve_forwarding(CELL untagged, CELL tag) -{ - check_data_pointer(untagged); - - CELL header = get(untagged); - /* another forwarding pointer */ - if(TAG(header) == GC_COLLECTED) - return resolve_forwarding(UNTAG(header),tag); - /* we've found the destination */ - else - { - check_header(header); - CELL pointer = RETAG(untagged,tag); - if(should_copy_p(untagged)) - pointer = RETAG(copy_object_impl(pointer),tag); - return pointer; - } -} - -/* Given a pointer to a tagged pointer to oldspace, copy it to newspace. -If the object has already been copied, return the forwarding -pointer address without copying anything; otherwise, install -a new forwarding pointer. */ -INLINE CELL copy_object(CELL pointer) -{ - check_data_pointer(pointer); - - CELL tag = TAG(pointer); - CELL header = get(UNTAG(pointer)); - - if(TAG(header) == GC_COLLECTED) - return resolve_forwarding(UNTAG(header),tag); - else - { - check_header(header); - return RETAG(copy_object_impl(pointer),tag); - } -} - -void copy_handle(CELL *handle) -{ - CELL pointer = *handle; - - if(!immediate_p(pointer)) - { - check_data_pointer(pointer); - if(should_copy_p(pointer)) - *handle = copy_object(pointer); - } -} - -CELL copy_next_from_nursery(CELL scan) +static CELL copy_next_from_nursery(CELL scan) { CELL *obj = (CELL *)scan; CELL *end = (CELL *)(scan + binary_payload_start(scan)); @@ -342,7 +364,7 @@ CELL copy_next_from_nursery(CELL scan) return scan + untagged_object_size(scan); } -CELL copy_next_from_aging(CELL scan) +static CELL copy_next_from_aging(CELL scan) { CELL *obj = (CELL *)scan; CELL *end = (CELL *)(scan + binary_payload_start(scan)); @@ -374,7 +396,7 @@ CELL copy_next_from_aging(CELL scan) return scan + untagged_object_size(scan); } -CELL copy_next_from_tenured(CELL scan) +static CELL copy_next_from_tenured(CELL scan) { CELL *obj = (CELL *)scan; CELL *end = (CELL *)(scan + binary_payload_start(scan)); @@ -424,7 +446,7 @@ void copy_reachable_objects(CELL scan, CELL *end) } /* Prepare to start copying reachable objects into an unused zone */ -void begin_gc(CELL requested_bytes) +static void begin_gc(CELL requested_bytes) { if(growing_data_heap) { @@ -457,7 +479,7 @@ void begin_gc(CELL requested_bytes) } } -void end_gc(CELL gc_elapsed) +static void end_gc(CELL gc_elapsed) { F_GC_STATS *s = &gc_stats[collecting_gen]; @@ -604,19 +626,19 @@ void primitive_gc_stats(void) { F_GC_STATS *s = &gc_stats[i]; stats.add(allot_cell(s->collections)); - stats.add(tag_bignum(long_long_to_bignum(s->gc_time))); - stats.add(tag_bignum(long_long_to_bignum(s->max_gc_time))); + stats.add(tag(long_long_to_bignum(s->gc_time))); + stats.add(tag(long_long_to_bignum(s->max_gc_time))); stats.add(allot_cell(s->collections == 0 ? 0 : s->gc_time / s->collections)); stats.add(allot_cell(s->object_count)); - stats.add(tag_bignum(long_long_to_bignum(s->bytes_copied))); + stats.add(tag(long_long_to_bignum(s->bytes_copied))); total_gc_time += s->gc_time; } - stats.add(tag_bignum(ulong_long_to_bignum(total_gc_time))); - stats.add(tag_bignum(ulong_long_to_bignum(cards_scanned))); - stats.add(tag_bignum(ulong_long_to_bignum(decks_scanned))); - stats.add(tag_bignum(ulong_long_to_bignum(card_scan_time))); + stats.add(tag(ulong_long_to_bignum(total_gc_time))); + stats.add(tag(ulong_long_to_bignum(cards_scanned))); + stats.add(tag(ulong_long_to_bignum(decks_scanned))); + stats.add(tag(ulong_long_to_bignum(card_scan_time))); stats.add(allot_cell(code_heap_scans)); stats.trim(); @@ -644,8 +666,8 @@ void primitive_clear_gc_stats(void) to coalesce equal but distinct quotations and wrappers. */ void primitive_become(void) { - F_ARRAY *new_objects = untag_array(dpop()); - F_ARRAY *old_objects = untag_array(dpop()); + F_ARRAY *new_objects = untag_check(dpop()); + F_ARRAY *old_objects = untag_check(dpop()); CELL capacity = array_capacity(new_objects); if(capacity != array_capacity(old_objects)) @@ -658,7 +680,8 @@ void primitive_become(void) CELL old_obj = array_nth(old_objects,i); CELL new_obj = array_nth(new_objects,i); - forward_object(old_obj,new_obj); + if(old_obj != new_obj) + forward_object(UNTAG(old_obj),new_obj); } gc(); diff --git a/vm/data_gc.h b/vm/data_gc.h deleted file mode 100644 index 1def24ae73..0000000000 --- a/vm/data_gc.h +++ /dev/null @@ -1,159 +0,0 @@ -void gc(void); -DLLEXPORT void minor_gc(void); - -/* used during garbage collection only */ - -F_ZONE *newspace; -bool performing_gc; -bool performing_compaction; -CELL collecting_gen; - -/* if true, we collecting AGING space for the second time, so if it is still -full, we go on to collect TENURED */ -bool collecting_aging_again; - -/* in case a generation fills up in the middle of a gc, we jump back -up to try collecting the next generation. */ -jmp_buf gc_jmp; - -/* statistics */ -typedef struct { - CELL collections; - u64 gc_time; - u64 max_gc_time; - CELL object_count; - u64 bytes_copied; -} F_GC_STATS; - -F_GC_STATS gc_stats[MAX_GEN_COUNT]; -u64 cards_scanned; -u64 decks_scanned; -u64 card_scan_time; -CELL code_heap_scans; - -/* What generation was being collected when copy_code_heap_roots() was last -called? Until the next call to add_code_block(), future -collections of younger generations don't have to touch the code -heap. */ -CELL last_code_heap_scan; - -/* sometimes we grow the heap */ -bool growing_data_heap; -F_DATA_HEAP *old_data_heap; - -INLINE bool collecting_accumulation_gen_p(void) -{ - return ((HAVE_AGING_P - && collecting_gen == AGING - && !collecting_aging_again) - || collecting_gen == TENURED); -} - -/* test if the pointer is in generation being collected, or a younger one. */ -INLINE bool should_copy(CELL untagged) -{ - if(in_zone(newspace,untagged)) - return false; - if(collecting_gen == TENURED) - return true; - else if(HAVE_AGING_P && collecting_gen == AGING) - return !in_zone(&data_heap->generations[TENURED],untagged); - else if(collecting_gen == NURSERY) - return in_zone(&nursery,untagged); - else - { - critical_error("Bug in should_copy",untagged); - return false; - } -} - -void copy_handle(CELL *handle); - -void garbage_collection(volatile CELL gen, - bool growing_data_heap_, - CELL requested_bytes); - -/* We leave this many bytes free at the top of the nursery so that inline -allocation (which does not call GC because of possible roots in volatile -registers) does not run out of memory */ -#define ALLOT_BUFFER_ZONE 1024 - -/* If this is defined, we GC every allocation. This catches missing local roots */ - -/* - * It is up to the caller to fill in the object's fields in a meaningful - * fashion! - */ - -INLINE void *allot_object(CELL type, CELL a) -{ -#ifdef GC_DEBUG - if(!gc_off) - gc(); -#endif - - CELL *object; - - if(nursery.size - ALLOT_BUFFER_ZONE > a) - { - /* If there is insufficient room, collect the nursery */ - if(nursery.here + ALLOT_BUFFER_ZONE + a > nursery.end) - garbage_collection(NURSERY,false,0); - - CELL h = nursery.here; - nursery.here = h + align8(a); - object = (CELL*)h; - } - /* If the object is bigger than the nursery, allocate it in - tenured space */ - else - { - F_ZONE *tenured = &data_heap->generations[TENURED]; - - /* If tenured space does not have enough room, collect */ - if(tenured->here + a > tenured->end) - { - gc(); - tenured = &data_heap->generations[TENURED]; - } - - /* If it still won't fit, grow the heap */ - if(tenured->here + a > tenured->end) - { - garbage_collection(TENURED,true,a); - tenured = &data_heap->generations[TENURED]; - } - - object = (CELL *)allot_zone(tenured,a); - - /* We have to do this */ - allot_barrier((CELL)object); - - /* Allows initialization code to store old->new pointers - without hitting the write barrier in the common case of - a nursery allocation */ - write_barrier((CELL)object); - } - - *object = tag_header(type); - return object; -} - -void copy_reachable_objects(CELL scan, CELL *end); - -void primitive_gc(void); -void primitive_gc_stats(void); -void clear_gc_stats(void); -void primitive_clear_gc_stats(void); -void primitive_become(void); - -INLINE void check_data_pointer(CELL pointer) -{ -#ifdef FACTOR_DEBUG - if(!growing_data_heap) - { - assert(pointer >= data_heap->segment->start - && pointer < data_heap->segment->end); - } -#endif -} diff --git a/vm/data_gc.hpp b/vm/data_gc.hpp index 2e508c93a5..f84f9f0699 100755 --- a/vm/data_gc.hpp +++ b/vm/data_gc.hpp @@ -28,9 +28,6 @@ INLINE bool collecting_accumulation_gen_p(void) extern CELL last_code_heap_scan; -/* test if the pointer is in generation being collected, or a younger one. */ -bool should_copy_p(CELL untagged); - void copy_handle(CELL *handle); void garbage_collection(volatile CELL gen, diff --git a/vm/data_heap.cpp b/vm/data_heap.cpp index 4abc37db23..ea206c6b3f 100644 --- a/vm/data_heap.cpp +++ b/vm/data_heap.cpp @@ -224,7 +224,7 @@ CELL unaligned_object_size(CELL pointer) case STRING_TYPE: return string_size(string_capacity((F_STRING*)pointer)); case TUPLE_TYPE: - tuple = untag(pointer); + tuple = (F_TUPLE *)pointer; layout = untag(tuple->layout); return tuple_size(layout); case QUOTATION_TYPE: @@ -284,7 +284,7 @@ CELL binary_payload_start(CELL pointer) case ARRAY_TYPE: return array_size(array_capacity((F_ARRAY*)pointer)); case TUPLE_TYPE: - tuple = untag(pointer); + tuple = (F_TUPLE *)pointer; layout = untag(tuple->layout); return tuple_size(layout); case WRAPPER_TYPE: diff --git a/vm/errors.cpp b/vm/errors.cpp index 81a0b0cc03..0404022802 100755 --- a/vm/errors.cpp +++ b/vm/errors.cpp @@ -113,7 +113,6 @@ void memory_protection_error(CELL addr, F_STACK_FRAME *native_stack) general_error(ERROR_RS_OVERFLOW,F,F,native_stack); else if(in_page(addr, nursery.end, 0, 0)) critical_error("allot_object() missed GC check",0); - else if(in_page(addr, gc_locals_region->start, 0, -1)) else general_error(ERROR_MEMORY,allot_cell(addr),F,native_stack); } diff --git a/vm/local_roots.cpp b/vm/local_roots.cpp index 14822f82ee..05d5602f0e 100644 --- a/vm/local_roots.cpp +++ b/vm/local_roots.cpp @@ -3,5 +3,5 @@ F_SEGMENT *gc_locals_region; CELL gc_locals; -F_SEGMENT *extra_roots_region; -CELL extra_roots; +F_SEGMENT *gc_bignums_region; +CELL gc_bignums; diff --git a/vm/local_roots.hpp b/vm/local_roots.hpp index 34b51222f3..3f57afcdaf 100644 --- a/vm/local_roots.hpp +++ b/vm/local_roots.hpp @@ -20,12 +20,18 @@ struct gc_root : public tagged ~gc_root() { CELL old = gc_local_pop(); assert(old == (CELL)this); } }; -/* Extra roots: stores pointers to objects in the heap. Requires extra work -(you have to unregister before accessing the object) but more flexible. */ -extern F_SEGMENT *extra_roots_region; -extern CELL extra_roots; +/* A similar hack for the bignum implementation */ +extern F_SEGMENT *gc_bignums_region; +extern CELL gc_bignums; -DEFPUSHPOP(root_,extra_roots) +DEFPUSHPOP(gc_bignum_,gc_bignums) -#define REGISTER_BIGNUM(obj) if(obj) root_push(tag_bignum(obj)) -#define UNREGISTER_BIGNUM(obj) if(obj) obj = (untag_bignum_fast(root_pop())) +struct gc_bignum +{ + F_BIGNUM **addr; + + gc_bignum(F_BIGNUM **addr_) : addr(addr_) { if(*addr_) check_data_pointer((CELL)*addr_); gc_bignum_push((CELL)addr); } + ~gc_bignum() { assert((CELL)addr == gc_bignum_pop()); } +}; + +#define GC_BIGNUM(x) gc_bignum x##__gc_root(&x) diff --git a/vm/math.cpp b/vm/math.cpp index 5bb8df8198..e3f9354b09 100644 --- a/vm/math.cpp +++ b/vm/math.cpp @@ -51,9 +51,9 @@ F_FASTCALL void overflow_fixnum_subtract(F_FIXNUM x, F_FIXNUM y) F_FASTCALL void overflow_fixnum_multiply(F_FIXNUM x, F_FIXNUM y) { F_BIGNUM *bx = fixnum_to_bignum(x); - REGISTER_BIGNUM(bx); + GC_BIGNUM(bx); F_BIGNUM *by = fixnum_to_bignum(y); - UNREGISTER_BIGNUM(bx); + GC_BIGNUM(by); drepl(tag(bignum_multiply(bx,by))); } From f9ae9033b6c17d8f4d12458262baf99753b89c72 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sun, 3 May 2009 13:46:37 +0200 Subject: [PATCH 13/44] reworked primary key handling and define-persistent for tuples --- .../tuple/collection/collection.factor | 105 ++++++++++++++---- extra/mongodb/tuple/index/authors.txt | 1 - extra/mongodb/tuple/index/index.factor | 56 ---------- extra/mongodb/tuple/index/summary.txt | 1 - .../tuple/persistent/persistent.factor | 28 +++-- extra/mongodb/tuple/state/state.factor | 27 ----- extra/mongodb/tuple/tuple.factor | 31 +++--- 7 files changed, 112 insertions(+), 137 deletions(-) delete mode 100644 extra/mongodb/tuple/index/authors.txt delete mode 100644 extra/mongodb/tuple/index/index.factor delete mode 100644 extra/mongodb/tuple/index/summary.txt diff --git a/extra/mongodb/tuple/collection/collection.factor b/extra/mongodb/tuple/collection/collection.factor index a4f86cd6a3..1bd2d94e69 100644 --- a/extra/mongodb/tuple/collection/collection.factor +++ b/extra/mongodb/tuple/collection/collection.factor @@ -1,51 +1,96 @@ USING: accessors arrays assocs bson.constants classes classes.tuple combinators continuations fry kernel mongodb.driver sequences strings -vectors words combinators.smart literals ; +vectors words combinators.smart literals memoize slots constructors ; IN: mongodb.tuple -SINGLETONS: +transient+ +load+ ; +SINGLETONS: +transient+ +load+ +user-defined-key+ ; + +: ( name key -- index-spec ) + index-spec new swap >>key swap >>name ; IN: mongodb.tuple.collection -FROM: mongodb.tuple => +transient+ +load+ ; +TUPLE: toid key value ; + +CONSTRUCTOR: toid ( value key -- toid ) ; + +FROM: mongodb.tuple => +transient+ +load+ ; MIXIN: mdb-persistent +SLOT: id SLOT: _id SLOT: _mfd + + +: >toid ( object -- toid ) + [ id>> ] [ class id-slot ] bi ; + +M: mdb-persistent id>> ( object -- id ) + dup class id-slot reader-word execute( object -- id ) ; + +M: mdb-persistent (>>id) ( object value -- ) + over class id-slot writer-word execute( object value -- ) ; + + + TUPLE: mdb-tuple-collection < mdb-collection { classes } ; GENERIC: tuple-collection ( object -- mdb-collection ) -GENERIC: mdb-slot-map ( tuple -- string ) +GENERIC: mdb-slot-map ( tuple -- assoc ) + +GENERIC: mdb-index-map ( tuple -- sequence ) assoc ( seq -- assoc ) - [ dup assoc? - [ 1array { "" } append ] unless ] map ; - : optl>map ( seq -- map ) - H{ } clone tuck - '[ split-optl opt>assoc swap _ set-at ] each ; inline + [ H{ } clone ] dip over + '[ split-optl swap _ set-at ] each ; inline + +: index-list>map ( seq -- map ) + [ H{ } clone ] dip over + '[ dup name>> _ set-at ] each ; inline + +: user-defined-key ( map -- key value ? ) + [ nip [ +user-defined-key+ ] dip member? ] assoc-find ; inline + +: user-defined-key-index ( class -- assoc ) + mdb-slot-map user-defined-key + [ drop [ "user-defined-key-index" 1 ] dip + H{ } clone [ set-at ] keep unique-index + [ ] [ name>> ] bi H{ } clone [ set-at ] keep + ] [ 2drop H{ } clone ] if ; PRIVATE> @@ -65,9 +110,15 @@ PRIVATE> over all-slots [ name>> ] map [ MDB_OID_FIELD ] dip member? [ ] [ MDB_ADDON_SLOTS prepend ] if ; inline -: set-slot-map ( class options -- ) - optl>map MDB_SLOTDEF_LIST set-word-prop ; inline - +: set-slot-map ( class option-list -- ) + optl>map [ MDB_SLOTDEF_MAP set-word-prop ] 2keep + user-defined-key + [ drop MDB_USER_KEY set-word-prop ] [ 3drop ] if ; inline + +: set-index-map ( class index-list -- ) + [ [ dup user-defined-key-index ] dip index-list>map ] output>sequence + assoc-combine MDB_INDEX_MAP set-word-prop ; inline + M: tuple-class tuple-collection ( tuple -- mdb-collection ) (mdb-collection) ; @@ -83,6 +134,13 @@ M: tuple-class mdb-slot-map ( class -- assoc ) M: mdb-collection mdb-slot-map ( collection -- assoc ) classes>> [ mdb-slot-map ] map assoc-combine ; +M: mdb-persistent mdb-index-map + class (mdb-index-map) ; +M: tuple-class mdb-index-map + (mdb-index-map) ; +M: mdb-collection mdb-index-map + classes>> [ mdb-index-map ] map assoc-combine ; + GENERIC: ( name -- mdb-tuple-collection ) -M: string ( name -- mdb-tuple-collection ) +M: string collection-map [ ] [ key? ] 2bi [ at ] [ [ mdb-tuple-collection new dup ] 2dip [ [ >>name ] keep ] dip set-at ] if ; inline -M: mdb-tuple-collection ( mdb-tuple-collection -- mdb-tuple-collection ) ; -M: mdb-collection ( mdb-collection -- mdb-tuple-collection ) +M: mdb-tuple-collection ; +M: mdb-collection [ name>> ] keep { [ capped>> >>capped ] @@ -110,6 +168,9 @@ M: mdb-collection ( mdb-collection -- mdb-tuple-collectio [ max>> >>max ] } cleave ; +: user-defined-key? ( tuple slot -- ? ) + +user-defined-key+ slot-option? ; + : transient-slot? ( tuple slot -- ? ) +transient+ slot-option? ; diff --git a/extra/mongodb/tuple/index/authors.txt b/extra/mongodb/tuple/index/authors.txt deleted file mode 100644 index 5df962bfe0..0000000000 --- a/extra/mongodb/tuple/index/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Sascha Matzke diff --git a/extra/mongodb/tuple/index/index.factor b/extra/mongodb/tuple/index/index.factor deleted file mode 100644 index 1e7a679df3..0000000000 --- a/extra/mongodb/tuple/index/index.factor +++ /dev/null @@ -1,56 +0,0 @@ -USING: kernel fry accessors formatting linked-assocs assocs sequences sequences.deep -mongodb.tuple.collection combinators mongodb.tuple.collection ; - -IN: mongodb.tuple - -SINGLETONS: +fieldindex+ +compoundindex+ +deepindex+ ; - -IN: mongodb.tuple.index - -TUPLE: tuple-index name spec ; - - ] 2dip - [ rest ] keep first ! assoc slot options itype - { { +fieldindex+ [ drop [ 1 ] dip pick set-at ] } - { +deepindex+ [ first "%s.%s" sprintf [ 1 ] dip pick set-at ] } - { +compoundindex+ [ - 2over swap [ 1 ] 2dip set-at [ drop ] dip ! assoc options - over '[ _ [ 1 ] 2dip set-at ] each ] } - } case ; - -: build-index-seq ( slot optlist -- index-seq ) - [ V{ } clone ] 2dip pick ! v{} slot optl v{} - [ swap ] dip ! v{} optl slot v{ } - '[ _ tuple-index new ! element slot exemplar - 2over swap index-name >>name ! element slot clone - [ build-index ] dip swap >>spec _ push - ] each ; - -: is-index-declaration? ( entry -- ? ) - first - { { +fieldindex+ [ t ] } - { +compoundindex+ [ t ] } - { +deepindex+ [ t ] } - [ drop f ] } case ; - -PRIVATE> - -: tuple-index-list ( mdb-collection/class -- seq ) - mdb-slot-map V{ } clone tuck - '[ [ is-index-declaration? ] filter - build-index-seq _ push - ] assoc-each flatten ; - diff --git a/extra/mongodb/tuple/index/summary.txt b/extra/mongodb/tuple/index/summary.txt deleted file mode 100644 index e4a15492be..0000000000 --- a/extra/mongodb/tuple/index/summary.txt +++ /dev/null @@ -1 +0,0 @@ -tuple class index handling diff --git a/extra/mongodb/tuple/persistent/persistent.factor b/extra/mongodb/tuple/persistent/persistent.factor index 061b27dd1b..fc521eca3e 100644 --- a/extra/mongodb/tuple/persistent/persistent.factor +++ b/extra/mongodb/tuple/persistent/persistent.factor @@ -27,8 +27,7 @@ DEFER: assoc>tuple : make-tuple ( assoc -- tuple ) prepare-assoc>tuple - '[ dup _ at assoc>tuple swap _ set-at ] each - [ mark-persistent ] keep ; inline recursive + '[ dup _ at assoc>tuple swap _ set-at ] each ; inline recursive : at+ ( value key assoc -- value ) 2dup key? @@ -38,9 +37,9 @@ DEFER: assoc>tuple dup tuple? [ assoc? not ] [ drop f ] if ; inline -: add-storable ( assoc ns -- ) - [ H{ } clone ] dip object-map get at+ - [ dup [ MDB_OID_FIELD ] dip at ] dip set-at ; inline +: add-storable ( assoc ns toid -- ) + [ [ H{ } clone ] dip object-map get at+ ] dip + swap set-at ; inline : write-field? ( tuple key value -- ? ) pick mdb-persistent? [ @@ -52,10 +51,10 @@ TUPLE: cond-value value quot ; CONSTRUCTOR: cond-value ( value quot -- cond-value ) ; : write-mdb-persistent ( value quot: ( tuple -- assoc ) -- value' ) - over [ (( tuple -- assoc )) call-effect ] dip - [ tuple-collection name>> ] keep + over [ call( tuple -- assoc ) ] dip + [ [ tuple-collection name>> ] [ >toid ] bi ] keep [ add-storable ] dip - [ tuple-collection name>> ] [ _id>> ] bi ; inline + [ tuple-collection name>> ] [ id>> ] bi ; inline : write-field ( value quot: ( tuple -- assoc ) -- value' ) { @@ -80,8 +79,7 @@ CONSTRUCTOR: cond-value ( value quot -- cond-value ) ; H{ } clone swap [ ] keep pick ; inline : ensure-mdb-info ( tuple -- tuple ) - dup _id>> [ >>_id ] unless - [ mark-persistent ] keep ; inline + dup id>> [ >>id ] unless ; inline : with-object-map ( quot: ( -- ) -- store-assoc ) [ H{ } clone dup object-map ] dip with-variable ; inline @@ -107,9 +105,9 @@ M: tuple tuple>selector ( tuple -- assoc ) prepare-assoc [ tuple>selector ] write-tuple-fields ; : assoc>tuple ( assoc -- tuple ) - dup assoc? - [ [ dup tuple-info? - [ make-tuple ] - [ ] if ] [ drop ] recover - ] [ ] if ; inline recursive + dup assoc? + [ [ dup tuple-info? + [ make-tuple ] + [ ] if ] [ drop ] recover + ] [ ] if ; inline recursive diff --git a/extra/mongodb/tuple/state/state.factor b/extra/mongodb/tuple/state/state.factor index 21923637e5..ec1b8865ab 100644 --- a/extra/mongodb/tuple/state/state.factor +++ b/extra/mongodb/tuple/state/state.factor @@ -6,17 +6,9 @@ IN: mongodb.tuple.state -SYMBOL: mdb-dirty-handling? - -: advised-with? ( name word loc -- ? ) - word-prop key? ; inline - : ( tuple -- tuple-info ) class V{ } clone tuck [ [ name>> ] dip push ] @@ -31,22 +23,3 @@ SYMBOL: mdb-dirty-handling? : tuple-info? ( assoc -- ? ) [ MDB_TUPLE_INFO ] dip key? ; -: tuple-meta ( tuple -- assoc ) - dup _mfd>> [ ] [ H{ } clone [ >>_mfd ] keep ] if* nip ; inline - -: dirty? ( tuple -- ? ) - [ MDB_DIRTY_FLAG ] dip tuple-meta at ; - -: mark-dirty ( tuple -- ) - [ t MDB_DIRTY_FLAG ] dip tuple-meta set-at ; - -: persistent? ( tuple -- ? ) - [ MDB_PERSISTENT_FLAG ] dip tuple-meta at ; - -: mark-persistent ( tuple -- ) - [ t MDB_PERSISTENT_FLAG ] dip tuple-meta [ set-at ] keep - [ f MDB_DIRTY_FLAG ] dip set-at ; - -: needs-store? ( tuple -- ? ) - [ persistent? not ] [ dirty? ] bi or ; - diff --git a/extra/mongodb/tuple/tuple.factor b/extra/mongodb/tuple/tuple.factor index 19281b769a..cbde30ca80 100644 --- a/extra/mongodb/tuple/tuple.factor +++ b/extra/mongodb/tuple/tuple.factor @@ -5,22 +5,24 @@ mongodb.tuple.persistent mongodb.tuple.state strings ; IN: mongodb.tuple +SINGLETONS: +fieldindex+ +compoundindex+ +deepindex+ +unique+ ; + SYNTAX: MDBTUPLE: parse-tuple-definition mdb-check-slots define-tuple-class ; -: define-persistent ( class collection options -- ) - [ [ dupd link-collection ] when* ] dip - [ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] dip - ! [ dup annotate-writers ] dip - set-slot-map ; +: define-persistent ( class collection slot-options index -- ) + [ [ dupd link-collection ] when* ] 2dip + [ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] 2dip + [ drop set-slot-map ] + [ nip set-index-map ] 3bi ; inline : ensure-table ( class -- ) tuple-collection [ create-collection ] - [ [ tuple-index-list ] keep - '[ _ name>> swap [ name>> ] [ spec>> ] bi ensure-index ] each + [ [ mdb-index-map values ] keep + '[ _ name>> >>ns ensure-index ] each ] bi ; : ensure-tables ( classes -- ) @@ -28,7 +30,7 @@ SYNTAX: MDBTUPLE: : drop-table ( class -- ) tuple-collection - [ [ tuple-index-list ] keep + [ [ mdb-index-map values ] keep '[ _ name>> swap name>> drop-index ] each ] [ name>> drop-collection ] bi ; @@ -40,11 +42,11 @@ SYNTAX: MDBTUPLE: GENERIC: id-selector ( object -- selector ) -M: string id-selector ( objid -- selector ) - "_id" H{ } clone [ set-at ] keep ; inline +M: toid id-selector + [ value>> ] [ key>> ] bi H{ } clone [ set-at ] keep ; inline -M: mdb-persistent id-selector ( mdb-persistent -- selector ) - _id>> id-selector ; +M: mdb-persistent id-selector + >toid id-selector ; : (save-tuples) ( collection assoc -- ) swap '[ [ _ ] 2dip @@ -62,9 +64,8 @@ PRIVATE> save-tuple ; : delete-tuple ( tuple -- ) - dup persistent? - [ [ tuple-collection name>> ] keep - id-selector delete ] [ drop ] if ; + [ tuple-collection name>> ] keep + id-selector delete ; : tuple>query ( tuple -- query ) [ tuple-collection name>> ] keep From bd92f6c8ccb04c563b4425a0c62f01199096459d Mon Sep 17 00:00:00 2001 From: Sam Anklesaria Date: Sun, 3 May 2009 11:48:28 -0500 Subject: [PATCH 14/44] separated behaviors and events in frp --- extra/ui/frp/frp.factor | 31 +++++++++++++++++++++---------- 1 file changed, 21 insertions(+), 10 deletions(-) diff --git a/extra/ui/frp/frp.factor b/extra/ui/frp/frp.factor index aa7c44ee03..f972a3f805 100644 --- a/extra/ui/frp/frp.factor +++ b/extra/ui/frp/frp.factor @@ -1,7 +1,7 @@ -USING: accessors arrays colors fonts fry kernel models +USING: accessors arrays colors fonts kernel models models.product monads sequences ui.gadgets ui.gadgets.buttons ui.gadgets.editors ui.gadgets.line-support ui.gadgets.tables -ui.gadgets.tracks ui.render ; +ui.gadgets.tracks ui.render ui.gadgets.scrollers ; QUALIFIED: make IN: ui.frp @@ -27,6 +27,8 @@ M: frp-table row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ; GENERIC: output-model ( gadget -- model ) M: gadget output-model model>> ; M: frp-table output-model selected-value>> ; +M: model-field output-model field-model>> ; +M: scroller output-model children>> first model>> ; GENERIC: , ( uiitem -- ) M: gadget , make:, ; @@ -41,13 +43,16 @@ M: table -> dup , selected-value>> ; [ { } make:make ] dip swap [ f track-add ] each ; inline : ( gadgets type -- track ) [ ] [ [ model>> ] map ] bi >>model ; inline : ( gadgets -- track ) horizontal ; inline +: ( gadgets -- track ) horizontal ; inline : ( gadgets -- track ) vertical ; inline +: ( gadgets -- track ) vertical ; inline -! Model utilities +! !!! Model utilities TUPLE: multi-model < model ; -! M: multi-model model-activated dup model-changed ; : ( models kind -- model ) f swap new-model [ [ add-dependency ] curry each ] keep ; +! Events- discrete model utilities + TUPLE: merge-model < multi-model ; M: merge-model model-changed [ value>> ] dip set-model ; : ( models -- model ) merge-model ; @@ -57,15 +62,21 @@ M: filter-model model-changed [ value>> ] dip [ quot>> call( val -- bool ) ] 2ke [ set-model ] [ 2drop ] if ; : ( model quot -- filter-model ) [ 1array filter-model ] dip >>quot ; +! Behaviors - continuous model utilities + TUPLE: fold-model < multi-model oldval quot ; M: fold-model model-changed [ [ value>> ] [ [ oldval>> ] [ quot>> ] bi ] bi* call( val oldval -- newval ) ] keep set-model ; -: ( oldval quot model -- model' ) 1array fold-model swap >>quot swap >>oldval ; +: ( oldval quot model -- model' ) 1array fold-model swap >>quot + swap [ >>oldval ] [ >>value ] bi ; -TUPLE: switch-model < multi-model switcher on ; -M: switch-model model-changed tuck [ switcher>> = ] 2keep - '[ on>> [ _ value>> _ set-model ] when ] [ t swap (>>on) ] if ; -: switch ( signal1 signal2 -- signal' ) [ 2array switch-model ] keep >>switcher ; +TUPLE: switch-model < multi-model original switcher on ; +M: switch-model model-changed 2dup switcher>> = + [ [ value>> ] [ t >>on ] bi* set-model ] + [ dup on>> [ 2drop ] [ [ value>> ] dip set-model ] if ] if ; +M: switch-model model-activated [ original>> ] keep model-changed ; +: switch ( signal1 signal2 -- signal' ) [ 2array switch-model ] 2keep + [ >>original ] [ >>switcher ] bi* ; TUPLE: mapped < model model quot ; @@ -87,4 +98,4 @@ INSTANCE: gadget-monad monad INSTANCE: gadget monad M: gadget monad-of drop gadget-monad ; M: gadget-monad return drop swap >>model ; -M: gadget >>= model>> '[ _ swap call( x -- y ) ] ; \ No newline at end of file +M: gadget >>= output-model [ swap call( x -- y ) ] curry ; \ No newline at end of file From 6fc5e7a75452a81f0f566929e403c8f9f0113d9b Mon Sep 17 00:00:00 2001 From: Sam Anklesaria Date: Sun, 3 May 2009 12:14:17 -0500 Subject: [PATCH 15/44] frp: switcher ignores f values --- extra/ui/frp/frp-docs.factor | 2 +- extra/ui/frp/frp.factor | 6 ++++-- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/extra/ui/frp/frp-docs.factor b/extra/ui/frp/frp-docs.factor index af44567e46..479a56e513 100644 --- a/extra/ui/frp/frp-docs.factor +++ b/extra/ui/frp/frp-docs.factor @@ -36,7 +36,7 @@ HELP: { $values { "oldval" "starting value" } { "quot" "applied to update and previous values" } { "model" model } { "model'" model } } { $description "Similar to " { $link reduce } " but works on models, applying a quotation to the previous and new values at each update" } ; -HELP: switch +HELP: { $values { "signal1" model } { "signal2" model } { "signal'" model } } { $description "Creates a model that starts with the behavior of model1 and switches to the behavior of model2 on its update" } ; diff --git a/extra/ui/frp/frp.factor b/extra/ui/frp/frp.factor index f972a3f805..6b146c8296 100644 --- a/extra/ui/frp/frp.factor +++ b/extra/ui/frp/frp.factor @@ -20,6 +20,8 @@ M: frp-table row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ; focus-border-color >>focus-border-color transparent >>column-line-color ; : ( model -- table ) [ 1array ] >>quot ; +: ( -- table ) f ; + : ( -- field ) f ; ! Layout utilities @@ -72,10 +74,10 @@ M: fold-model model-changed [ [ value>> ] [ [ oldval>> ] [ quot>> ] bi ] bi* TUPLE: switch-model < multi-model original switcher on ; M: switch-model model-changed 2dup switcher>> = - [ [ value>> ] [ t >>on ] bi* set-model ] + [ over value>> [ [ value>> ] [ t >>on ] bi* set-model ] [ 2drop ] if ] [ dup on>> [ 2drop ] [ [ value>> ] dip set-model ] if ] if ; M: switch-model model-activated [ original>> ] keep model-changed ; -: switch ( signal1 signal2 -- signal' ) [ 2array switch-model ] 2keep +: ( signal1 signal2 -- signal' ) [ 2array switch-model ] 2keep [ >>original ] [ >>switcher ] bi* ; TUPLE: mapped < model model quot ; From 7d020d8f2f8e6a1ad579634d177c4a9f3cfa7f33 Mon Sep 17 00:00:00 2001 From: Sam Anklesaria Date: Sun, 3 May 2009 12:29:12 -0500 Subject: [PATCH 16/44] frp: set default val-quot --- extra/ui/frp/frp.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/ui/frp/frp.factor b/extra/ui/frp/frp.factor index 6b146c8296..699d034c72 100644 --- a/extra/ui/frp/frp.factor +++ b/extra/ui/frp/frp.factor @@ -18,7 +18,8 @@ M: frp-table row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ; frp-table new-line-gadget dup >>renderer [ ] >>quot swap >>model f >>selected-value sans-serif-font >>font focus-border-color >>focus-border-color - transparent >>column-line-color ; + transparent >>column-line-color [ ] >>val-quot ; +: ( -- table ) f ; : ( model -- table ) [ 1array ] >>quot ; : ( -- table ) f ; From 0ca6a6c63f195c7326baac282ebaa12d67abe595 Mon Sep 17 00:00:00 2001 From: Sam Anklesaria Date: Sun, 3 May 2009 12:29:29 -0500 Subject: [PATCH 17/44] added gui for file-trees --- extra/file-trees/file-trees.factor | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/extra/file-trees/file-trees.factor b/extra/file-trees/file-trees.factor index 788291c0a2..eadfccdc4c 100644 --- a/extra/file-trees/file-trees.factor +++ b/extra/file-trees/file-trees.factor @@ -1,10 +1,10 @@ -USING: accessors delegate delegate.protocols io.pathnames -kernel locals namespaces sequences vectors -tools.annotations prettyprint ; +USING: accessors arrays delegate delegate.protocols +io.pathnames kernel locals namespaces prettyprint sequences +ui.frp vectors ; IN: file-trees TUPLE: tree node children ; -CONSULT: sequence-protocol tree children>> [ node>> ] map ; +CONSULT: sequence-protocol tree children>> ; : ( start -- tree ) V{ } clone [ tree boa dup children>> ] [ ".." swap tree boa ] bi swap push ; @@ -20,4 +20,9 @@ DEFER: (tree-insert) path-rest [ path-head tree-insert ] unless-empty ] if* ; : create-tree ( file-list -- tree ) [ path-components ] map - t [ [ tree-insert ] curry each ] keep ; \ No newline at end of file + t [ [ tree-insert ] curry each ] keep ; + +: ( tree-model -- table ) + [ node>> 1array ] >>quot + [ selected-value>> ] + [ swap >>model ] bi ; \ No newline at end of file From 3e640e9cd6b3dfcd3c6171336b63fc1583d0d917 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 3 May 2009 15:30:37 -0500 Subject: [PATCH 18/44] add ${ to literals --- basis/literals/literals-tests.factor | 6 ++++++ basis/literals/literals.factor | 4 +++- 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/basis/literals/literals-tests.factor b/basis/literals/literals-tests.factor index 024c94e4f2..29072f1299 100644 --- a/basis/literals/literals-tests.factor +++ b/basis/literals/literals-tests.factor @@ -19,3 +19,9 @@ IN: literals.tests [ { 0.5 2.0 } ] [ { $[ 1.0 2.0 / ] 2.0 } ] unit-test [ { 1.0 { 0.5 1.5 } 4.0 } ] [ { 1.0 { $[ 1.0 2.0 / ] 1.5 } $[ 2.0 2.0 * ] } ] unit-test + +<< +CONSTANT: constant-a 3 +>> + +[ { 3 10 "ftw" } ] [ ${ constant-a 10 "ftw" } ] unit-test diff --git a/basis/literals/literals.factor b/basis/literals/literals.factor index e55d78ab6e..7c7592dda8 100644 --- a/basis/literals/literals.factor +++ b/basis/literals/literals.factor @@ -1,6 +1,8 @@ ! (c) Joe Groff, see license for details -USING: accessors continuations kernel parser words quotations vectors ; +USING: accessors continuations kernel parser words quotations +combinators.smart vectors sequences ; IN: literals SYNTAX: $ scan-word [ def>> call ] curry with-datastack >vector ; SYNTAX: $[ parse-quotation with-datastack >vector ; +SYNTAX: ${ \ } [ [ ?execute ] { } map-as ] parse-literal ; From 6ccd82fabaac91923981a4b909db9ff428af5fce Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 3 May 2009 15:52:26 -0500 Subject: [PATCH 19/44] world API changes: open-window can take a world-attributes tuple with additional parameters besides title. new begin-world, end-world, and draw-world* generics --- basis/ui/gadgets/worlds/worlds.factor | 63 +++++++++++++++++++-------- basis/ui/ui.factor | 23 ++++++++-- 2 files changed, 64 insertions(+), 22 deletions(-) diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 171272dfc1..68ef6a4b9a 100755 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -4,15 +4,27 @@ USING: accessors arrays assocs continuations kernel math models namespaces opengl opengl.textures sequences io combinators combinators.short-circuit fry math.vectors math.rectangles cache ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks -ui.commands ui.pixel-formats destructors ; +ui.commands ui.pixel-formats destructors literals ; IN: ui.gadgets.worlds +CONSTANT: default-world-pixel-format-attributes + { windowed double-buffered T{ depth-bits { value 16 } } } + TUPLE: world < track -active? focused? -layers -title status status-owner -text-handle handle images -window-loc ; + active? focused? + layers + title status status-owner + text-handle handle images + window-loc + pixel-format-attributes ; + +TUPLE: world-attributes + { world-class initial: world } + title + status + gadgets + { pixel-format-attributes initial: $ default-world-pixel-format-attributes } ; +C: world-attributes : find-world ( gadget -- world/f ) [ world? ] find-parent ; @@ -45,18 +57,23 @@ M: world request-focus-on ( child gadget -- ) 2dup eq? [ 2drop ] [ dup focused?>> (request-focus) ] if ; -: new-world ( gadget title status class -- world ) +: new-world ( class -- world ) vertical swap new-track t >>root? t >>active? - { 0 0 } >>window-loc - swap >>status - swap >>title - swap 1 track-add - dup request-focus ; + { 0 0 } >>window-loc ; -: ( gadget title status -- world ) - world new-world ; +: apply-world-attributes ( world attributes -- world ) + { + [ title>> >>title ] + [ status>> >>status ] + [ pixel-format-attributes>> >>pixel-format-attributes ] + [ gadgets>> [ 1 track-add ] each ] + } cleave ; + +: ( world-attributes -- world ) + [ world-class>> new-world ] keep apply-world-attributes + dup request-focus ; : as-big-as-possible ( world gadget -- ) dup [ { 0 0 } >>loc over dim>> >>dim ] when 2drop ; inline @@ -77,7 +94,17 @@ SYMBOL: flush-layout-cache-hook flush-layout-cache-hook [ [ ] ] initialize -: (draw-world) ( world -- ) +GENERIC: begin-world ( world -- ) +GENERIC: end-world ( world -- ) + +M: world begin-world + drop ; +M: world end-world + drop ; + +GENERIC: draw-world* ( world -- ) + +M: world draw-world* dup handle>> [ check-extensions { @@ -108,7 +135,7 @@ ui-error-hook [ [ rethrow ] ] initialize : draw-world ( world -- ) dup draw-world? [ dup world [ - [ (draw-world) ] [ + [ draw-world* ] [ over ui-error f >>active? drop ] recover @@ -151,8 +178,7 @@ M: world handle-gesture ( gesture gadget -- ? ) [ get-global find-world eq? ] keep '[ f _ set-global ] when ; M: world world-pixel-format-attributes - drop - { windowed double-buffered T{ depth-bits { value 16 } } } ; + pixel-format-attributes>> ; M: world check-world-pixel-format 2drop ; @@ -160,3 +186,4 @@ M: world check-world-pixel-format : with-world-pixel-format ( world quot -- ) [ dup dup world-pixel-format-attributes ] dip [ 2dup check-world-pixel-format ] prepose with-disposal ; inline + diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index 09403cb2d2..0d15d7d57a 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -4,7 +4,8 @@ USING: arrays assocs io kernel math models namespaces make dlists deques sequences threads sequences words continuations init combinators combinators.short-circuit hashtables concurrency.flags sets accessors calendar fry destructors ui.gadgets ui.gadgets.private -ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render ; +ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render +strings ; IN: ui >focused? focus-path f swap focus-gestures ; -M: world graft* +: try-to-open-window ( world -- ) [ (open-window) ] + [ handle>> select-gl-context ] + [ + [ begin-world ] + [ [ handle>> (close-window) ] [ ui-error ] bi* ] + recover + ] tri ; + +M: world graft* + [ try-to-open-window ] [ [ title>> ] keep set-title ] [ request-focus ] tri ; @@ -66,6 +76,7 @@ M: world graft* [ images>> [ dispose ] when* ] [ hand-clicked close-global ] [ hand-gadget close-global ] + [ end-world ] } cleave ; M: world ungraft* @@ -166,13 +177,17 @@ PRIVATE> : restore-windows? ( -- ? ) windows get empty? not ; +: ?attributes ( gadget title/attributes -- attributes ) + dup string? [ world-attributes new swap >>title ] when + swap [ [ [ 1array ] [ f ] if* ] curry unless* ] curry change-gadgets ; + PRIVATE> : open-world-window ( world -- ) dup pref-dim >>dim dup relayout graft ; -: open-window ( gadget title -- ) - f open-world-window ; +: open-window ( gadget title/attributes -- ) + ?attributes open-world-window ; : set-fullscreen? ( ? gadget -- ) find-world set-fullscreen* ; From cd87988ab31563e3a538a319365010b3f02ee0f6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 3 May 2009 15:54:40 -0500 Subject: [PATCH 20/44] use ${ in a couple of places, use output>array --- basis/formatting/formatting.factor | 20 ++++++++++---------- basis/windows/errors/errors.factor | 14 ++++++++------ extra/spheres/spheres.factor | 16 +++++++++------- 3 files changed, 27 insertions(+), 23 deletions(-) diff --git a/basis/formatting/formatting.factor b/basis/formatting/formatting.factor index ac0b0850b4..5a517e4ac4 100644 --- a/basis/formatting/formatting.factor +++ b/basis/formatting/formatting.factor @@ -4,7 +4,7 @@ USING: accessors arrays ascii assocs calendar combinators fry kernel generalizations io io.encodings.ascii io.files io.streams.string macros math math.functions math.parser peg.ebnf quotations -sequences splitting strings unicode.case vectors ; +sequences splitting strings unicode.case vectors combinators.smart ; IN: formatting @@ -113,7 +113,6 @@ MACRO: printf ( format-string -- ) : sprintf ( format-string -- result ) [ printf ] with-string-writer ; inline - string 2 CHAR: 0 pad-head ; inline @@ -129,12 +128,15 @@ MACRO: printf ( format-string -- ) [ pad-00 ] map "/" join ; inline : >datetime ( timestamp -- string ) - { [ day-of-week day-abbreviation3 ] - [ month>> month-abbreviation ] - [ day>> pad-00 ] - [ >time ] - [ year>> number>string ] - } cleave 5 narray " " join ; inline + [ + { + [ day-of-week day-abbreviation3 ] + [ month>> month-abbreviation ] + [ day>> pad-00 ] + [ >time ] + [ year>> number>string ] + } cleave + ] output>array " " join ; inline : (week-of-year) ( timestamp day -- n ) [ dup clone 1 >>month 1 >>day day-of-week dup ] dip > [ 7 swap - ] when @@ -187,5 +189,3 @@ PRIVATE> MACRO: strftime ( format-string -- ) parse-strftime [ length ] keep [ ] join '[ _ @ reverse concat nip ] ; - - diff --git a/basis/windows/errors/errors.factor b/basis/windows/errors/errors.factor index e08704d469..d180cb20e7 100644 --- a/basis/windows/errors/errors.factor +++ b/basis/windows/errors/errors.factor @@ -1,7 +1,7 @@ USING: alien.c-types kernel locals math math.bitwise windows.kernel32 sequences byte-arrays unicode.categories io.encodings.string io.encodings.utf16n alien.strings -arrays ; +arrays literals ; IN: windows.errors CONSTANT: ERROR_SUCCESS 0 @@ -732,11 +732,13 @@ ERROR: error-message-failed id ; win32-error-string throw ] when ; -: expected-io-errors ( -- seq ) - ERROR_SUCCESS - ERROR_IO_INCOMPLETE - ERROR_IO_PENDING - WAIT_TIMEOUT 4array ; foldable +CONSTANT: expected-io-errors + ${ + ERROR_SUCCESS + ERROR_IO_INCOMPLETE + ERROR_IO_PENDING + WAIT_TIMEOUT + } : expected-io-error? ( error-code -- ? ) expected-io-errors member? ; diff --git a/extra/spheres/spheres.factor b/extra/spheres/spheres.factor index fa666dd776..18e326f1b7 100755 --- a/extra/spheres/spheres.factor +++ b/extra/spheres/spheres.factor @@ -1,7 +1,7 @@ USING: kernel opengl opengl.demo-support opengl.gl opengl.textures opengl.shaders opengl.framebuffers opengl.capabilities multiline ui.gadgets accessors sequences ui.render ui math locals arrays -generalizations combinators ui.gadgets.worlds ; +generalizations combinators ui.gadgets.worlds literals ; IN: spheres STRING: plane-vertex-shader @@ -136,12 +136,14 @@ M: spheres-gadget distance-step ( gadget -- dz ) GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_S GL_CLAMP glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_T GL_CLAMP glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_R GL_CLAMP glTexParameteri - GL_TEXTURE_CUBE_MAP_POSITIVE_X - GL_TEXTURE_CUBE_MAP_POSITIVE_Y - GL_TEXTURE_CUBE_MAP_POSITIVE_Z - GL_TEXTURE_CUBE_MAP_NEGATIVE_X - GL_TEXTURE_CUBE_MAP_NEGATIVE_Y - GL_TEXTURE_CUBE_MAP_NEGATIVE_Z 6 narray + ${ + GL_TEXTURE_CUBE_MAP_POSITIVE_X + GL_TEXTURE_CUBE_MAP_POSITIVE_Y + GL_TEXTURE_CUBE_MAP_POSITIVE_Z + GL_TEXTURE_CUBE_MAP_NEGATIVE_X + GL_TEXTURE_CUBE_MAP_NEGATIVE_Y + GL_TEXTURE_CUBE_MAP_NEGATIVE_Z + } [ 0 GL_RGBA8 (reflection-dim) 0 GL_RGBA GL_UNSIGNED_BYTE f glTexImage2D ] each ] keep ; From 474735a60c349afea2cce0671162e143e2fe5538 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 3 May 2009 17:11:01 -0500 Subject: [PATCH 21/44] update status-bar for api changes. set the gl-context outside of draw-world* generic --- basis/ui/gadgets/status-bar/status-bar.factor | 8 +++---- basis/ui/gadgets/worlds/worlds.factor | 22 +++++++++---------- 2 files changed, 15 insertions(+), 15 deletions(-) diff --git a/basis/ui/gadgets/status-bar/status-bar.factor b/basis/ui/gadgets/status-bar/status-bar.factor index a1c2dca23d..0d3015508e 100644 --- a/basis/ui/gadgets/status-bar/status-bar.factor +++ b/basis/ui/gadgets/status-bar/status-bar.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors models models.delay models.arrow sequences ui.gadgets.labels ui.gadgets.tracks -ui.gadgets.worlds ui.gadgets ui kernel calendar summary ; +ui.gadgets.worlds ui.gadgets ui ui.private kernel calendar summary ; IN: ui.gadgets.status-bar : ( model -- gadget ) @@ -10,9 +10,9 @@ IN: ui.gadgets.status-bar reverse-video-theme t >>root? ; -: open-status-window ( gadget title -- ) - f [ ] keep - f track-add +: open-status-window ( gadget title/attributes -- ) + ?attributes f >>status + dup status>> f track-add open-world-window ; : show-summary ( object gadget -- ) diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 68ef6a4b9a..837cf822dc 100755 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -105,16 +105,13 @@ M: world end-world GENERIC: draw-world* ( world -- ) M: world draw-world* - dup handle>> [ - check-extensions - { - [ init-gl ] - [ draw-gadget ] - [ text-handle>> [ purge-cache ] when* ] - [ images>> [ purge-cache ] when* ] - } cleave - ] with-gl-context - flush-layout-cache-hook get call( -- ) ; + check-extensions + { + [ init-gl ] + [ draw-gadget ] + [ text-handle>> [ purge-cache ] when* ] + [ images>> [ purge-cache ] when* ] + } cleave ; : draw-world? ( world -- ? ) #! We don't draw deactivated worlds, or those with 0 size. @@ -135,7 +132,10 @@ ui-error-hook [ [ rethrow ] ] initialize : draw-world ( world -- ) dup draw-world? [ dup world [ - [ draw-world* ] [ + [ + dup handle>> [ draw-world* ] with-gl-context + flush-layout-cache-hook get call( -- ) + ] [ over ui-error f >>active? drop ] recover From 4e8df4a190729dc5125fa86893c82ca417352134 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 3 May 2009 17:14:49 -0500 Subject: [PATCH 22/44] change spheres to use new world api --- extra/opengl/demo-support/demo-support.factor | 73 +++++++++---------- extra/spheres/spheres.factor | 60 ++++++++------- 2 files changed, 68 insertions(+), 65 deletions(-) diff --git a/extra/opengl/demo-support/demo-support.factor b/extra/opengl/demo-support/demo-support.factor index 5973766c8e..4d5f5ee4b7 100755 --- a/extra/opengl/demo-support/demo-support.factor +++ b/extra/opengl/demo-support/demo-support.factor @@ -1,6 +1,6 @@ USING: arrays kernel math math.functions math.order math.vectors namespaces opengl opengl.gl sequences ui ui.gadgets ui.gestures -ui.render accessors combinators ; +ui.gadgets.worlds ui.render accessors combinators ; IN: opengl.demo-support : FOV ( -- x ) 2.0 sqrt 1+ ; inline @@ -9,62 +9,61 @@ CONSTANT: KEY-ROTATE-STEP 10.0 SYMBOL: last-drag-loc -TUPLE: demo-gadget < gadget yaw pitch distance ; +TUPLE: demo-world < world yaw pitch distance ; -: new-demo-gadget ( yaw pitch distance class -- gadget ) - new - swap >>distance - swap >>pitch - swap >>yaw ; inline +: set-demo-orientation ( world yaw pitch distance -- world ) + [ >>yaw ] [ >>pitch ] [ >>distance ] tri* ; GENERIC: far-plane ( gadget -- z ) GENERIC: near-plane ( gadget -- z ) GENERIC: distance-step ( gadget -- dz ) -M: demo-gadget far-plane ( gadget -- z ) +M: demo-world far-plane ( gadget -- z ) drop 4.0 ; -M: demo-gadget near-plane ( gadget -- z ) +M: demo-world near-plane ( gadget -- z ) drop 1.0 64.0 / ; -M: demo-gadget distance-step ( gadget -- dz ) +M: demo-world distance-step ( gadget -- dz ) drop 1.0 64.0 / ; : fov-ratio ( gadget -- fov ) dim>> dup first2 min v/n ; -: yaw-demo-gadget ( yaw gadget -- ) +: yaw-demo-world ( yaw gadget -- ) [ + ] with change-yaw relayout-1 ; -: pitch-demo-gadget ( pitch gadget -- ) +: pitch-demo-world ( pitch gadget -- ) [ + ] with change-pitch relayout-1 ; -: zoom-demo-gadget ( distance gadget -- ) +: zoom-demo-world ( distance gadget -- ) [ + ] with change-distance relayout-1 ; -M: demo-gadget pref-dim* ( gadget -- dim ) +M: demo-world focusable-child* ( world -- gadget ) + drop t ; + +M: demo-world pref-dim* ( gadget -- dim ) drop { 640 480 } ; : -+ ( x -- -x x ) [ neg ] keep ; -: demo-gadget-frustum ( gadget -- -x x -y y near far ) +: demo-world-frustum ( gadget -- -x x -y y near far ) [ near-plane ] [ far-plane ] [ fov-ratio ] tri [ nip swap FOV / v*n first2 [ -+ ] bi@ ] 3keep drop ; -: demo-gadget-set-matrices ( gadget -- ) +M: demo-world begin-world + GL_PROJECTION glMatrixMode + glLoadIdentity + demo-world-frustum glFrustum ; + +: demo-world-set-matrix ( gadget -- ) GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear - [ - GL_PROJECTION glMatrixMode - glLoadIdentity - demo-gadget-frustum glFrustum - ] [ - GL_MODELVIEW glMatrixMode - glLoadIdentity - [ [ 0.0 0.0 ] dip distance>> neg glTranslatef ] - [ pitch>> 1.0 0.0 0.0 glRotatef ] - [ yaw>> 0.0 1.0 0.0 glRotatef ] - tri - ] bi ; + GL_MODELVIEW glMatrixMode + glLoadIdentity + [ [ 0.0 0.0 ] dip distance>> neg glTranslatef ] + [ pitch>> 1.0 0.0 0.0 glRotatef ] + [ yaw>> 0.0 1.0 0.0 glRotatef ] + tri ; : reset-last-drag-rel ( -- ) { 0 0 } last-drag-loc set-global ; @@ -94,16 +93,16 @@ M: demo-gadget pref-dim* ( gadget -- dim ) swap first swap second glVertex2d ] do-state ; -demo-gadget H{ - { T{ key-down f f "LEFT" } [ KEY-ROTATE-STEP neg swap yaw-demo-gadget ] } - { T{ key-down f f "RIGHT" } [ KEY-ROTATE-STEP swap yaw-demo-gadget ] } - { T{ key-down f f "DOWN" } [ KEY-ROTATE-STEP neg swap pitch-demo-gadget ] } - { T{ key-down f f "UP" } [ KEY-ROTATE-STEP swap pitch-demo-gadget ] } - { T{ key-down f f "=" } [ dup distance-step neg swap zoom-demo-gadget ] } - { T{ key-down f f "-" } [ dup distance-step swap zoom-demo-gadget ] } +demo-world H{ + { T{ key-down f f "LEFT" } [ KEY-ROTATE-STEP neg swap yaw-demo-world ] } + { T{ key-down f f "RIGHT" } [ KEY-ROTATE-STEP swap yaw-demo-world ] } + { T{ key-down f f "DOWN" } [ KEY-ROTATE-STEP neg swap pitch-demo-world ] } + { T{ key-down f f "UP" } [ KEY-ROTATE-STEP swap pitch-demo-world ] } + { T{ key-down f f "=" } [ dup distance-step neg swap zoom-demo-world ] } + { T{ key-down f f "-" } [ dup distance-step swap zoom-demo-world ] } { T{ button-down f f 1 } [ drop reset-last-drag-rel ] } - { T{ drag f 1 } [ drag-yaw-pitch rot [ pitch-demo-gadget ] keep yaw-demo-gadget ] } - { mouse-scroll [ scroll-direction get second over distance-step * swap zoom-demo-gadget ] } + { T{ drag f 1 } [ drag-yaw-pitch rot [ pitch-demo-world ] keep yaw-demo-world ] } + { mouse-scroll [ scroll-direction get second over distance-step * swap zoom-demo-world ] } } set-gestures diff --git a/extra/spheres/spheres.factor b/extra/spheres/spheres.factor index fa666dd776..708d6c68dd 100755 --- a/extra/spheres/spheres.factor +++ b/extra/spheres/spheres.factor @@ -1,7 +1,8 @@ USING: kernel opengl opengl.demo-support opengl.gl opengl.textures opengl.shaders opengl.framebuffers opengl.capabilities multiline ui.gadgets accessors sequences ui.render ui math locals arrays -generalizations combinators ui.gadgets.worlds ; +generalizations combinators ui.gadgets.worlds method-chains +literals ui.pixel-formats ; IN: spheres STRING: plane-vertex-shader @@ -110,19 +111,16 @@ main() } ; -TUPLE: spheres-gadget < demo-gadget +TUPLE: spheres-world < demo-world plane-program solid-sphere-program texture-sphere-program reflection-framebuffer reflection-depthbuffer - reflection-texture initialized? ; + reflection-texture ; -: ( -- gadget ) - 20.0 10.0 20.0 spheres-gadget new-demo-gadget ; - -M: spheres-gadget near-plane ( gadget -- z ) +M: spheres-world near-plane ( gadget -- z ) drop 1.0 ; -M: spheres-gadget far-plane ( gadget -- z ) +M: spheres-world far-plane ( gadget -- z ) drop 512.0 ; -M: spheres-gadget distance-step ( gadget -- dz ) +M: spheres-world distance-step ( gadget -- dz ) drop 0.5 ; : (reflection-dim) ( -- w h ) @@ -136,12 +134,14 @@ M: spheres-gadget distance-step ( gadget -- dz ) GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_S GL_CLAMP glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_T GL_CLAMP glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_R GL_CLAMP glTexParameteri - GL_TEXTURE_CUBE_MAP_POSITIVE_X - GL_TEXTURE_CUBE_MAP_POSITIVE_Y - GL_TEXTURE_CUBE_MAP_POSITIVE_Z - GL_TEXTURE_CUBE_MAP_NEGATIVE_X - GL_TEXTURE_CUBE_MAP_NEGATIVE_Y - GL_TEXTURE_CUBE_MAP_NEGATIVE_Z 6 narray + { + $ GL_TEXTURE_CUBE_MAP_POSITIVE_X + $ GL_TEXTURE_CUBE_MAP_POSITIVE_Y + $ GL_TEXTURE_CUBE_MAP_POSITIVE_Z + $ GL_TEXTURE_CUBE_MAP_NEGATIVE_X + $ GL_TEXTURE_CUBE_MAP_NEGATIVE_Y + $ GL_TEXTURE_CUBE_MAP_NEGATIVE_Z + } [ 0 GL_RGBA8 (reflection-dim) 0 GL_RGBA GL_UNSIGNED_BYTE f glTexImage2D ] each ] keep ; @@ -171,22 +171,19 @@ M: spheres-gadget distance-step ( gadget -- dz ) sphere-main-fragment-shader check-gl-shader 3array check-gl-program ; -M: spheres-gadget graft* ( gadget -- ) - dup find-gl-context +AFTER: spheres-world begin-world "2.0" { "GL_ARB_shader_objects" } require-gl-version-or-extensions { "GL_EXT_framebuffer_object" } require-gl-extensions + 20.0 10.0 20.0 set-demo-orientation (plane-program) >>plane-program (solid-sphere-program) >>solid-sphere-program (texture-sphere-program) >>texture-sphere-program (make-reflection-texture) >>reflection-texture (make-reflection-depthbuffer) [ >>reflection-depthbuffer ] keep (make-reflection-framebuffer) >>reflection-framebuffer - t >>initialized? drop ; -M: spheres-gadget ungraft* ( gadget -- ) - f >>initialized? - dup find-gl-context +M: spheres-world end-world { [ reflection-framebuffer>> [ delete-framebuffer ] when* ] [ reflection-depthbuffer>> [ delete-renderbuffer ] when* ] @@ -196,7 +193,7 @@ M: spheres-gadget ungraft* ( gadget -- ) [ plane-program>> [ delete-gl-program ] when* ] } cleave ; -M: spheres-gadget pref-dim* ( gadget -- dim ) +M: spheres-world pref-dim* ( gadget -- dim ) drop { 640 480 } ; :: (draw-sphere) ( program center radius -- ) @@ -280,12 +277,12 @@ M: spheres-gadget pref-dim* ( gadget -- dim ) [ dim>> 0 0 rot first2 glViewport ] } cleave ] with-framebuffer ; -: (draw-gadget) ( gadget -- ) +M: spheres-world draw-world* GL_DEPTH_TEST glEnable GL_SCISSOR_TEST glDisable 0.15 0.15 1.0 1.0 glClearColor { [ (draw-reflection-texture) ] - [ demo-gadget-set-matrices ] + [ demo-world-set-matrix ] [ sphere-scene ] [ reflection-texture>> GL_TEXTURE_CUBE_MAP GL_TEXTURE0 bind-texture-unit ] [ @@ -297,10 +294,17 @@ M: spheres-gadget pref-dim* ( gadget -- dim ) ] } cleave ; -M: spheres-gadget draw-gadget* ( gadget -- ) - dup initialized?>> [ (draw-gadget) ] [ drop ] if ; - : spheres-window ( -- ) - [ "Spheres" open-window ] with-ui ; + [ + f T{ world-attributes + { world-class spheres-world } + { title "Spheres" } + { pixel-format-attributes { + windowed + double-buffered + T{ depth-bits { value 16 } } + } } + } open-window + ] with-ui ; MAIN: spheres-window From bc07c075e72bddfcf69cec4739ec54537c6408be Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 3 May 2009 17:23:14 -0500 Subject: [PATCH 23/44] Merge branch 'master' of git://factorcode.org/git/factor Conflicts: extra/spheres/spheres.factor --- basis/formatting/formatting.factor | 20 ++++++++-------- basis/literals/literals-tests.factor | 6 +++++ basis/literals/literals.factor | 4 +++- basis/windows/errors/errors.factor | 14 ++++++----- extra/file-trees/file-trees.factor | 15 ++++++++---- extra/spheres/spheres.factor | 14 +++++------ extra/str-fry/str-fry.factor | 7 ++++-- extra/ui/frp/frp-docs.factor | 2 +- extra/ui/frp/frp.factor | 36 +++++++++++++++++++--------- 9 files changed, 75 insertions(+), 43 deletions(-) diff --git a/basis/formatting/formatting.factor b/basis/formatting/formatting.factor index ac0b0850b4..5a517e4ac4 100644 --- a/basis/formatting/formatting.factor +++ b/basis/formatting/formatting.factor @@ -4,7 +4,7 @@ USING: accessors arrays ascii assocs calendar combinators fry kernel generalizations io io.encodings.ascii io.files io.streams.string macros math math.functions math.parser peg.ebnf quotations -sequences splitting strings unicode.case vectors ; +sequences splitting strings unicode.case vectors combinators.smart ; IN: formatting @@ -113,7 +113,6 @@ MACRO: printf ( format-string -- ) : sprintf ( format-string -- result ) [ printf ] with-string-writer ; inline - string 2 CHAR: 0 pad-head ; inline @@ -129,12 +128,15 @@ MACRO: printf ( format-string -- ) [ pad-00 ] map "/" join ; inline : >datetime ( timestamp -- string ) - { [ day-of-week day-abbreviation3 ] - [ month>> month-abbreviation ] - [ day>> pad-00 ] - [ >time ] - [ year>> number>string ] - } cleave 5 narray " " join ; inline + [ + { + [ day-of-week day-abbreviation3 ] + [ month>> month-abbreviation ] + [ day>> pad-00 ] + [ >time ] + [ year>> number>string ] + } cleave + ] output>array " " join ; inline : (week-of-year) ( timestamp day -- n ) [ dup clone 1 >>month 1 >>day day-of-week dup ] dip > [ 7 swap - ] when @@ -187,5 +189,3 @@ PRIVATE> MACRO: strftime ( format-string -- ) parse-strftime [ length ] keep [ ] join '[ _ @ reverse concat nip ] ; - - diff --git a/basis/literals/literals-tests.factor b/basis/literals/literals-tests.factor index 024c94e4f2..29072f1299 100644 --- a/basis/literals/literals-tests.factor +++ b/basis/literals/literals-tests.factor @@ -19,3 +19,9 @@ IN: literals.tests [ { 0.5 2.0 } ] [ { $[ 1.0 2.0 / ] 2.0 } ] unit-test [ { 1.0 { 0.5 1.5 } 4.0 } ] [ { 1.0 { $[ 1.0 2.0 / ] 1.5 } $[ 2.0 2.0 * ] } ] unit-test + +<< +CONSTANT: constant-a 3 +>> + +[ { 3 10 "ftw" } ] [ ${ constant-a 10 "ftw" } ] unit-test diff --git a/basis/literals/literals.factor b/basis/literals/literals.factor index e55d78ab6e..7c7592dda8 100644 --- a/basis/literals/literals.factor +++ b/basis/literals/literals.factor @@ -1,6 +1,8 @@ ! (c) Joe Groff, see license for details -USING: accessors continuations kernel parser words quotations vectors ; +USING: accessors continuations kernel parser words quotations +combinators.smart vectors sequences ; IN: literals SYNTAX: $ scan-word [ def>> call ] curry with-datastack >vector ; SYNTAX: $[ parse-quotation with-datastack >vector ; +SYNTAX: ${ \ } [ [ ?execute ] { } map-as ] parse-literal ; diff --git a/basis/windows/errors/errors.factor b/basis/windows/errors/errors.factor index e08704d469..d180cb20e7 100644 --- a/basis/windows/errors/errors.factor +++ b/basis/windows/errors/errors.factor @@ -1,7 +1,7 @@ USING: alien.c-types kernel locals math math.bitwise windows.kernel32 sequences byte-arrays unicode.categories io.encodings.string io.encodings.utf16n alien.strings -arrays ; +arrays literals ; IN: windows.errors CONSTANT: ERROR_SUCCESS 0 @@ -732,11 +732,13 @@ ERROR: error-message-failed id ; win32-error-string throw ] when ; -: expected-io-errors ( -- seq ) - ERROR_SUCCESS - ERROR_IO_INCOMPLETE - ERROR_IO_PENDING - WAIT_TIMEOUT 4array ; foldable +CONSTANT: expected-io-errors + ${ + ERROR_SUCCESS + ERROR_IO_INCOMPLETE + ERROR_IO_PENDING + WAIT_TIMEOUT + } : expected-io-error? ( error-code -- ? ) expected-io-errors member? ; diff --git a/extra/file-trees/file-trees.factor b/extra/file-trees/file-trees.factor index 788291c0a2..eadfccdc4c 100644 --- a/extra/file-trees/file-trees.factor +++ b/extra/file-trees/file-trees.factor @@ -1,10 +1,10 @@ -USING: accessors delegate delegate.protocols io.pathnames -kernel locals namespaces sequences vectors -tools.annotations prettyprint ; +USING: accessors arrays delegate delegate.protocols +io.pathnames kernel locals namespaces prettyprint sequences +ui.frp vectors ; IN: file-trees TUPLE: tree node children ; -CONSULT: sequence-protocol tree children>> [ node>> ] map ; +CONSULT: sequence-protocol tree children>> ; : ( start -- tree ) V{ } clone [ tree boa dup children>> ] [ ".." swap tree boa ] bi swap push ; @@ -20,4 +20,9 @@ DEFER: (tree-insert) path-rest [ path-head tree-insert ] unless-empty ] if* ; : create-tree ( file-list -- tree ) [ path-components ] map - t [ [ tree-insert ] curry each ] keep ; \ No newline at end of file + t [ [ tree-insert ] curry each ] keep ; + +: ( tree-model -- table ) + [ node>> 1array ] >>quot + [ selected-value>> ] + [ swap >>model ] bi ; \ No newline at end of file diff --git a/extra/spheres/spheres.factor b/extra/spheres/spheres.factor index 708d6c68dd..671edf38ce 100755 --- a/extra/spheres/spheres.factor +++ b/extra/spheres/spheres.factor @@ -134,13 +134,13 @@ M: spheres-world distance-step ( gadget -- dz ) GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_S GL_CLAMP glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_T GL_CLAMP glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_R GL_CLAMP glTexParameteri - { - $ GL_TEXTURE_CUBE_MAP_POSITIVE_X - $ GL_TEXTURE_CUBE_MAP_POSITIVE_Y - $ GL_TEXTURE_CUBE_MAP_POSITIVE_Z - $ GL_TEXTURE_CUBE_MAP_NEGATIVE_X - $ GL_TEXTURE_CUBE_MAP_NEGATIVE_Y - $ GL_TEXTURE_CUBE_MAP_NEGATIVE_Z + ${ + GL_TEXTURE_CUBE_MAP_POSITIVE_X + GL_TEXTURE_CUBE_MAP_POSITIVE_Y + GL_TEXTURE_CUBE_MAP_POSITIVE_Z + GL_TEXTURE_CUBE_MAP_NEGATIVE_X + GL_TEXTURE_CUBE_MAP_NEGATIVE_Y + GL_TEXTURE_CUBE_MAP_NEGATIVE_Z } [ 0 GL_RGBA8 (reflection-dim) 0 GL_RGBA GL_UNSIGNED_BYTE f glTexImage2D ] each diff --git a/extra/str-fry/str-fry.factor b/extra/str-fry/str-fry.factor index aafdaa95d9..bfe74f37eb 100644 --- a/extra/str-fry/str-fry.factor +++ b/extra/str-fry/str-fry.factor @@ -1,4 +1,7 @@ -USING: kernel sequences splitting strings.parser ; +USING: combinators effects kernel math sequences splitting +strings.parser ; IN: str-fry -: str-fry ( str -- quot ) "_" split unclip [ [ rot glue ] reduce ] 2curry ; +: str-fry ( str -- quot ) "_" split + [ unclip [ [ rot glue ] reduce ] 2curry ] + [ length 1 - 1 [ call-effect ] 2curry ] bi ; SYNTAX: I" parse-string rest str-fry over push-all ; \ No newline at end of file diff --git a/extra/ui/frp/frp-docs.factor b/extra/ui/frp/frp-docs.factor index af44567e46..479a56e513 100644 --- a/extra/ui/frp/frp-docs.factor +++ b/extra/ui/frp/frp-docs.factor @@ -36,7 +36,7 @@ HELP: { $values { "oldval" "starting value" } { "quot" "applied to update and previous values" } { "model" model } { "model'" model } } { $description "Similar to " { $link reduce } " but works on models, applying a quotation to the previous and new values at each update" } ; -HELP: switch +HELP: { $values { "signal1" model } { "signal2" model } { "signal'" model } } { $description "Creates a model that starts with the behavior of model1 and switches to the behavior of model2 on its update" } ; diff --git a/extra/ui/frp/frp.factor b/extra/ui/frp/frp.factor index aa7c44ee03..699d034c72 100644 --- a/extra/ui/frp/frp.factor +++ b/extra/ui/frp/frp.factor @@ -1,7 +1,7 @@ -USING: accessors arrays colors fonts fry kernel models +USING: accessors arrays colors fonts kernel models models.product monads sequences ui.gadgets ui.gadgets.buttons ui.gadgets.editors ui.gadgets.line-support ui.gadgets.tables -ui.gadgets.tracks ui.render ; +ui.gadgets.tracks ui.render ui.gadgets.scrollers ; QUALIFIED: make IN: ui.frp @@ -18,8 +18,11 @@ M: frp-table row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ; frp-table new-line-gadget dup >>renderer [ ] >>quot swap >>model f >>selected-value sans-serif-font >>font focus-border-color >>focus-border-color - transparent >>column-line-color ; + transparent >>column-line-color [ ] >>val-quot ; +: ( -- table ) f ; : ( model -- table ) [ 1array ] >>quot ; +: ( -- table ) f ; + : ( -- field ) f ; ! Layout utilities @@ -27,6 +30,8 @@ M: frp-table row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ; GENERIC: output-model ( gadget -- model ) M: gadget output-model model>> ; M: frp-table output-model selected-value>> ; +M: model-field output-model field-model>> ; +M: scroller output-model children>> first model>> ; GENERIC: , ( uiitem -- ) M: gadget , make:, ; @@ -41,13 +46,16 @@ M: table -> dup , selected-value>> ; [ { } make:make ] dip swap [ f track-add ] each ; inline : ( gadgets type -- track ) [ ] [ [ model>> ] map ] bi >>model ; inline : ( gadgets -- track ) horizontal ; inline +: ( gadgets -- track ) horizontal ; inline : ( gadgets -- track ) vertical ; inline +: ( gadgets -- track ) vertical ; inline -! Model utilities +! !!! Model utilities TUPLE: multi-model < model ; -! M: multi-model model-activated dup model-changed ; : ( models kind -- model ) f swap new-model [ [ add-dependency ] curry each ] keep ; +! Events- discrete model utilities + TUPLE: merge-model < multi-model ; M: merge-model model-changed [ value>> ] dip set-model ; : ( models -- model ) merge-model ; @@ -57,15 +65,21 @@ M: filter-model model-changed [ value>> ] dip [ quot>> call( val -- bool ) ] 2ke [ set-model ] [ 2drop ] if ; : ( model quot -- filter-model ) [ 1array filter-model ] dip >>quot ; +! Behaviors - continuous model utilities + TUPLE: fold-model < multi-model oldval quot ; M: fold-model model-changed [ [ value>> ] [ [ oldval>> ] [ quot>> ] bi ] bi* call( val oldval -- newval ) ] keep set-model ; -: ( oldval quot model -- model' ) 1array fold-model swap >>quot swap >>oldval ; +: ( oldval quot model -- model' ) 1array fold-model swap >>quot + swap [ >>oldval ] [ >>value ] bi ; -TUPLE: switch-model < multi-model switcher on ; -M: switch-model model-changed tuck [ switcher>> = ] 2keep - '[ on>> [ _ value>> _ set-model ] when ] [ t swap (>>on) ] if ; -: switch ( signal1 signal2 -- signal' ) [ 2array switch-model ] keep >>switcher ; +TUPLE: switch-model < multi-model original switcher on ; +M: switch-model model-changed 2dup switcher>> = + [ over value>> [ [ value>> ] [ t >>on ] bi* set-model ] [ 2drop ] if ] + [ dup on>> [ 2drop ] [ [ value>> ] dip set-model ] if ] if ; +M: switch-model model-activated [ original>> ] keep model-changed ; +: ( signal1 signal2 -- signal' ) [ 2array switch-model ] 2keep + [ >>original ] [ >>switcher ] bi* ; TUPLE: mapped < model model quot ; @@ -87,4 +101,4 @@ INSTANCE: gadget-monad monad INSTANCE: gadget monad M: gadget monad-of drop gadget-monad ; M: gadget-monad return drop swap >>model ; -M: gadget >>= model>> '[ _ swap call( x -- y ) ] ; \ No newline at end of file +M: gadget >>= output-model [ swap call( x -- y ) ] curry ; \ No newline at end of file From 585ea8da544bba0da0161ebd4ff0382d5ed4b0c9 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 3 May 2009 18:32:35 -0500 Subject: [PATCH 24/44] don't pprint gadgets with RECT: syntax --- basis/prettyprint/backend/backend.factor | 7 +++++-- basis/ui/gadgets/gadgets.factor | 6 +++++- 2 files changed, 10 insertions(+), 3 deletions(-) diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index 1976c84fd1..22dec9d2fc 100644 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -135,8 +135,8 @@ M: pathname pprint* [ text ] [ f ] bi* \ } pprint-word block> ; -M: tuple pprint* - boa-tuples? get [ call-next-method ] [ +: pprint-tuple ( tuple -- ) + boa-tuples? get [ pprint-object ] [ [ > ; From 045635cdf26c620903e481bf84c24d1702f6510b Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 3 May 2009 20:33:03 -0500 Subject: [PATCH 25/44] yield during mouse-moved events in cocoa so gadgets have a chance to redraw --- basis/ui/backend/cocoa/views/views.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/backend/cocoa/views/views.factor b/basis/ui/backend/cocoa/views/views.factor index 4a16e3bd37..aab851c783 100644 --- a/basis/ui/backend/cocoa/views/views.factor +++ b/basis/ui/backend/cocoa/views/views.factor @@ -9,7 +9,7 @@ threads combinators math.rectangles ; IN: ui.backend.cocoa.views : send-mouse-moved ( view event -- ) - [ mouse-location ] [ drop window ] 2bi move-hand fire-motion ; + [ mouse-location ] [ drop window ] 2bi move-hand fire-motion yield ; : button ( event -- n ) #! Cocoa -> Factor UI button mapping From 45049077360d81c4d707c8f5d281f465dd18748a Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 3 May 2009 22:01:35 -0500 Subject: [PATCH 26/44] add a resize-world generic to handle window resizes --- basis/ui/gadgets/worlds/worlds.factor | 13 +++++++++++++ basis/ui/ui.factor | 17 ++++++++++------- 2 files changed, 23 insertions(+), 7 deletions(-) diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 837cf822dc..31b5a137a3 100755 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -24,6 +24,7 @@ TUPLE: world-attributes status gadgets { pixel-format-attributes initial: $ default-world-pixel-format-attributes } ; + C: world-attributes : find-world ( gadget -- world/f ) [ world? ] find-parent ; @@ -97,10 +98,22 @@ flush-layout-cache-hook [ [ ] ] initialize GENERIC: begin-world ( world -- ) GENERIC: end-world ( world -- ) +GENERIC: resize-world ( world -- ) + M: world begin-world drop ; M: world end-world drop ; +M: world resize-world + drop ; + +M: world (>>dim) + [ call-next-method ] + [ + dup handle>> + [ select-gl-context resize-world ] + [ drop ] if* + ] bi ; GENERIC: draw-world* ( world -- ) diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index 0d15d7d57a..d07403836a 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -51,13 +51,16 @@ SYMBOL: windows focus-path f swap focus-gestures ; : try-to-open-window ( world -- ) - [ (open-window) ] - [ handle>> select-gl-context ] - [ - [ begin-world ] - [ [ handle>> (close-window) ] [ ui-error ] bi* ] - recover - ] tri ; + { + [ (open-window) ] + [ handle>> select-gl-context ] + [ + [ begin-world ] + [ [ handle>> (close-window) ] [ ui-error ] bi* ] + recover + ] + [ resize-world ] + } cleave ; M: world graft* [ try-to-open-window ] From 8925773558007aee490170d73eb15ec746e76c7d Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 3 May 2009 22:02:50 -0500 Subject: [PATCH 27/44] update bunny to use world api; clean up projection matrix and viewport discipline in demos --- extra/bunny/bunny.factor | 53 +++++++++++-------- extra/bunny/outlined/outlined.factor | 10 +++- extra/opengl/demo-support/demo-support.factor | 7 +-- extra/spheres/spheres.factor | 10 ++-- 4 files changed, 50 insertions(+), 30 deletions(-) diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor index d0625e464f..620f737fe3 100755 --- a/extra/bunny/bunny.factor +++ b/extra/bunny/bunny.factor @@ -1,58 +1,67 @@ USING: accessors arrays bunny.cel-shaded bunny.fixed-pipeline bunny.model bunny.outlined destructors kernel math opengl.demo-support opengl.gl sequences ui ui.gadgets ui.gadgets.worlds ui.gestures -ui.render words ; +ui.render words ui.pixel-formats ; IN: bunny -TUPLE: bunny-gadget < demo-gadget model-triangles geom draw-seq draw-n ; +TUPLE: bunny-world < demo-world model-triangles geom draw-seq draw-n ; -: ( -- bunny-gadget ) - 0.0 0.0 0.375 bunny-gadget new-demo-gadget - maybe-download read-model >>model-triangles ; - -: bunny-gadget-draw ( gadget -- draw ) +: get-draw ( gadget -- draw ) [ draw-n>> ] [ draw-seq>> ] bi nth ; -: bunny-gadget-next-draw ( gadget -- ) +: next-draw ( gadget -- ) dup [ draw-seq>> ] [ draw-n>> ] bi 1+ swap length mod >>draw-n relayout-1 ; -M: bunny-gadget graft* ( gadget -- ) - dup find-gl-context - GL_DEPTH_TEST glEnable - dup model-triangles>> >>geom - dup +: make-draws ( gadget -- draw-seq ) [ ] [ ] [ ] tri 3array - sift >>draw-seq + sift ; + +M: bunny-world begin-world + GL_DEPTH_TEST glEnable + 0.0 0.0 0.375 set-demo-orientation + maybe-download read-model + [ >>model-triangles ] [ >>geom ] bi + dup make-draws >>draw-seq 0 >>draw-n drop ; -M: bunny-gadget ungraft* ( gadget -- ) +M: bunny-world end-world dup find-gl-context [ geom>> [ dispose ] when* ] [ draw-seq>> [ [ dispose ] when* ] each ] bi ; -M: bunny-gadget draw-gadget* ( gadget -- ) +M: bunny-world draw-world* dup draw-seq>> empty? [ drop ] [ 0.15 0.15 0.15 1.0 glClearColor GL_DEPTH_BUFFER_BIT GL_COLOR_BUFFER_BIT bitor glClear - dup demo-gadget-set-matrices + dup demo-world-set-matrix GL_MODELVIEW glMatrixMode 0.02 -0.105 0.0 glTranslatef - [ geom>> ] [ bunny-gadget-draw ] bi draw-bunny + [ geom>> ] [ get-draw ] bi draw-bunny ] if ; -M: bunny-gadget pref-dim* ( gadget -- dim ) +M: bunny-world pref-dim* ( gadget -- dim ) drop { 640 480 } ; -bunny-gadget H{ - { T{ key-down f f "TAB" } [ bunny-gadget-next-draw ] } +bunny-world H{ + { T{ key-down f f "TAB" } [ next-draw ] } } set-gestures : bunny-window ( -- ) - [ "Bunny" open-window ] with-ui ; + [ + f T{ world-attributes + { world-class bunny-world } + { title "Bunny" } + { pixel-format-attributes { + windowed + double-buffered + T{ depth-bits { value 16 } } + } } + } open-window + ] with-ui ; MAIN: bunny-window diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor index 7491ed8bcb..0ad2a72100 100755 --- a/extra/bunny/outlined/outlined.factor +++ b/extra/bunny/outlined/outlined.factor @@ -216,7 +216,11 @@ MACRO: (framebuffer-texture>>draw) ( iformat xformat setter -- ) ] with-framebuffer ; : (pass2) ( draw -- ) - init-matrices { + GL_PROJECTION glMatrixMode + glPushMatrix glLoadIdentity + GL_MODELVIEW glMatrixMode + glLoadIdentity + { [ color-texture>> GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit ] [ normal-texture>> GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit ] [ depth-texture>> GL_TEXTURE_2D GL_TEXTURE2 bind-texture-unit ] @@ -230,7 +234,9 @@ MACRO: (framebuffer-texture>>draw) ( iformat xformat setter -- ) } cleave { -1.0 -1.0 } { 1.0 1.0 } rect-vertices ] with-gl-program ] - } cleave ; + } cleave + GL_PROJECTION glMatrixMode + glPopMatrix ; M: bunny-outlined draw-bunny [ remake-framebuffer-if-needed ] diff --git a/extra/opengl/demo-support/demo-support.factor b/extra/opengl/demo-support/demo-support.factor index 4d5f5ee4b7..35c64d4ad1 100755 --- a/extra/opengl/demo-support/demo-support.factor +++ b/extra/opengl/demo-support/demo-support.factor @@ -45,16 +45,17 @@ M: demo-world pref-dim* ( gadget -- dim ) : -+ ( x -- -x x ) [ neg ] keep ; -: demo-world-frustum ( gadget -- -x x -y y near far ) +: demo-world-frustum ( world -- -x x -y y near far ) [ near-plane ] [ far-plane ] [ fov-ratio ] tri [ nip swap FOV / v*n first2 [ -+ ] bi@ ] 3keep drop ; -M: demo-world begin-world +M: demo-world resize-world GL_PROJECTION glMatrixMode glLoadIdentity - demo-world-frustum glFrustum ; + [ [ 0 0 ] dip dim>> first2 glViewport ] + [ demo-world-frustum glFrustum ] bi ; : demo-world-set-matrix ( gadget -- ) GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear diff --git a/extra/spheres/spheres.factor b/extra/spheres/spheres.factor index 671edf38ce..d763e476be 100755 --- a/extra/spheres/spheres.factor +++ b/extra/spheres/spheres.factor @@ -171,7 +171,7 @@ M: spheres-world distance-step ( gadget -- dz ) sphere-main-fragment-shader check-gl-shader 3array check-gl-program ; -AFTER: spheres-world begin-world +M: spheres-world begin-world "2.0" { "GL_ARB_shader_objects" } require-gl-version-or-extensions { "GL_EXT_framebuffer_object" } require-gl-extensions 20.0 10.0 20.0 set-demo-orientation @@ -251,7 +251,7 @@ M: spheres-world pref-dim* ( gadget -- dim ) [ drop 0 0 (reflection-dim) glViewport ] [ GL_PROJECTION glMatrixMode - glLoadIdentity + glPushMatrix glLoadIdentity reflection-frustum glFrustum GL_MODELVIEW glMatrixMode glLoadIdentity @@ -274,7 +274,11 @@ M: spheres-world pref-dim* ( gadget -- dim ) [ GL_TEXTURE_CUBE_MAP_POSITIVE_Y (reflection-face) glPopMatrix 90.0 1.0 0.0 0.0 glRotatef ] [ sphere-scene ] - [ dim>> 0 0 rot first2 glViewport ] + [ + [ 0 0 ] dip dim>> first2 glViewport + GL_PROJECTION glMatrixMode + glPopMatrix + ] } cleave ] with-framebuffer ; M: spheres-world draw-world* From fa8c47d310fc6ae0ea4e684f43b1f001c1901d69 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 3 May 2009 22:04:25 -0500 Subject: [PATCH 28/44] move ui.offscreen to unmaintained for now --- {extra => unmaintained}/ui/offscreen/authors.txt | 0 {extra => unmaintained}/ui/offscreen/offscreen-docs.factor | 0 {extra => unmaintained}/ui/offscreen/offscreen.factor | 0 {extra => unmaintained}/ui/offscreen/summary.txt | 0 {extra => unmaintained}/ui/offscreen/tags.txt | 0 5 files changed, 0 insertions(+), 0 deletions(-) rename {extra => unmaintained}/ui/offscreen/authors.txt (100%) rename {extra => unmaintained}/ui/offscreen/offscreen-docs.factor (100%) rename {extra => unmaintained}/ui/offscreen/offscreen.factor (100%) rename {extra => unmaintained}/ui/offscreen/summary.txt (100%) rename {extra => unmaintained}/ui/offscreen/tags.txt (100%) diff --git a/extra/ui/offscreen/authors.txt b/unmaintained/ui/offscreen/authors.txt similarity index 100% rename from extra/ui/offscreen/authors.txt rename to unmaintained/ui/offscreen/authors.txt diff --git a/extra/ui/offscreen/offscreen-docs.factor b/unmaintained/ui/offscreen/offscreen-docs.factor similarity index 100% rename from extra/ui/offscreen/offscreen-docs.factor rename to unmaintained/ui/offscreen/offscreen-docs.factor diff --git a/extra/ui/offscreen/offscreen.factor b/unmaintained/ui/offscreen/offscreen.factor similarity index 100% rename from extra/ui/offscreen/offscreen.factor rename to unmaintained/ui/offscreen/offscreen.factor diff --git a/extra/ui/offscreen/summary.txt b/unmaintained/ui/offscreen/summary.txt similarity index 100% rename from extra/ui/offscreen/summary.txt rename to unmaintained/ui/offscreen/summary.txt diff --git a/extra/ui/offscreen/tags.txt b/unmaintained/ui/offscreen/tags.txt similarity index 100% rename from extra/ui/offscreen/tags.txt rename to unmaintained/ui/offscreen/tags.txt From d546e8c89aed1ad2762bc225f958c2a77e12b338 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 3 May 2009 22:21:36 -0500 Subject: [PATCH 29/44] nitpick ui.pixel-formats docs --- basis/ui/pixel-formats/pixel-formats-docs.factor | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/basis/ui/pixel-formats/pixel-formats-docs.factor b/basis/ui/pixel-formats/pixel-formats-docs.factor index 207b757908..003b205c3d 100644 --- a/basis/ui/pixel-formats/pixel-formats-docs.factor +++ b/basis/ui/pixel-formats/pixel-formats-docs.factor @@ -91,29 +91,29 @@ HELP: backing-store { double-buffered backing-store } related-words HELP: multisampled -{ $class-description "Requests a pixel format with multisampled antialiasing enabled. The " { $link sample-buffers } " and " { $link samples } " attributes must also be specified to specify the level of multisampling." } +{ $class-description "Requests a pixel format with multisampled antialiasing enabled. The " { $link sample-buffers } " and " { $link samples } " attributes must also be provided to specify the level of multisampling." } { $notes "On some window systems this is not distinct from " { $link supersampled } "." } ; HELP: supersampled -{ $class-description "Requests a pixel format with supersampled antialiasing enabled. The " { $link sample-buffers } " and " { $link samples } " attributes must also be specified to specify the level of supersampling." } +{ $class-description "Requests a pixel format with supersampled antialiasing enabled. The " { $link sample-buffers } " and " { $link samples } " attributes must also be provided to specify the level of supersampling." } { $notes "On some window systems this is not distinct from " { $link multisampled } "." } ; HELP: sample-alpha { $class-description "Used with " { $link multisampled } " or " { $link supersampled } " to request more accurate multisampling of alpha values." } ; HELP: color-float -{ $class-description "Requests a pixel format where the pixels are stored in floating-point format." } ; +{ $class-description "Requests a pixel format where the color buffer is stored in floating-point format." } ; HELP: color-bits -{ $class-description "Requests a pixel format of at least " { $snippet "value" } " bits per pixel." } ; +{ $class-description "Requests a pixel format with a color buffer of at least " { $snippet "value" } " bits per pixel." } ; HELP: red-bits -{ $class-description "Requests a pixel format with at least " { $snippet "value" } " red bits per pixel." } ; +{ $class-description "Requests a pixel format with a color buffer with at least " { $snippet "value" } " red bits per pixel." } ; HELP: green-bits -{ $class-description "Requests a pixel format with at least " { $snippet "value" } " green bits per pixel." } ; +{ $class-description "Requests a pixel format with a color buffer with at least " { $snippet "value" } " green bits per pixel." } ; HELP: blue-bits -{ $class-description "Requests a pixel format with at least " { $snippet "value" } " blue bits per pixel." } ; +{ $class-description "Requests a pixel format with a color buffer with at least " { $snippet "value" } " blue bits per pixel." } ; HELP: alpha-bits -{ $class-description "Requests a pixel format with at least " { $snippet "value" } " alpha bits per pixel." } ; +{ $class-description "Requests a pixel format with a color buffer with at least " { $snippet "value" } " alpha bits per pixel." } ; { color-float color-bits red-bits green-bits blue-bits alpha-bits } related-words From 8beea2ab0ca19a3b7b3467a820c0d78f5a34c48e Mon Sep 17 00:00:00 2001 From: Nicholas Seckar Date: Sun, 3 May 2009 21:00:29 -0700 Subject: [PATCH 30/44] Don't treat . directories as vocab dirs. Rename subdirs to (less general) vocab-subdirs. Add all-vocabs-under and load-all-under. --- basis/tools/vocabs/vocabs-tests.factor | 5 ++++- basis/tools/vocabs/vocabs.factor | 20 +++++++++++++++++--- 2 files changed, 21 insertions(+), 4 deletions(-) diff --git a/basis/tools/vocabs/vocabs-tests.factor b/basis/tools/vocabs/vocabs-tests.factor index 04e628d080..a4430c07bc 100644 --- a/basis/tools/vocabs/vocabs-tests.factor +++ b/basis/tools/vocabs/vocabs-tests.factor @@ -1,5 +1,5 @@ IN: tools.vocabs.tests -USING: tools.test tools.vocabs namespaces continuations ; +USING: continuations namespaces tools.test tools.vocabs tools.vocabs.private ; [ ] [ changed-vocabs get-global @@ -7,3 +7,6 @@ USING: tools.test tools.vocabs namespaces continuations ; [ t ] [ "kernel" changed-vocab? ] unit-test [ "kernel" changed-vocab ] [ changed-vocabs set-global ] [ ] cleanup ] unit-test + +[ t ] [ "some-vocab" valid-vocab-dirname ] unit-test +[ f ] [ ".git" valid-vocab-dirname ] unit-test diff --git a/basis/tools/vocabs/vocabs.factor b/basis/tools/vocabs/vocabs.factor index 4b9a72a443..7cd94827db 100644 --- a/basis/tools/vocabs/vocabs.factor +++ b/basis/tools/vocabs/vocabs.factor @@ -205,15 +205,21 @@ M: vocab-link summary vocab-summary ; : set-vocab-authors ( authors vocab -- ) dup vocab-authors-path set-vocab-file-contents ; -: subdirs ( dir -- dirs ) + + + +: vocab-subdirs ( dir -- dirs ) [ - [ link-info directory? ] filter + [ [ link-info directory? ] [ valid-vocab-dirname ] bi and ] filter ] with-directory-files natural-sort ; : (all-child-vocabs) ( root name -- vocabs ) [ vocab-dir append-path dup exists? - [ subdirs ] [ drop { } ] if + [ vocab-subdirs ] [ drop { } ] if ] keep [ swap [ "." glue ] with map ] unless-empty ; @@ -235,6 +241,11 @@ M: vocab-link summary vocab-summary ; dup [ "" vocabs-in-dir ] { } make ] { } map>assoc ; +: all-vocabs-under ( prefix -- vocabs ) + [ + vocab-roots get [ over vocabs-in-dir ] each drop + ] { } make ; + MEMO: all-vocabs-seq ( -- seq ) all-vocabs values concat ; @@ -252,6 +263,9 @@ MEMO: all-vocabs-seq ( -- seq ) : load-everything ( -- ) try-everything load-failures. ; +: load-all-under ( prefix -- ) + all-vocabs-under filter-unportable require-all load-failures. ; + : unrooted-child-vocabs ( prefix -- seq ) dup empty? [ CHAR: . suffix ] unless vocabs From 804d4aae81204a08671e7eb20e567f18559c045a Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 3 May 2009 23:01:26 -0500 Subject: [PATCH 31/44] docs for new world words --- .../gadgets/status-bar/status-bar-docs.factor | 4 +-- basis/ui/gadgets/worlds/worlds-docs.factor | 31 +++++++++++++++++-- basis/ui/ui-docs.factor | 19 +++++++++--- 3 files changed, 45 insertions(+), 9 deletions(-) diff --git a/basis/ui/gadgets/status-bar/status-bar-docs.factor b/basis/ui/gadgets/status-bar/status-bar-docs.factor index 57c69c2a66..7a68310e36 100644 --- a/basis/ui/gadgets/status-bar/status-bar-docs.factor +++ b/basis/ui/gadgets/status-bar/status-bar-docs.factor @@ -18,7 +18,7 @@ HELP: { $notes "If the " { $snippet "model" } " is " { $snippet "status" } ", this gadget will display mouse over help for " { $link "ui.gadgets.presentations" } "." } ; HELP: open-status-window -{ $values { "gadget" gadget } { "title" string } } +{ $values { "gadget" gadget } { "title/attributes" { "a " { $link string } " or a " { $link world-attributes } " tuple" } } } { $description "Like " { $link open-window } ", with the additional feature that the new window iwll have a status bar displaying the value stored in the world's " { $slot "status" } " slot." } { $see-also show-status hide-status } ; @@ -30,4 +30,4 @@ ARTICLE: "ui.gadgets.status-bar" "Status bars and mouse-over help" { $subsection hide-status } { $link "ui.gadgets.presentations" } " use the status bar to display object summary." ; -ABOUT: "ui.gadgets.status-bar" \ No newline at end of file +ABOUT: "ui.gadgets.status-bar" diff --git a/basis/ui/gadgets/worlds/worlds-docs.factor b/basis/ui/gadgets/worlds/worlds-docs.factor index 9d4df189f2..d4e9790d89 100755 --- a/basis/ui/gadgets/worlds/worlds-docs.factor +++ b/basis/ui/gadgets/worlds/worlds-docs.factor @@ -48,8 +48,8 @@ HELP: world } ; HELP: -{ $values { "gadget" gadget } { "title" string } { "status" model } { "world" "a new " { $link world } } } -{ $description "Creates a new " { $link world } " delegating to the given gadget." } ; +{ $values { "world-attributes" world-attributes } { "world" "a new " { $link world } } } +{ $description "Creates a new " { $link world } " or world subclass with the given attributes." } ; HELP: find-world { $values { "gadget" gadget } { "world/f" { $maybe world } } } @@ -65,6 +65,30 @@ HELP: find-gl-context { $description "Makes the OpenGL context of the gadget's containing native window the current OpenGL context." } { $notes "This word should be called from " { $link graft* } " and " { $link ungraft* } " methods which need to allocate and deallocate OpenGL resources, such as textures, display lists, and so on." } ; +HELP: begin-world +{ $values { "world" world } } +{ $description "Called immediately after " { $snippet "world" } "'s OpenGL context has been created. The world's OpenGL context is current when this method is called." } ; + +HELP: end-world +{ $values { "world" world } } +{ $description "Called immediately before " { $snippet "world" } "'s OpenGL context is destroyed. The world's OpenGL context is current when this method is called." } ; + +HELP: resize-world +{ $values { "world" world } } +{ $description "Called when the window containing " { $snippet "world" } " is resized. The " { $snippet "loc" } " and " { $snippet "dim" } " slots of " { $snippet "world" } " will be updated with the world's new position and size. The world's OpenGL context is current when this method is called." } ; + +HELP: draw-world* +{ $values { "world" world } } +{ $description "Called when " { $snippet "world" } " needs to be redrawn. The world's OpenGL context is current when this method is called." } ; + +ARTICLE: "ui.gadgets.worlds-subclassing" "Subclassing worlds" +"The " { $link world } " gadget can be subclassed, giving Factor code full control of the window's OpenGL context. The following generic words can be overridden to replace standard UI behavior:" +{ $subsection begin-world } +{ $subsection end-world } +{ $subsection resize-world } +{ $subsection draw-world* } +"See the " { $vocab-link "spheres" } " and " { $vocab-link "bunny" } " demos for examples." ; + ARTICLE: "ui-paint-custom" "Implementing custom drawing logic" "The UI uses OpenGL to render gadgets. Custom rendering logic can be plugged in with the " { $link "ui-pen-protocol" } ", or by implementing a generic word:" { $subsection draw-gadget* } @@ -72,7 +96,8 @@ ARTICLE: "ui-paint-custom" "Implementing custom drawing logic" $nl "Gadgets which need to allocate and deallocate OpenGL resources such as textures, display lists, and so on, should perform the allocation in the " { $link graft* } " method, and the deallocation in the " { $link ungraft* } " method. Since those words are not necessarily called with the gadget's OpenGL context active, a utility word can be used to find and make the correct OpenGL context current:" { $subsection find-gl-context } -"OpenGL state must not be altered as a result of drawing a gadget, so any flags which were enabled should be disabled, and vice versa." +"OpenGL state must not be altered as a result of drawing a gadget, so any flags which were enabled should be disabled, and vice versa. To take full control of the OpenGL context, see " { $link "ui.gadgets.worlds-subclassing" } "." { $subsection "ui-paint-coord" } +{ $subsection "ui.gadgets.worlds-subclassing" } { $subsection "gl-utilities" } { $subsection "text-rendering" } ; diff --git a/basis/ui/ui-docs.factor b/basis/ui/ui-docs.factor index f2b6154745..397fc419fa 100644 --- a/basis/ui/ui-docs.factor +++ b/basis/ui/ui-docs.factor @@ -2,17 +2,28 @@ USING: help.markup help.syntax strings quotations debugger namespaces ui.backend ui.gadgets ui.gadgets.worlds ui.gadgets.tracks ui.gadgets.packs ui.gadgets.grids ui.gadgets.private math.rectangles colors ui.text fonts -kernel ui.private ; +kernel ui.private classes sequences ; IN: ui HELP: windows { $var-description "Global variable holding an association list mapping native window handles to " { $link world } " instances." } ; -{ windows open-window find-window } related-words +{ windows open-window find-window world-attributes } related-words HELP: open-window -{ $values { "gadget" gadget } { "title" string } } -{ $description "Opens a native window with the specified title." } ; +{ $values { "gadget" gadget } { "title/attributes" { "a " { $link string } " or a " { $link world-attributes } " tuple" } } } +{ $description "Opens a native window containing " { $snippet "gadget" } " with the specified attributes. If a string is provided, it is used as the window title; otherwise, the window attributes are specified in a " { $link world-attributes } " tuple." } ; + +HELP: world-attributes +{ $values { "world-class" class } { "title" string } { "status" gadget } { "gadgets" sequence } { "pixel-format-attributes" sequence } } +{ $class-description "Tuples of this class can be passed to " { $link open-window } " to control attributes of the window opened. The following attributes can be set:" } +{ $list + { { $snippet "world-class" } " specifies the class of world to construct. " { $link world } " is the default." } + { { $snippet "title" } " is the window title." } + { { $snippet "status" } ", if specified, is a gadget that will be used as the window's status bar." } + { { $snippet "gadgets" } " is a sequence of gadgets that will be placed inside the window." } + { { $snippet "pixel-format-attributes" } " is a sequence of " { $link "ui.pixel-formats-attributes" } " that the window will request for its OpenGL pixel format." } +} ; HELP: set-fullscreen? { $values { "?" "a boolean" } { "gadget" gadget } } From 94e64b6e9c82ee44d5e14c84954f6004b64774df Mon Sep 17 00:00:00 2001 From: Nicholas Seckar Date: Sun, 3 May 2009 21:14:44 -0700 Subject: [PATCH 32/44] Add docs for load-all-under and all-vocabs-under --- basis/tools/vocabs/vocabs-docs.factor | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/basis/tools/vocabs/vocabs-docs.factor b/basis/tools/vocabs/vocabs-docs.factor index 33f197d0ea..98902f8fe6 100644 --- a/basis/tools/vocabs/vocabs-docs.factor +++ b/basis/tools/vocabs/vocabs-docs.factor @@ -73,3 +73,11 @@ HELP: set-vocab-tags HELP: all-vocabs { $values { "assoc" "an association list mapping vocabulary roots to sequences of vocabulary specifiers" } } { $description "Outputs an association list of all vocabularies which have been loaded or are available for loading." } ; + +HELP: load-all-under +{ $values { "prefix" string } } +{ $description "Load all vocabularies that match the provided prefix." } ; + +HELP: all-vocabs-under +{ $values { "prefix" string } } +{ $description "Return a sequence of vocab or vocab-links for each vocab matching the provided prefix. Unlike " { $link all-child-vocabs } " this word will return both loaded and unloaded vocabularies." } ; From 8e17e0a01e14b2c25d64da5c014a84f9f1cd1a9a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 May 2009 01:00:30 -0500 Subject: [PATCH 33/44] VM: use better abstractions for tagged pointers, eliminate get()/set() stuff, clean up array, string, and byte-array element access --- Makefile | 6 +- vm/alien.cpp | 171 +++++++++--------- vm/alien.hpp | 80 +++++---- vm/arrays.cpp | 8 +- vm/arrays.hpp | 24 ++- vm/bignum.cpp | 1 - vm/bignum.hpp | 2 +- vm/bignumint.hpp | 4 +- vm/booleans.cpp | 6 +- vm/booleans.hpp | 8 +- vm/byte_arrays.cpp | 10 +- vm/byte_arrays.hpp | 6 +- vm/callstack.cpp | 52 +++--- vm/callstack.hpp | 16 +- vm/code_block.cpp | 61 +++---- vm/code_block.hpp | 10 +- vm/code_gc.hpp | 6 +- vm/code_heap.cpp | 18 +- vm/code_heap.hpp | 6 +- vm/contexts.cpp | 186 ++++++++++++++++++++ vm/contexts.hpp | 61 +++++++ vm/cpu-ppc.hpp | 2 +- vm/cpu-x86.32.hpp | 2 +- vm/cpu-x86.64.hpp | 2 +- vm/cpu-x86.hpp | 22 +-- vm/data_gc.cpp | 124 ++++++------- vm/data_gc.hpp | 55 +++--- vm/data_heap.cpp | 41 ++--- vm/data_heap.hpp | 32 ++-- vm/debug.cpp | 62 ++----- vm/debug.hpp | 2 +- vm/dispatch.cpp | 36 ++-- vm/dispatch.hpp | 8 +- vm/errors.cpp | 4 +- vm/errors.hpp | 13 +- vm/factor.cpp | 29 +-- vm/factor.hpp | 20 +-- vm/float_bits.hpp | 8 +- vm/generic_arrays.hpp | 27 +-- vm/image.cpp | 83 ++++----- vm/image.hpp | 6 +- vm/inline_cache.cpp | 11 +- vm/inline_cache.hpp | 5 +- vm/io.cpp | 20 +-- vm/io.hpp | 27 +-- vm/layouts.hpp | 85 +++++++-- vm/local_roots.hpp | 7 +- vm/master.hpp | 3 + vm/math.cpp | 369 +++++++++++++++++++-------------------- vm/math.hpp | 171 +++++++++--------- vm/os-freebsd-x86.32.hpp | 2 +- vm/os-freebsd-x86.64.hpp | 2 +- vm/os-genunix.hpp | 2 +- vm/os-linux-arm.hpp | 2 +- vm/os-linux-ppc.hpp | 2 +- vm/os-linux-x86.32.hpp | 2 +- vm/os-linux-x86.64.hpp | 2 +- vm/os-macosx-ppc.hpp | 2 +- vm/os-macosx-x86.32.hpp | 2 +- vm/os-macosx-x86.64.hpp | 2 +- vm/os-macosx.hpp | 8 +- vm/os-macosx.mm | 2 +- vm/os-openbsd-x86.32.hpp | 2 +- vm/os-openbsd-x86.64.hpp | 2 +- vm/os-solaris-x86.32.hpp | 2 +- vm/os-solaris-x86.64.hpp | 2 +- vm/os-unix.cpp | 6 +- vm/os-windows-ce.cpp | 2 +- vm/os-windows.cpp | 4 +- vm/os-windows.hpp | 6 +- vm/primitives.cpp | 302 ++++++++++++++++---------------- vm/primitives.hpp | 6 +- vm/profiler.cpp | 2 +- vm/profiler.hpp | 2 +- vm/quotations.cpp | 51 +++--- vm/quotations.hpp | 9 +- vm/run.cpp | 216 ++--------------------- vm/run.hpp | 175 +------------------ vm/segments.hpp | 5 + vm/stacks.hpp | 14 ++ vm/strings.cpp | 46 +++-- vm/strings.hpp | 17 +- vm/tagged.hpp | 38 ++-- vm/tuples.cpp | 8 +- vm/tuples.hpp | 18 +- vm/words.cpp | 8 +- vm/words.hpp | 10 +- vm/write_barrier.hpp | 14 +- 88 files changed, 1479 insertions(+), 1536 deletions(-) create mode 100644 vm/contexts.cpp create mode 100644 vm/contexts.hpp create mode 100644 vm/segments.hpp create mode 100644 vm/stacks.hpp diff --git a/Makefile b/Makefile index 8c07a656b8..18cb7d15c7 100755 --- a/Makefile +++ b/Makefile @@ -36,6 +36,7 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \ vm/code_block.o \ vm/code_gc.o \ vm/code_heap.o \ + vm/contexts.o \ vm/data_gc.o \ vm/data_heap.o \ vm/debug.o \ @@ -177,7 +178,10 @@ $(TEST_LIBRARY): vm/ffi_test.o clean: rm -f vm/*.o - rm -f factor*.dll libfactor.{a,so,dylib} libfactor-ffi-test.{a,so,dylib} Factor.app/Contents/Frameworks/libfactor.dylib + rm -f factor.dll + rm -f libfactor.* + rm -f libfactor-ffi-test.* + rm -f Factor.app/Contents/Frameworks/libfactor.dylib tags: etags vm/*.{cpp,hpp,mm,S,c} diff --git a/vm/alien.cpp b/vm/alien.cpp index f3613d518b..fdfa887a8f 100755 --- a/vm/alien.cpp +++ b/vm/alien.cpp @@ -1,39 +1,13 @@ #include "master.hpp" -/* gets the address of an object representing a C pointer */ -char *alien_offset(CELL object) -{ - F_ALIEN *alien; - F_BYTE_ARRAY *byte_array; - - switch(type_of(object)) - { - case BYTE_ARRAY_TYPE: - byte_array = untag(object); - return (char *)(byte_array + 1); - case ALIEN_TYPE: - alien = untag(object); - if(alien->expired != F) - general_error(ERROR_EXPIRED,object,F,NULL); - return alien_offset(alien->alien) + alien->displacement; - case F_TYPE: - return NULL; - default: - type_error(ALIEN_TYPE,object); - return NULL; /* can't happen */ - } -} - /* gets the address of an object representing a C pointer, with the intention of storing the pointer across code which may potentially GC. */ char *pinned_alien_offset(CELL object) { - F_ALIEN *alien; - - switch(type_of(object)) + switch(tagged(object).type()) { case ALIEN_TYPE: - alien = untag(object); + F_ALIEN *alien = untag(object); if(alien->expired != F) general_error(ERROR_EXPIRED,object,F,NULL); return pinned_alien_offset(alien->alien) + alien->displacement; @@ -45,19 +19,13 @@ char *pinned_alien_offset(CELL object) } } -/* pop an object representing a C pointer */ -char *unbox_alien(void) -{ - return alien_offset(dpop()); -} - /* make an alien */ CELL allot_alien(CELL delegate_, CELL displacement) { gc_root delegate(delegate_); gc_root alien(allot(sizeof(F_ALIEN))); - if(delegate.isa(ALIEN_TYPE)) + if(delegate.type_p(ALIEN_TYPE)) { tagged delegate_alien = delegate.as(); displacement += delegate_alien->displacement; @@ -72,17 +40,8 @@ CELL allot_alien(CELL delegate_, CELL displacement) return alien.value(); } -/* make an alien and push */ -void box_alien(void *ptr) -{ - if(ptr == NULL) - dpush(F); - else - dpush(allot_alien(F,(CELL)ptr)); -} - /* make an alien pointing at an offset of another alien */ -void primitive_displaced_alien(void) +PRIMITIVE(displaced_alien) { CELL alien = dpop(); CELL displacement = to_cell(dpop()); @@ -91,7 +50,7 @@ void primitive_displaced_alien(void) dpush(F); else { - switch(type_of(alien)) + switch(tagged(alien).type()) { case BYTE_ARRAY_TYPE: case ALIEN_TYPE: @@ -107,13 +66,13 @@ void primitive_displaced_alien(void) /* address of an object representing a C pointer. Explicitly throw an error if the object is a byte array, as a sanity check. */ -void primitive_alien_address(void) +PRIMITIVE(alien_address) { box_unsigned_cell((CELL)pinned_alien_offset(dpop())); } /* pop ( alien n ) from datastack, return alien's address plus n */ -INLINE void *alien_pointer(void) +static void *alien_pointer(void) { F_FIXNUM offset = to_fixnum(dpop()); return unbox_alien() + offset; @@ -121,11 +80,11 @@ INLINE void *alien_pointer(void) /* define words to read/write values at an alien address */ #define DEFINE_ALIEN_ACCESSOR(name,type,boxer,to) \ - void primitive_alien_##name(void) \ + PRIMITIVE(alien_##name) \ { \ boxer(*(type*)alien_pointer()); \ } \ - void primitive_set_alien_##name(void) \ + PRIMITIVE(set_alien_##name) \ { \ type *ptr = (type *)alien_pointer(); \ type value = to(dpop()); \ @@ -146,42 +105,8 @@ DEFINE_ALIEN_ACCESSOR(float,float,box_float,to_float) DEFINE_ALIEN_ACCESSOR(double,double,box_double,to_double) DEFINE_ALIEN_ACCESSOR(cell,void *,box_alien,pinned_alien_offset) -/* for FFI calls passing structs by value */ -void to_value_struct(CELL src, void *dest, CELL size) -{ - memcpy(dest,alien_offset(src),size); -} - -/* for FFI callbacks receiving structs by value */ -void box_value_struct(void *src, CELL size) -{ - F_BYTE_ARRAY *array = allot_byte_array(size); - memcpy(array + 1,src,size); - dpush(tag(array)); -} - -/* On some x86 OSes, structs <= 8 bytes are returned in registers. */ -void box_small_struct(CELL x, CELL y, CELL size) -{ - CELL data[2]; - data[0] = x; - data[1] = y; - box_value_struct(data,size); -} - -/* On OS X/PPC, complex numbers are returned in registers. */ -void box_medium_struct(CELL x1, CELL x2, CELL x3, CELL x4, CELL size) -{ - CELL data[4]; - data[0] = x1; - data[1] = x2; - data[2] = x3; - data[3] = x4; - box_value_struct(data,size); -} - /* open a native library and push a handle */ -void primitive_dlopen(void) +PRIMITIVE(dlopen) { gc_root path(dpop()); path.untag_check(); @@ -192,7 +117,7 @@ void primitive_dlopen(void) } /* look up a symbol in a native library */ -void primitive_dlsym(void) +PRIMITIVE(dlsym) { gc_root dll(dpop()); gc_root name(dpop()); @@ -214,12 +139,12 @@ void primitive_dlsym(void) } /* close a native library handle */ -void primitive_dlclose(void) +PRIMITIVE(dlclose) { ffi_dlclose(untag_check(dpop())); } -void primitive_dll_validp(void) +PRIMITIVE(dll_validp) { CELL dll = dpop(); if(dll == F) @@ -227,3 +152,73 @@ void primitive_dll_validp(void) else dpush(tagged(dll)->dll == NULL ? F : T); } + +/* gets the address of an object representing a C pointer */ +VM_C_API char *alien_offset(CELL object) +{ + switch(tagged(object).type()) + { + case BYTE_ARRAY_TYPE: + F_BYTE_ARRAY *byte_array = untag(object); + return (char *)(byte_array + 1); + case ALIEN_TYPE: + F_ALIEN *alien = untag(object); + if(alien->expired != F) + general_error(ERROR_EXPIRED,object,F,NULL); + return alien_offset(alien->alien) + alien->displacement; + case F_TYPE: + return NULL; + default: + type_error(ALIEN_TYPE,object); + return NULL; /* can't happen */ + } +} + +/* pop an object representing a C pointer */ +VM_C_API char *unbox_alien(void) +{ + return alien_offset(dpop()); +} + +/* make an alien and push */ +VM_C_API void box_alien(void *ptr) +{ + if(ptr == NULL) + dpush(F); + else + dpush(allot_alien(F,(CELL)ptr)); +} + +/* for FFI calls passing structs by value */ +VM_C_API void to_value_struct(CELL src, void *dest, CELL size) +{ + memcpy(dest,alien_offset(src),size); +} + +/* for FFI callbacks receiving structs by value */ +VM_C_API void box_value_struct(void *src, CELL size) +{ + F_BYTE_ARRAY *array = allot_byte_array(size); + memcpy(array + 1,src,size); + dpush(tag(array)); +} + +/* On some x86 OSes, structs <= 8 bytes are returned in registers. */ +VM_C_API void box_small_struct(CELL x, CELL y, CELL size) +{ + CELL data[2]; + data[0] = x; + data[1] = y; + box_value_struct(data,size); +} + +/* On OS X/PPC, complex numbers are returned in registers. */ +VM_C_API void box_medium_struct(CELL x1, CELL x2, CELL x3, CELL x4, CELL size) +{ + CELL data[4]; + data[0] = x1; + data[1] = x2; + data[2] = x3; + data[3] = x4; + box_value_struct(data,size); +} diff --git a/vm/alien.hpp b/vm/alien.hpp index 301cfaad14..377a4317bc 100755 --- a/vm/alien.hpp +++ b/vm/alien.hpp @@ -1,46 +1,44 @@ CELL allot_alien(CELL delegate, CELL displacement); -void primitive_displaced_alien(void); -void primitive_alien_address(void); +PRIMITIVE(displaced_alien); +PRIMITIVE(alien_address); -DLLEXPORT char *alien_offset(CELL object); +PRIMITIVE(alien_signed_cell); +PRIMITIVE(set_alien_signed_cell); +PRIMITIVE(alien_unsigned_cell); +PRIMITIVE(set_alien_unsigned_cell); +PRIMITIVE(alien_signed_8); +PRIMITIVE(set_alien_signed_8); +PRIMITIVE(alien_unsigned_8); +PRIMITIVE(set_alien_unsigned_8); +PRIMITIVE(alien_signed_4); +PRIMITIVE(set_alien_signed_4); +PRIMITIVE(alien_unsigned_4); +PRIMITIVE(set_alien_unsigned_4); +PRIMITIVE(alien_signed_2); +PRIMITIVE(set_alien_signed_2); +PRIMITIVE(alien_unsigned_2); +PRIMITIVE(set_alien_unsigned_2); +PRIMITIVE(alien_signed_1); +PRIMITIVE(set_alien_signed_1); +PRIMITIVE(alien_unsigned_1); +PRIMITIVE(set_alien_unsigned_1); +PRIMITIVE(alien_float); +PRIMITIVE(set_alien_float); +PRIMITIVE(alien_double); +PRIMITIVE(set_alien_double); +PRIMITIVE(alien_cell); +PRIMITIVE(set_alien_cell); -DLLEXPORT char *unbox_alien(void); -DLLEXPORT void box_alien(void *ptr); +PRIMITIVE(dlopen); +PRIMITIVE(dlsym); +PRIMITIVE(dlclose); +PRIMITIVE(dll_validp); -void primitive_alien_signed_cell(void); -void primitive_set_alien_signed_cell(void); -void primitive_alien_unsigned_cell(void); -void primitive_set_alien_unsigned_cell(void); -void primitive_alien_signed_8(void); -void primitive_set_alien_signed_8(void); -void primitive_alien_unsigned_8(void); -void primitive_set_alien_unsigned_8(void); -void primitive_alien_signed_4(void); -void primitive_set_alien_signed_4(void); -void primitive_alien_unsigned_4(void); -void primitive_set_alien_unsigned_4(void); -void primitive_alien_signed_2(void); -void primitive_set_alien_signed_2(void); -void primitive_alien_unsigned_2(void); -void primitive_set_alien_unsigned_2(void); -void primitive_alien_signed_1(void); -void primitive_set_alien_signed_1(void); -void primitive_alien_unsigned_1(void); -void primitive_set_alien_unsigned_1(void); -void primitive_alien_float(void); -void primitive_set_alien_float(void); -void primitive_alien_double(void); -void primitive_set_alien_double(void); -void primitive_alien_cell(void); -void primitive_set_alien_cell(void); - -DLLEXPORT void to_value_struct(CELL src, void *dest, CELL size); -DLLEXPORT void box_value_struct(void *src, CELL size); -DLLEXPORT void box_small_struct(CELL x, CELL y, CELL size); -void box_medium_struct(CELL x1, CELL x2, CELL x3, CELL x4, CELL size); - -void primitive_dlopen(void); -void primitive_dlsym(void); -void primitive_dlclose(void); -void primitive_dll_validp(void); +VM_C_API char *alien_offset(CELL object); +VM_C_API char *unbox_alien(void); +VM_C_API void box_alien(void *ptr); +VM_C_API void to_value_struct(CELL src, void *dest, CELL size); +VM_C_API void box_value_struct(void *src, CELL size); +VM_C_API void box_small_struct(CELL x, CELL y, CELL size); +VM_C_API void box_medium_struct(CELL x1, CELL x2, CELL x3, CELL x4, CELL size); diff --git a/vm/arrays.cpp b/vm/arrays.cpp index ec592fae4f..3aa725e434 100644 --- a/vm/arrays.cpp +++ b/vm/arrays.cpp @@ -7,7 +7,7 @@ F_ARRAY *allot_array(CELL capacity, CELL fill_) gc_root array(allot_array_internal(capacity)); if(fill.value() == tag_fixnum(0)) - memset((void*)AREF(array.untagged(),0),'\0',capacity * CELLS); + memset(array->data(),'\0',capacity * CELLS); else { /* No need for write barrier here. Either the object is in @@ -15,13 +15,13 @@ F_ARRAY *allot_array(CELL capacity, CELL fill_) and the write barrier is already hit for us in that case. */ CELL i; for(i = 0; i < capacity; i++) - put(AREF(array.untagged(),i),fill.value()); + array->data()[i] = fill.value(); } return array.untagged(); } /* push a new array on the stack */ -void primitive_array(void) +PRIMITIVE(array) { CELL initial = dpop(); CELL size = unbox_array_size(); @@ -60,7 +60,7 @@ CELL allot_array_4(CELL v1_, CELL v2_, CELL v3_, CELL v4_) return a.value(); } -void primitive_resize_array(void) +PRIMITIVE(resize_array) { F_ARRAY* array = untag_check(dpop()); CELL capacity = unbox_array_size(); diff --git a/vm/arrays.hpp b/vm/arrays.hpp index dc68779dc0..a42bc81833 100644 --- a/vm/arrays.hpp +++ b/vm/arrays.hpp @@ -1,11 +1,31 @@ +inline static CELL array_nth(F_ARRAY *array, CELL slot) +{ +#ifdef FACTOR_DEBUG + assert(slot < array_capacity(array)); + assert(array->header.hi_tag() == ARRAY_TYPE); +#endif + return array->data()[slot]; +} + +inline static void set_array_nth(F_ARRAY *array, CELL slot, CELL value) +{ +#ifdef FACTOR_DEBUG + assert(slot < array_capacity(array)); + assert(array->header.hi_tag() == ARRAY_TYPE); + check_tagged_pointer(value); +#endif + array->data()[slot] = value; + write_barrier(array); +} + F_ARRAY *allot_array(CELL capacity, CELL fill); CELL allot_array_1(CELL obj); CELL allot_array_2(CELL v1, CELL v2); CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4); -void primitive_array(void); -void primitive_resize_array(void); +PRIMITIVE(array); +PRIMITIVE(resize_array); struct growable_array { CELL count; diff --git a/vm/bignum.cpp b/vm/bignum.cpp index 72356ff556..8cd17f7dc6 100755 --- a/vm/bignum.cpp +++ b/vm/bignum.cpp @@ -1352,7 +1352,6 @@ bignum_digit_to_bignum(bignum_digit_type digit, int negative_p) F_BIGNUM * allot_bignum(bignum_length_type length, int negative_p) { - gc(); BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX)); F_BIGNUM * result = allot_array_internal(length + 1); BIGNUM_SET_NEGATIVE_P (result, negative_p); diff --git a/vm/bignum.hpp b/vm/bignum.hpp index 23a0dd2142..208a0e436d 100644 --- a/vm/bignum.hpp +++ b/vm/bignum.hpp @@ -1,7 +1,7 @@ /* :tabSize=2:indentSize=2:noTabs=true: Copyright (C) 1989-1992 Massachusetts Institute of Technology -Portions copyright (C) 2004-2007 Slava Pestov +Portions copyright (C) 2004-2009 Slava Pestov This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and diff --git a/vm/bignumint.hpp b/vm/bignumint.hpp index 3e591e7436..72430eaa8e 100644 --- a/vm/bignumint.hpp +++ b/vm/bignumint.hpp @@ -64,8 +64,8 @@ typedef F_FIXNUM bignum_length_type; #define BIGNUM_LENGTH(bignum) (untag_fixnum((bignum)->capacity) - 1) -#define BIGNUM_NEGATIVE_P(bignum) (get(AREF(bignum,0)) != 0) -#define BIGNUM_SET_NEGATIVE_P(bignum,neg) put(AREF(bignum,0),neg) +#define BIGNUM_NEGATIVE_P(bignum) (bignum->data()[0] != 0) +#define BIGNUM_SET_NEGATIVE_P(bignum,neg) (bignum->data()[0] = neg) #define BIGNUM_ZERO_P(bignum) \ ((BIGNUM_LENGTH (bignum)) == 0) diff --git a/vm/booleans.cpp b/vm/booleans.cpp index 8cee090467..b63a67cd1c 100644 --- a/vm/booleans.cpp +++ b/vm/booleans.cpp @@ -1,13 +1,11 @@ #include "master.hpp" -/* FFI calls this */ -void box_boolean(bool value) +VM_C_API void box_boolean(bool value) { dpush(value ? T : F); } -/* FFI calls this */ -bool to_boolean(CELL value) +VM_C_API bool to_boolean(CELL value) { return value != F; } diff --git a/vm/booleans.hpp b/vm/booleans.hpp index ae49652dd8..7634afa02c 100644 --- a/vm/booleans.hpp +++ b/vm/booleans.hpp @@ -1,7 +1,7 @@ -INLINE CELL tag_boolean(CELL untagged) +inline static CELL tag_boolean(CELL untagged) { - return (untagged == false ? F : T); + return (untagged ? T : F); } -DLLEXPORT void box_boolean(bool value); -DLLEXPORT bool to_boolean(CELL value); +VM_C_API void box_boolean(bool value); +VM_C_API bool to_boolean(CELL value); diff --git a/vm/byte_arrays.cpp b/vm/byte_arrays.cpp index 303c0f032a..eaf0eff4b1 100644 --- a/vm/byte_arrays.cpp +++ b/vm/byte_arrays.cpp @@ -7,19 +7,19 @@ F_BYTE_ARRAY *allot_byte_array(CELL size) return array; } -void primitive_byte_array(void) +PRIMITIVE(byte_array) { CELL size = unbox_array_size(); dpush(tag(allot_byte_array(size))); } -void primitive_uninitialized_byte_array(void) +PRIMITIVE(uninitialized_byte_array) { CELL size = unbox_array_size(); dpush(tag(allot_array_internal(size))); } -void primitive_resize_byte_array(void) +PRIMITIVE(resize_byte_array) { F_BYTE_ARRAY *array = untag_check(dpop()); CELL capacity = unbox_array_size(); @@ -33,7 +33,7 @@ void growable_byte_array::append_bytes(void *elts, CELL len) if(new_size >= array_capacity(array.untagged())) array = reallot_array(array.untagged(),new_size * 2); - memcpy((void *)BREF(array.untagged(),count),elts,len); + memcpy(&array->data()[count],elts,len); count += len; } @@ -48,7 +48,7 @@ void growable_byte_array::append_byte_array(CELL byte_array_) if(new_size >= array_capacity(array.untagged())) array = reallot_array(array.untagged(),new_size * 2); - memcpy((void *)BREF(array.untagged(),count),byte_array.untagged() + 1,len); + memcpy(&array->data()[count],byte_array->data(),len); count += len; } diff --git a/vm/byte_arrays.hpp b/vm/byte_arrays.hpp index c5b62a96d6..dcc6658976 100644 --- a/vm/byte_arrays.hpp +++ b/vm/byte_arrays.hpp @@ -1,8 +1,8 @@ F_BYTE_ARRAY *allot_byte_array(CELL size); -void primitive_byte_array(void); -void primitive_uninitialized_byte_array(void); -void primitive_resize_byte_array(void); +PRIMITIVE(byte_array); +PRIMITIVE(uninitialized_byte_array); +PRIMITIVE(resize_byte_array); /* Macros to simulate a byte vector in C */ struct growable_byte_array { diff --git a/vm/callstack.cpp b/vm/callstack.cpp index f7c56d378c..3597716dcc 100755 --- a/vm/callstack.cpp +++ b/vm/callstack.cpp @@ -8,12 +8,6 @@ static void check_frame(F_STACK_FRAME *frame) #endif } -/* called before entry into Factor code. */ -F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom) -{ - stack_chain->callstack_bottom = callstack_bottom; -} - void iterate_callstack(CELL top, CELL bottom, CALLSTACK_ITER iterator) { F_STACK_FRAME *frame = (F_STACK_FRAME *)bottom - 1; @@ -68,7 +62,7 @@ F_STACK_FRAME *capture_start(void) return frame + 1; } -void primitive_callstack(void) +PRIMITIVE(callstack) { F_STACK_FRAME *top = capture_start(); F_STACK_FRAME *bottom = stack_chain->callstack_bottom; @@ -82,7 +76,7 @@ void primitive_callstack(void) dpush(tag(callstack)); } -void primitive_set_callstack(void) +PRIMITIVE(set_callstack) { F_CALLSTACK *stack = untag_check(dpop()); @@ -161,7 +155,7 @@ void stack_frame_to_array(F_STACK_FRAME *frame) set_array_nth(array,frame_index++,frame_scan(frame)); } -void primitive_callstack_to_array(void) +PRIMITIVE(callstack_to_array) { gc_root callstack(dpop()); @@ -189,39 +183,43 @@ F_STACK_FRAME *innermost_stack_frame(F_CALLSTACK *callstack) return frame; } +F_STACK_FRAME *innermost_stack_frame_quot(F_CALLSTACK *callstack) +{ + F_STACK_FRAME *inner = innermost_stack_frame(callstack); + tagged(frame_executing(inner)).untag_check(); + return inner; +} + /* Some primitives implementing a limited form of callstack mutation. Used by the single stepper. */ -void primitive_innermost_stack_frame_quot(void) +PRIMITIVE(innermost_stack_frame_quot) { - F_STACK_FRAME *inner = innermost_stack_frame( - untag_check(dpop())); - type_check(QUOTATION_TYPE,frame_executing(inner)); - - dpush(frame_executing(inner)); + dpush(frame_executing(innermost_stack_frame_quot(untag_check(dpop())))); } -void primitive_innermost_stack_frame_scan(void) +PRIMITIVE(innermost_stack_frame_scan) { - F_STACK_FRAME *inner = innermost_stack_frame( - untag_check(dpop())); - type_check(QUOTATION_TYPE,frame_executing(inner)); - - dpush(frame_scan(inner)); + dpush(frame_scan(innermost_stack_frame_quot(untag_check(dpop())))); } -void primitive_set_innermost_stack_frame_quot(void) +PRIMITIVE(set_innermost_stack_frame_quot) { gc_root callstack(dpop()); gc_root quot(dpop()); + callstack.untag_check(); + quot.untag_check(); + jit_compile(quot.value(),true); - F_STACK_FRAME *inner = innermost_stack_frame(callstack.untagged()); - type_check(QUOTATION_TYPE,frame_executing(inner)); - + F_STACK_FRAME *inner = innermost_stack_frame_quot(callstack.untagged()); CELL offset = (char *)FRAME_RETURN_ADDRESS(inner) - (char *)inner->xt; - inner->xt = quot->xt; - FRAME_RETURN_ADDRESS(inner) = (char *)quot->xt + offset; } + +/* called before entry into Factor code. */ +VM_ASM_API void save_callstack_bottom(F_STACK_FRAME *callstack_bottom) +{ + stack_chain->callstack_bottom = callstack_bottom; +} diff --git a/vm/callstack.hpp b/vm/callstack.hpp index 2468ef623a..fbdadcc859 100755 --- a/vm/callstack.hpp +++ b/vm/callstack.hpp @@ -1,4 +1,4 @@ -INLINE CELL callstack_size(CELL size) +inline static CELL callstack_size(CELL size) { return sizeof(F_CALLSTACK) + size; } @@ -16,11 +16,11 @@ CELL frame_executing(F_STACK_FRAME *frame); CELL frame_scan(F_STACK_FRAME *frame); CELL frame_type(F_STACK_FRAME *frame); -void primitive_callstack(void); -void primitive_set_callstack(void); -void primitive_callstack_to_array(void); -void primitive_innermost_stack_frame_quot(void); -void primitive_innermost_stack_frame_scan(void); -void primitive_set_innermost_stack_frame_quot(void); +PRIMITIVE(callstack); +PRIMITIVE(set_callstack); +PRIMITIVE(callstack_to_array); +PRIMITIVE(innermost_stack_frame_quot); +PRIMITIVE(innermost_stack_frame_scan); +PRIMITIVE(set_innermost_stack_frame_quot); -F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom); +VM_ASM_API void save_callstack_bottom(F_STACK_FRAME *callstack_bottom); diff --git a/vm/code_block.cpp b/vm/code_block.cpp index 8a95b46861..97a2e141da 100644 --- a/vm/code_block.cpp +++ b/vm/code_block.cpp @@ -47,23 +47,21 @@ void iterate_relocations(F_CODE_BLOCK *compiled, RELOCATION_ITERATOR iter) } /* Store a 32-bit value into a PowerPC LIS/ORI sequence */ -INLINE void store_address_2_2(CELL cell, CELL value) +static void store_address_2_2(CELL *cell, CELL value) { - put(cell - CELLS,((get(cell - CELLS) & ~0xffff) | ((value >> 16) & 0xffff))); - put(cell,((get(cell) & ~0xffff) | (value & 0xffff))); + cell[-1] = ((cell[-1] & ~0xffff) | ((value >> 16) & 0xffff)); + cell[ 0] = ((cell[ 0] & ~0xffff) | (value & 0xffff)); } /* Store a value into a bitfield of a PowerPC instruction */ -INLINE void store_address_masked(CELL cell, F_FIXNUM value, CELL mask, F_FIXNUM shift) +static void store_address_masked(CELL *cell, F_FIXNUM value, CELL mask, F_FIXNUM shift) { /* This is unaccurate but good enough */ F_FIXNUM test = (F_FIXNUM)mask >> 1; if(value <= -test || value >= test) critical_error("Value does not fit inside relocation",0); - u32 original = *(u32*)cell; - original &= ~mask; - *(u32*)cell = (original | ((value >> shift) & mask)); + *cell = ((*cell & ~mask) | ((value >> shift) & mask)); } /* Perform a fixup on a code block */ @@ -74,7 +72,7 @@ void store_address_in_code_block(CELL klass, CELL offset, F_FIXNUM absolute_valu switch(klass) { case RC_ABSOLUTE_CELL: - put(offset,absolute_value); + *(CELL *)offset = absolute_value; break; case RC_ABSOLUTE: *(u32*)offset = absolute_value; @@ -83,24 +81,24 @@ void store_address_in_code_block(CELL klass, CELL offset, F_FIXNUM absolute_valu *(u32*)offset = relative_value - sizeof(u32); break; case RC_ABSOLUTE_PPC_2_2: - store_address_2_2(offset,absolute_value); + store_address_2_2((CELL *)offset,absolute_value); break; case RC_RELATIVE_PPC_2: - store_address_masked(offset,relative_value,REL_RELATIVE_PPC_2_MASK,0); + store_address_masked((CELL *)offset,relative_value,REL_RELATIVE_PPC_2_MASK,0); break; case RC_RELATIVE_PPC_3: - store_address_masked(offset,relative_value,REL_RELATIVE_PPC_3_MASK,0); + store_address_masked((CELL *)offset,relative_value,REL_RELATIVE_PPC_3_MASK,0); break; case RC_RELATIVE_ARM_3: - store_address_masked(offset,relative_value - CELLS * 2, + store_address_masked((CELL *)offset,relative_value - CELLS * 2, REL_RELATIVE_ARM_3_MASK,2); break; case RC_INDIRECT_ARM: - store_address_masked(offset,relative_value - CELLS, + store_address_masked((CELL *)offset,relative_value - CELLS, REL_INDIRECT_ARM_MASK,0); break; case RC_INDIRECT_ARM_PC: - store_address_masked(offset,relative_value - CELLS * 2, + store_address_masked((CELL *)offset,relative_value - CELLS * 2, REL_INDIRECT_ARM_MASK,0); break; default: @@ -234,7 +232,7 @@ void update_literal_and_word_references(F_CODE_BLOCK *compiled) update_word_references(compiled); } -INLINE void check_code_address(CELL address) +static void check_code_address(CELL address) { #ifdef FACTOR_DEBUG assert(address >= code_heap.segment->start && address < code_heap.segment->end); @@ -273,28 +271,24 @@ void mark_active_blocks(F_CONTEXT *stacks) } } -void mark_object_code_block(CELL scan) +void mark_object_code_block(F_OBJECT *object) { - F_WORD *word; - F_QUOTATION *quot; - F_CALLSTACK *stack; - - switch(hi_tag(scan)) + switch(object->header.hi_tag()) { case WORD_TYPE: - word = (F_WORD *)scan; + F_WORD *word = (F_WORD *)object; if(word->code) mark_code_block(word->code); if(word->profiling) mark_code_block(word->profiling); break; case QUOTATION_TYPE: - quot = (F_QUOTATION *)scan; + F_QUOTATION *quot = (F_QUOTATION *)object; if(quot->compiledp != F) mark_code_block(quot->code); break; case CALLSTACK_TYPE: - stack = (F_CALLSTACK *)scan; + F_CALLSTACK *stack = (F_CALLSTACK *)object; iterate_callstack_object(stack,mark_stack_frame_step); break; } @@ -318,16 +312,17 @@ void *get_rel_symbol(F_ARRAY *literals, CELL index) if(dll != NULL && !dll->dll) return (void *)undefined_symbol; - if(type_of(symbol) == BYTE_ARRAY_TYPE) + switch(tagged(symbol).type()) { + case BYTE_ARRAY_TYPE: F_SYMBOL *name = alien_offset(symbol); void *sym = ffi_dlsym(dll,name); if(sym) return sym; - } - else if(type_of(symbol) == ARRAY_TYPE) - { + else + return (void *)undefined_symbol; + case ARRAY_TYPE: CELL i; F_ARRAY *names = untag(symbol); for(i = 0; i < array_capacity(names); i++) @@ -338,17 +333,19 @@ void *get_rel_symbol(F_ARRAY *literals, CELL index) if(sym) return sym; } + return (void *)undefined_symbol; + default: + critical_error("Bad symbol specifier",symbol); + return (void *)undefined_symbol; } - - return (void *)undefined_symbol; } /* Compute an address to store at a relocation */ void relocate_code_block_step(F_REL rel, CELL index, F_CODE_BLOCK *compiled) { #ifdef FACTOR_DEBUG - type_check(ARRAY_TYPE,compiled->literals); - type_check(BYTE_ARRAY_TYPE,compiled->relocation); + tagged(compiled->literals).untag_check(); + tagged(compiled->relocation).untag_check(); #endif CELL offset = REL_OFFSET(rel) + (CELL)(compiled + 1); diff --git a/vm/code_block.hpp b/vm/code_block.hpp index 1115b9b891..94bf0bddfc 100644 --- a/vm/code_block.hpp +++ b/vm/code_block.hpp @@ -49,9 +49,9 @@ typedef enum { /* code relocation table consists of a table of entries for each fixup */ typedef u32 F_REL; -#define REL_TYPE(r) (F_RELTYPE)(((r) & 0xf0000000) >> 28) -#define REL_CLASS(r) (F_RELCLASS)(((r) & 0x0f000000) >> 24) -#define REL_OFFSET(r) ((r) & 0x00ffffff) +#define REL_TYPE(r) (F_RELTYPE)(((r) & 0xf0000000) >> 28) +#define REL_CLASS(r) (F_RELCLASS)(((r) & 0x0f000000) >> 24) +#define REL_OFFSET(r) ((r) & 0x00ffffff) void flush_icache_for(F_CODE_BLOCK *compiled); @@ -75,11 +75,11 @@ void mark_code_block(F_CODE_BLOCK *compiled); void mark_active_blocks(F_CONTEXT *stacks); -void mark_object_code_block(CELL scan); +void mark_object_code_block(F_OBJECT *scan); void relocate_code_block(F_CODE_BLOCK *relocating); -INLINE bool stack_traces_p(void) +inline static bool stack_traces_p(void) { return userenv[STACK_TRACES_ENV] != F; } diff --git a/vm/code_gc.hpp b/vm/code_gc.hpp index f199e469ff..eef3b24629 100755 --- a/vm/code_gc.hpp +++ b/vm/code_gc.hpp @@ -25,7 +25,7 @@ CELL heap_size(F_HEAP *heap); CELL compute_heap_forwarding(F_HEAP *heap); void compact_heap(F_HEAP *heap); -INLINE F_BLOCK *next_block(F_HEAP *heap, F_BLOCK *block) +inline static F_BLOCK *next_block(F_HEAP *heap, F_BLOCK *block) { CELL next = ((CELL)block + block->size); if(next == heap->segment->end) @@ -34,12 +34,12 @@ INLINE F_BLOCK *next_block(F_HEAP *heap, F_BLOCK *block) return (F_BLOCK *)next; } -INLINE F_BLOCK *first_block(F_HEAP *heap) +inline static F_BLOCK *first_block(F_HEAP *heap) { return (F_BLOCK *)heap->segment->start; } -INLINE F_BLOCK *last_block(F_HEAP *heap) +inline static F_BLOCK *last_block(F_HEAP *heap) { return (F_BLOCK *)heap->segment->end; } diff --git a/vm/code_heap.cpp b/vm/code_heap.cpp index 4d7b3fc410..00fb56c81a 100755 --- a/vm/code_heap.cpp +++ b/vm/code_heap.cpp @@ -55,7 +55,7 @@ void update_code_heap_words(void) iterate_code_heap(update_word_references); } -void primitive_modify_code_heap(void) +PRIMITIVE(modify_code_heap) { gc_root alist(dpop()); @@ -105,7 +105,7 @@ void primitive_modify_code_heap(void) } /* Push the free space and total size of the code heap */ -void primitive_code_room(void) +PRIMITIVE(code_room) { CELL used, total_free, max_free; heap_usage(&code_heap,&used,&total_free,&max_free); @@ -136,7 +136,7 @@ void forward_object_xts(void) while((obj = next_object()) != F) { - switch(type_of(obj)) + switch(tagged(obj).type()) { case WORD_TYPE: F_WORD *word = untag(obj); @@ -176,14 +176,18 @@ void fixup_object_xts(void) while((obj = next_object()) != F) { - if(type_of(obj) == WORD_TYPE) - update_word_xt(obj); - else if(type_of(obj) == QUOTATION_TYPE) + switch(tagged(obj).type()) { + case WORD_TYPE: + update_word_xt(obj); + break; + case QUOTATION_TYPE: F_QUOTATION *quot = untag(obj); - if(quot->compiledp != F) set_quot_xt(quot,quot->code); + break; + default: + break; } } diff --git a/vm/code_heap.hpp b/vm/code_heap.hpp index 42571825be..6baff94988 100755 --- a/vm/code_heap.hpp +++ b/vm/code_heap.hpp @@ -13,13 +13,13 @@ void iterate_code_heap(CODE_HEAP_ITERATOR iter); void copy_code_heap_roots(void); -void primitive_modify_code_heap(void); +PRIMITIVE(modify_code_heap); -void primitive_code_room(void); +PRIMITIVE(code_room); void compact_code_heap(void); -INLINE void check_code_pointer(CELL pointer) +inline static void check_code_pointer(CELL pointer) { #ifdef FACTOR_DEBUG assert(pointer >= code_heap.segment->start && pointer < code_heap.segment->end); diff --git a/vm/contexts.cpp b/vm/contexts.cpp new file mode 100644 index 0000000000..f800191630 --- /dev/null +++ b/vm/contexts.cpp @@ -0,0 +1,186 @@ +#include "master.hpp" + +F_CONTEXT *stack_chain; +CELL ds_size, rs_size; +F_CONTEXT *unused_contexts; + +void reset_datastack(void) +{ + ds = ds_bot - CELLS; +} + +void reset_retainstack(void) +{ + rs = rs_bot - CELLS; +} + +#define RESERVED (64 * CELLS) + +void fix_stacks(void) +{ + if(ds + CELLS < ds_bot || ds + RESERVED >= ds_top) reset_datastack(); + if(rs + CELLS < rs_bot || rs + RESERVED >= rs_top) reset_retainstack(); +} + +/* called before entry into foreign C code. Note that ds and rs might +be stored in registers, so callbacks must save and restore the correct values */ +void save_stacks(void) +{ + if(stack_chain) + { + stack_chain->datastack = ds; + stack_chain->retainstack = rs; + } +} + +F_CONTEXT *alloc_context(void) +{ + F_CONTEXT *context; + + if(unused_contexts) + { + context = unused_contexts; + unused_contexts = unused_contexts->next; + } + else + { + context = (F_CONTEXT *)safe_malloc(sizeof(F_CONTEXT)); + context->datastack_region = alloc_segment(ds_size); + context->retainstack_region = alloc_segment(rs_size); + } + + return context; +} + +void dealloc_context(F_CONTEXT *context) +{ + context->next = unused_contexts; + unused_contexts = context; +} + +/* called on entry into a compiled callback */ +void nest_stacks(void) +{ + F_CONTEXT *new_stacks = alloc_context(); + + new_stacks->callstack_bottom = (F_STACK_FRAME *)-1; + new_stacks->callstack_top = (F_STACK_FRAME *)-1; + + /* note that these register values are not necessarily valid stack + pointers. they are merely saved non-volatile registers, and are + restored in unnest_stacks(). consider this scenario: + - factor code calls C function + - C function saves ds/cs registers (since they're non-volatile) + - C function clobbers them + - C function calls Factor callback + - Factor callback returns + - C function restores registers + - C function returns to Factor code */ + new_stacks->datastack_save = ds; + new_stacks->retainstack_save = rs; + + /* save per-callback userenv */ + new_stacks->current_callback_save = userenv[CURRENT_CALLBACK_ENV]; + new_stacks->catchstack_save = userenv[CATCHSTACK_ENV]; + + new_stacks->next = stack_chain; + stack_chain = new_stacks; + + reset_datastack(); + reset_retainstack(); +} + +/* called when leaving a compiled callback */ +void unnest_stacks(void) +{ + ds = stack_chain->datastack_save; + rs = stack_chain->retainstack_save; + + /* restore per-callback userenv */ + userenv[CURRENT_CALLBACK_ENV] = stack_chain->current_callback_save; + userenv[CATCHSTACK_ENV] = stack_chain->catchstack_save; + + F_CONTEXT *old_stacks = stack_chain; + stack_chain = old_stacks->next; + dealloc_context(old_stacks); +} + +/* called on startup */ +void init_stacks(CELL ds_size_, CELL rs_size_) +{ + ds_size = ds_size_; + rs_size = rs_size_; + stack_chain = NULL; + unused_contexts = NULL; +} + +bool stack_to_array(CELL bottom, CELL top) +{ + F_FIXNUM depth = (F_FIXNUM)(top - bottom + CELLS); + + if(depth < 0) + return false; + else + { + F_ARRAY *a = allot_array_internal(depth / CELLS); + memcpy(a + 1,(void*)bottom,depth); + dpush(tag(a)); + return true; + } +} + +PRIMITIVE(datastack) +{ + if(!stack_to_array(ds_bot,ds)) + general_error(ERROR_DS_UNDERFLOW,F,F,NULL); +} + +PRIMITIVE(retainstack) +{ + if(!stack_to_array(rs_bot,rs)) + general_error(ERROR_RS_UNDERFLOW,F,F,NULL); +} + +/* returns pointer to top of stack */ +CELL array_to_stack(F_ARRAY *array, CELL bottom) +{ + CELL depth = array_capacity(array) * CELLS; + memcpy((void*)bottom,array + 1,depth); + return bottom + depth - CELLS; +} + +PRIMITIVE(set_datastack) +{ + ds = array_to_stack(untag_check(dpop()),ds_bot); +} + +PRIMITIVE(set_retainstack) +{ + rs = array_to_stack(untag_check(dpop()),rs_bot); +} + +/* Used to implement call( */ +PRIMITIVE(check_datastack) +{ + F_FIXNUM out = to_fixnum(dpop()); + F_FIXNUM in = to_fixnum(dpop()); + F_FIXNUM height = out - in; + F_ARRAY *array = untag_check(dpop()); + F_FIXNUM length = array_capacity(array); + F_FIXNUM depth = (ds - ds_bot + CELLS) / CELLS; + if(depth - height != length) + dpush(F); + else + { + F_FIXNUM i; + for(i = 0; i < length - in; i++) + { + if(((CELL *)ds_bot)[i] != array_nth(array,i)) + { + dpush(F); + return; + } + } + dpush(T); + } +} diff --git a/vm/contexts.hpp b/vm/contexts.hpp new file mode 100644 index 0000000000..2c4ba71d37 --- /dev/null +++ b/vm/contexts.hpp @@ -0,0 +1,61 @@ +/* Assembly code makes assumptions about the layout of this struct: + - callstack_top field is 0 + - callstack_bottom field is 1 + - datastack field is 2 + - retainstack field is 3 */ +struct F_CONTEXT { + /* C stack pointer on entry */ + F_STACK_FRAME *callstack_top; + F_STACK_FRAME *callstack_bottom; + + /* current datastack top pointer */ + CELL datastack; + + /* current retain stack top pointer */ + CELL retainstack; + + /* saved contents of ds register on entry to callback */ + CELL datastack_save; + + /* saved contents of rs register on entry to callback */ + CELL retainstack_save; + + /* memory region holding current datastack */ + F_SEGMENT *datastack_region; + + /* memory region holding current retain stack */ + F_SEGMENT *retainstack_region; + + /* saved userenv slots on entry to callback */ + CELL catchstack_save; + CELL current_callback_save; + + F_CONTEXT *next; +}; + +extern F_CONTEXT *stack_chain; + +extern CELL ds_size, rs_size; + +#define ds_bot (stack_chain->datastack_region->start) +#define ds_top (stack_chain->datastack_region->end) +#define rs_bot (stack_chain->retainstack_region->start) +#define rs_top (stack_chain->retainstack_region->end) + +DEFPUSHPOP(d,ds) +DEFPUSHPOP(r,rs) + +void reset_datastack(void); +void reset_retainstack(void); +void fix_stacks(void); +void init_stacks(CELL ds_size, CELL rs_size); + +PRIMITIVE(datastack); +PRIMITIVE(retainstack); +PRIMITIVE(set_datastack); +PRIMITIVE(set_retainstack); +PRIMITIVE(check_datastack); + +VM_C_API void save_stacks(void); +VM_C_API void nest_stacks(void); +VM_C_API void unnest_stacks(void); diff --git a/vm/cpu-ppc.hpp b/vm/cpu-ppc.hpp index 298e21aa7d..20dfb9855a 100755 --- a/vm/cpu-ppc.hpp +++ b/vm/cpu-ppc.hpp @@ -1,5 +1,5 @@ #define FACTOR_CPU_STRING "ppc" -#define F_FASTCALL +#define VM_ASM_API register CELL ds asm("r29"); register CELL rs asm("r30"); diff --git a/vm/cpu-x86.32.hpp b/vm/cpu-x86.32.hpp index 0f99ce6130..97713d9ba2 100755 --- a/vm/cpu-x86.32.hpp +++ b/vm/cpu-x86.32.hpp @@ -3,4 +3,4 @@ register CELL ds asm("esi"); register CELL rs asm("edi"); -#define F_FASTCALL extern "C" __attribute__ ((regparm (2))) +#define VM_ASM_API extern "C" __attribute__ ((regparm (2))) diff --git a/vm/cpu-x86.64.hpp b/vm/cpu-x86.64.hpp index 2876823b20..497c85d998 100644 --- a/vm/cpu-x86.64.hpp +++ b/vm/cpu-x86.64.hpp @@ -3,4 +3,4 @@ register CELL ds asm("r14"); register CELL rs asm("r15"); -#define F_FASTCALL extern "C" +#define VM_ASM_API extern "C" diff --git a/vm/cpu-x86.hpp b/vm/cpu-x86.hpp index 4b3ac13819..58a13b5d95 100755 --- a/vm/cpu-x86.hpp +++ b/vm/cpu-x86.hpp @@ -2,9 +2,9 @@ #define FRAME_RETURN_ADDRESS(frame) *(XT *)(frame_successor(frame) + 1) -INLINE void flush_icache(CELL start, CELL len) {} +inline static void flush_icache(CELL start, CELL len) {} -INLINE void check_call_site(CELL return_address) +inline static void check_call_site(CELL return_address) { /* An x86 CALL instruction looks like so: |e8|..|..|..|..| @@ -16,30 +16,24 @@ INLINE void check_call_site(CELL return_address) #endif } -INLINE CELL get_call_target(CELL return_address) +inline static CELL get_call_target(CELL return_address) { check_call_site(return_address); return *(int *)(return_address - 4) + return_address; } -INLINE void set_call_target(CELL return_address, CELL target) +inline static void set_call_target(CELL return_address, CELL target) { check_call_site(return_address); *(int *)(return_address - 4) = (target - return_address); } /* Defined in assembly */ -extern "C" void primitive_fixnum_add(void); -extern "C" void primitive_fixnum_subtract(void); -extern "C" void primitive_fixnum_multiply(void); +VM_ASM_API void c_to_factor(CELL quot); +VM_ASM_API void throw_impl(CELL quot, F_STACK_FRAME *rewind_to); +VM_ASM_API void lazy_jit_compile(CELL quot); -F_FASTCALL void c_to_factor(CELL quot); -F_FASTCALL void throw_impl(CELL quot, F_STACK_FRAME *rewind_to); -F_FASTCALL void lazy_jit_compile(CELL quot); - -extern "C" void set_callstack(F_STACK_FRAME *to, +VM_C_API void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *(*memcpy)(void*,const void*, size_t)); - -extern "C" void primitive_inline_cache_miss(void); diff --git a/vm/data_gc.cpp b/vm/data_gc.cpp index b6c24ba4f9..dd229c7ad2 100755 --- a/vm/data_gc.cpp +++ b/vm/data_gc.cpp @@ -38,12 +38,11 @@ void init_data_gc(void) } /* Given a pointer to oldspace, copy it to newspace */ -static void *copy_untagged_object(void *pointer, CELL size) +static F_OBJECT *copy_untagged_object_impl(F_OBJECT *pointer, CELL size) { if(newspace->here + size >= newspace->end) longjmp(gc_jmp,1); - allot_barrier(newspace->here); - void *newpointer = allot_zone(newspace,size); + F_OBJECT *newpointer = allot_zone(newspace,size); F_GC_STATS *s = &gc_stats[collecting_gen]; s->object_count++; @@ -53,21 +52,14 @@ static void *copy_untagged_object(void *pointer, CELL size) return newpointer; } -static void forward_object(CELL untagged, CELL newpointer) +static F_OBJECT *copy_object_impl(F_OBJECT *untagged) { - put(untagged,RETAG(newpointer,GC_COLLECTED)); -} - -static CELL copy_object_impl(CELL untagged) -{ - CELL newpointer = (CELL)copy_untagged_object( - (void*)untagged, - untagged_object_size(untagged)); - forward_object(untagged,newpointer); + F_OBJECT *newpointer = copy_untagged_object_impl(untagged,untagged_object_size(untagged)); + untagged->header.forward_to(newpointer); return newpointer; } -static bool should_copy_p(CELL untagged) +static bool should_copy_p(F_OBJECT *untagged) { if(in_zone(newspace,untagged)) return false; @@ -79,51 +71,48 @@ static bool should_copy_p(CELL untagged) return in_zone(&nursery,untagged); else { - critical_error("Bug in should_copy_p",untagged); + critical_error("Bug in should_copy_p",(CELL)untagged); return false; } } /* Follow a chain of forwarding pointers */ -static CELL resolve_forwarding(CELL untagged, CELL tag) +static F_OBJECT *resolve_forwarding(F_OBJECT *untagged) { check_data_pointer(untagged); - CELL header = get(untagged); - /* another forwarding pointer */ - if(TAG(header) == GC_COLLECTED) - return resolve_forwarding(UNTAG(header),tag); + /* is there another forwarding pointer? */ + if(untagged->header.forwarding_pointer_p()) + return resolve_forwarding(untagged->header.forwarding_pointer()); /* we've found the destination */ else { - check_header(header); - CELL pointer = RETAG(untagged,tag); + untagged->header.check_header(); if(should_copy_p(untagged)) - pointer = RETAG(copy_object_impl(untagged),tag); - return pointer; + return copy_object_impl(untagged); + else + return untagged; } } -/* 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. While this preserves the tag, it does -not dispatch on it in any way. */ -static CELL copy_object(CELL pointer) +template static T *copy_untagged_object(T *untagged) { - check_data_pointer(pointer); + check_data_pointer(untagged); - CELL tag = TAG(pointer); - CELL untagged = UNTAG(pointer); - CELL header = get(untagged); - - if(TAG(header) == GC_COLLECTED) - return resolve_forwarding(UNTAG(header),tag); + if(untagged->header.forwarding_pointer_p()) + untagged = (T *)resolve_forwarding(untagged->header.forwarding_pointer()); else { - check_header(header); - return RETAG(copy_object_impl(untagged),tag); + untagged->header.check_header(); + untagged = (T *)copy_object_impl(untagged); } + + return untagged; +} + +static CELL copy_object(CELL pointer) +{ + return RETAG(copy_untagged_object(untag(pointer)),TAG(pointer)); } void copy_handle(CELL *handle) @@ -132,8 +121,9 @@ void copy_handle(CELL *handle) if(!immediate_p(pointer)) { - check_data_pointer(pointer); - if(should_copy_p(pointer)) + F_OBJECT *object = untag(pointer); + check_data_pointer(object); + if(should_copy_p(object)) *handle = copy_object(pointer); } } @@ -285,16 +275,16 @@ static void copy_registered_bignums(void) for(; scan <= gc_bignums; scan += CELLS) { - CELL *handle = *(CELL **)scan; - CELL pointer = *handle; + F_BIGNUM **handle = *(F_BIGNUM ***)scan; + F_BIGNUM *pointer = *handle; if(pointer) { check_data_pointer(pointer); if(should_copy_p(pointer)) - *handle = copy_object(pointer); + *handle = copy_untagged_object(pointer); #ifdef FACTOR_DEBUG - assert(hi_tag(*handle) == BIGNUM_TYPE); + assert((*handle)->header.hi_tag() == BIGNUM_TYPE); #endif } } @@ -339,7 +329,7 @@ static void copy_roots(void) static CELL copy_next_from_nursery(CELL scan) { CELL *obj = (CELL *)scan; - CELL *end = (CELL *)(scan + binary_payload_start(scan)); + CELL *end = (CELL *)(scan + binary_payload_start((F_OBJECT *)scan)); if(obj != end) { @@ -354,20 +344,20 @@ static CELL copy_next_from_nursery(CELL scan) if(!immediate_p(pointer)) { - check_data_pointer(pointer); + check_data_pointer((F_OBJECT *)pointer); if(pointer >= nursery_start && pointer < nursery_end) *obj = copy_object(pointer); } } } - return scan + untagged_object_size(scan); + return scan + untagged_object_size((F_OBJECT *)scan); } static CELL copy_next_from_aging(CELL scan) { CELL *obj = (CELL *)scan; - CELL *end = (CELL *)(scan + binary_payload_start(scan)); + CELL *end = (CELL *)(scan + binary_payload_start((F_OBJECT *)scan)); if(obj != end) { @@ -385,7 +375,7 @@ static CELL copy_next_from_aging(CELL scan) if(!immediate_p(pointer)) { - check_data_pointer(pointer); + check_data_pointer((F_OBJECT *)pointer); if(!(pointer >= newspace_start && pointer < newspace_end) && !(pointer >= tenured_start && pointer < tenured_end)) *obj = copy_object(pointer); @@ -393,13 +383,13 @@ static CELL copy_next_from_aging(CELL scan) } } - return scan + untagged_object_size(scan); + return scan + untagged_object_size((F_OBJECT *)scan); } static CELL copy_next_from_tenured(CELL scan) { CELL *obj = (CELL *)scan; - CELL *end = (CELL *)(scan + binary_payload_start(scan)); + CELL *end = (CELL *)(scan + binary_payload_start((F_OBJECT *)scan)); if(obj != end) { @@ -414,16 +404,16 @@ static CELL copy_next_from_tenured(CELL scan) if(!immediate_p(pointer)) { - check_data_pointer(pointer); + check_data_pointer((F_OBJECT *)pointer); if(!(pointer >= newspace_start && pointer < newspace_end)) *obj = copy_object(pointer); } } } - mark_object_code_block(scan); + mark_object_code_block((F_OBJECT *)scan); - return scan + untagged_object_size(scan); + return scan + untagged_object_size((F_OBJECT *)scan); } void copy_reachable_objects(CELL scan, CELL *end) @@ -605,17 +595,12 @@ void gc(void) garbage_collection(TENURED,false,0); } -void minor_gc(void) -{ - garbage_collection(NURSERY,false,0); -} - -void primitive_gc(void) +PRIMITIVE(gc) { gc(); } -void primitive_gc_stats(void) +PRIMITIVE(gc_stats) { growable_array stats; @@ -657,14 +642,14 @@ void clear_gc_stats(void) code_heap_scans = 0; } -void primitive_clear_gc_stats(void) +PRIMITIVE(clear_gc_stats) { clear_gc_stats(); } /* classes.tuple uses this to reshape tuples; tools.deploy.shaker uses this to coalesce equal but distinct quotations and wrappers. */ -void primitive_become(void) +PRIMITIVE(become) { F_ARRAY *new_objects = untag_check(dpop()); F_ARRAY *old_objects = untag_check(dpop()); @@ -677,11 +662,11 @@ void primitive_become(void) for(i = 0; i < capacity; i++) { - CELL old_obj = array_nth(old_objects,i); - CELL new_obj = array_nth(new_objects,i); + tagged old_obj(array_nth(old_objects,i)); + tagged new_obj(array_nth(new_objects,i)); if(old_obj != new_obj) - forward_object(UNTAG(old_obj),new_obj); + old_obj->header.forward_to(new_obj.untagged()); } gc(); @@ -692,3 +677,8 @@ void primitive_become(void) unoptimized words. */ compile_all_words(); } + +VM_C_API void minor_gc(void) +{ + garbage_collection(NURSERY,false,0); +} diff --git a/vm/data_gc.hpp b/vm/data_gc.hpp index f84f9f0699..068429bfdd 100755 --- a/vm/data_gc.hpp +++ b/vm/data_gc.hpp @@ -1,8 +1,3 @@ -void init_data_gc(void); - -void gc(void); -DLLEXPORT void minor_gc(void); - /* statistics */ struct F_GC_STATS { CELL collections; @@ -18,7 +13,13 @@ extern bool performing_compaction; extern CELL collecting_gen; extern bool collecting_aging_again; -INLINE bool collecting_accumulation_gen_p(void) +extern CELL last_code_heap_scan; + +void init_data_gc(void); + +void gc(void); + +inline static bool collecting_accumulation_gen_p(void) { return ((HAVE_AGING_P && collecting_gen == AGING @@ -26,8 +27,6 @@ INLINE bool collecting_accumulation_gen_p(void) || collecting_gen == TENURED); } -extern CELL last_code_heap_scan; - void copy_handle(CELL *handle); void garbage_collection(volatile CELL gen, @@ -43,7 +42,7 @@ registers) does not run out of memory */ * It is up to the caller to fill in the object's fields in a meaningful * fashion! */ -INLINE void *allot_object(CELL header, CELL size) +inline static F_OBJECT *allot_object(F_HEADER header, CELL size) { #ifdef GC_DEBUG if(!gc_off) @@ -82,15 +81,12 @@ INLINE void *allot_object(CELL header, CELL size) tenured = &data_heap->generations[TENURED]; } - object = (F_OBJECT *)allot_zone(tenured,size); - - /* We have to do this */ - allot_barrier((CELL)object); + object = allot_zone(tenured,size); /* Allows initialization code to store old->new pointers without hitting the write barrier in the common case of a nursery allocation */ - write_barrier((CELL)object); + write_barrier(object); } object->header = header; @@ -99,26 +95,41 @@ INLINE void *allot_object(CELL header, CELL size) template T *allot(CELL size) { - return (T *)allot_object(tag_header(T::type_number),size); + return (T *)allot_object(F_HEADER(T::type_number),size); } void copy_reachable_objects(CELL scan, CELL *end); -void primitive_gc(void); -void primitive_gc_stats(void); +PRIMITIVE(gc); +PRIMITIVE(gc_stats); void clear_gc_stats(void); -void primitive_clear_gc_stats(void); -void primitive_become(void); +PRIMITIVE(clear_gc_stats); +PRIMITIVE(become); extern bool growing_data_heap; -INLINE void check_data_pointer(CELL pointer) +inline static void check_data_pointer(F_OBJECT *pointer) { #ifdef FACTOR_DEBUG if(!growing_data_heap) { - assert(pointer >= data_heap->segment->start - && pointer < data_heap->segment->end); + assert((CELL)pointer >= data_heap->segment->start + && (CELL)pointer < data_heap->segment->end); } #endif } + +inline static void check_tagged_pointer(CELL tagged) +{ +#ifdef FACTOR_DEBUG + if(!immediate_p(tagged)) + { + F_OBJECT *object = untag(tagged); + check_data_pointer(object); + object->header.hi_tag(); + } +#endif +} + +VM_C_API void minor_gc(void); + diff --git a/vm/data_heap.cpp b/vm/data_heap.cpp index ea206c6b3f..39d58d6796 100644 --- a/vm/data_heap.cpp +++ b/vm/data_heap.cpp @@ -4,7 +4,7 @@ bool secure_gc; /* new objects are allocated here */ -DLLEXPORT F_ZONE nursery; +VM_C_API F_ZONE nursery; /* GC is off during heap walking */ bool gc_off; @@ -198,22 +198,22 @@ CELL object_size(CELL tagged) if(immediate_p(tagged)) return 0; else - return untagged_object_size(UNTAG(tagged)); + return untagged_object_size(untag(tagged)); } /* Size of the object pointed to by an untagged pointer */ -CELL untagged_object_size(CELL pointer) +CELL untagged_object_size(F_OBJECT *pointer) { return align8(unaligned_object_size(pointer)); } /* Size of the data area of an object pointed to by an untagged pointer */ -CELL unaligned_object_size(CELL pointer) +CELL unaligned_object_size(F_OBJECT *pointer) { F_TUPLE *tuple; F_TUPLE_LAYOUT *layout; - switch(untag_header(get(pointer))) + switch(pointer->header.hi_tag()) { case ARRAY_TYPE: return array_size((F_ARRAY*)pointer); @@ -243,12 +243,12 @@ CELL unaligned_object_size(CELL pointer) return callstack_size( untag_fixnum(((F_CALLSTACK *)pointer)->length)); default: - critical_error("Invalid header",pointer); + critical_error("Invalid header",(CELL)pointer); return -1; /* can't happen */ } } -void primitive_size(void) +PRIMITIVE(size) { box_unsigned_cell(object_size(dpop())); } @@ -256,12 +256,12 @@ void primitive_size(void) /* The number of cells from the start of the object which should be scanned by the GC. Some types have a binary payload at the end (string, word, DLL) which we ignore. */ -CELL binary_payload_start(CELL pointer) +CELL binary_payload_start(F_OBJECT *pointer) { F_TUPLE *tuple; F_TUPLE_LAYOUT *layout; - switch(untag_header(get(pointer))) + switch(pointer->header.hi_tag()) { /* these objects do not refer to other objects at all */ case FLOAT_TYPE: @@ -290,13 +290,13 @@ CELL binary_payload_start(CELL pointer) case WRAPPER_TYPE: return sizeof(F_WRAPPER); default: - critical_error("Invalid header",pointer); + critical_error("Invalid header",(CELL)pointer); return -1; /* can't happen */ } } /* Push memory usage statistics in data heap */ -void primitive_data_room(void) +PRIMITIVE(data_room) { dpush(tag_fixnum((data_heap->cards_end - data_heap->cards) >> 10)); dpush(tag_fixnum((data_heap->decks_end - data_heap->decks) >> 10)); @@ -326,7 +326,7 @@ void begin_scan(void) gc_off = true; } -void primitive_begin_scan(void) +PRIMITIVE(begin_scan) { begin_scan(); } @@ -336,27 +336,22 @@ CELL next_object(void) if(!gc_off) general_error(ERROR_HEAP_SCAN,F,F,NULL); - CELL value = get(heap_scan_ptr); - CELL obj = heap_scan_ptr; - CELL type; - if(heap_scan_ptr >= data_heap->generations[TENURED].here) return F; - type = untag_header(value); - heap_scan_ptr += untagged_object_size(heap_scan_ptr); - - return RETAG(obj,type < HEADER_TYPE ? type : OBJECT_TYPE); + F_OBJECT *object = (F_OBJECT *)heap_scan_ptr; + heap_scan_ptr += untagged_object_size(object); + return tag_dynamic(object); } /* Push object at heap scan cursor and advance; pushes f when done */ -void primitive_next_object(void) +PRIMITIVE(next_object) { dpush(next_object()); } /* Re-enables GC */ -void primitive_end_scan(void) +PRIMITIVE(end_scan) { gc_off = false; } @@ -370,7 +365,7 @@ CELL find_all_words(void) CELL obj; while((obj = next_object()) != F) { - if(type_of(obj) == WORD_TYPE) + if(tagged(obj).type_p(WORD_TYPE)) words.add(obj); } diff --git a/vm/data_heap.hpp b/vm/data_heap.hpp index db3cbd52f8..d32f53fb2b 100644 --- a/vm/data_heap.hpp +++ b/vm/data_heap.hpp @@ -49,9 +49,9 @@ extern F_DATA_HEAP *data_heap; /* new objects are allocated here */ extern F_ZONE nursery; -INLINE bool in_zone(F_ZONE *z, CELL pointer) +inline static bool in_zone(F_ZONE *z, F_OBJECT *pointer) { - return pointer >= z->start && pointer < z->end; + return (CELL)pointer >= z->start && (CELL)pointer < z->end; } CELL init_zone(F_ZONE *z, CELL size, CELL base); @@ -81,29 +81,31 @@ size must be a multiple of the page size */ F_SEGMENT *alloc_segment(CELL size); void dealloc_segment(F_SEGMENT *block); -CELL untagged_object_size(CELL pointer); -CELL unaligned_object_size(CELL pointer); -CELL object_size(CELL pointer); -CELL binary_payload_start(CELL pointer); +CELL untagged_object_size(F_OBJECT *pointer); +CELL unaligned_object_size(F_OBJECT *pointer); +CELL binary_payload_start(F_OBJECT *pointer); +CELL object_size(CELL tagged); void begin_scan(void); CELL next_object(void); -void primitive_data_room(void); -void primitive_size(void); +PRIMITIVE(data_room); +PRIMITIVE(size); -void primitive_begin_scan(void); -void primitive_next_object(void); -void primitive_end_scan(void); +PRIMITIVE(begin_scan); +PRIMITIVE(next_object); +PRIMITIVE(end_scan); /* GC is off during heap walking */ extern bool gc_off; -INLINE void *allot_zone(F_ZONE *z, CELL a) +inline static F_OBJECT *allot_zone(F_ZONE *z, CELL a) { CELL h = z->here; z->here = h + align8(a); - return (void*)h; + F_OBJECT *object = (F_OBJECT *)h; + allot_barrier(object); + return object; } CELL find_all_words(void); @@ -111,10 +113,10 @@ CELL find_all_words(void); /* Every object has a regular representation in the runtime, which makes GC much simpler. Every slot of the object until binary_payload_start is a pointer to some other object. */ -INLINE void do_slots(CELL obj, void (* iter)(CELL *)) +inline static void do_slots(CELL obj, void (* iter)(CELL *)) { CELL scan = obj; - CELL payload_start = binary_payload_start(obj); + CELL payload_start = binary_payload_start((F_OBJECT *)obj); CELL end = obj + payload_start; scan += CELLS; diff --git a/vm/debug.cpp b/vm/debug.cpp index 2335e4cfb1..411570b50d 100755 --- a/vm/debug.cpp +++ b/vm/debug.cpp @@ -12,14 +12,13 @@ void print_chars(F_STRING* str) void print_word(F_WORD* word, CELL nesting) { - - if(type_of(word->vocabulary) == STRING_TYPE) + if(tagged(word->vocabulary).type_p(STRING_TYPE)) { print_chars(untag(word->vocabulary)); print_string(":"); } - - if(type_of(word->name) == STRING_TYPE) + + if(tagged(word->name).type_p(STRING_TYPE)) print_chars(untag(word->name)); else { @@ -99,7 +98,7 @@ void print_nested_obj(CELL obj, F_FIXNUM nesting) F_QUOTATION *quot; - switch(type_of(obj)) + switch(tagged(obj).type()) { case FIXNUM_TYPE: print_fixnum(untag_fixnum(obj)); @@ -130,7 +129,11 @@ void print_nested_obj(CELL obj, F_FIXNUM nesting) print_string(" ]"); break; default: - print_string("#"); + print_string("#(obj).type()); + print_string(" @ "); + print_cell_hex(obj); + print_string(">"); break; } } @@ -140,11 +143,11 @@ void print_obj(CELL obj) print_nested_obj(obj,10); } -void print_objects(CELL start, CELL end) +void print_objects(CELL *start, CELL *end) { - for(; start <= end; start += CELLS) + for(; start <= end; start++) { - print_obj(get(start)); + print_obj(*start); nl(); } } @@ -152,13 +155,13 @@ void print_objects(CELL start, CELL end) void print_datastack(void) { print_string("==== DATA STACK:\n"); - print_objects(ds_bot,ds); + print_objects((CELL *)ds_bot,(CELL *)ds); } void print_retainstack(void) { print_string("==== RETAIN STACK:\n"); - print_objects(rs_bot,rs); + print_objects((CELL *)rs_bot,(CELL *)rs); } void print_stack_frame(F_STACK_FRAME *frame) @@ -184,39 +187,8 @@ void print_callstack(void) void dump_cell(CELL cell) { print_cell_hex_pad(cell); print_string(": "); - - cell = get(cell); - + cell = *(CELL *)cell; print_cell_hex_pad(cell); print_string(" tag "); print_cell(TAG(cell)); - - switch(TAG(cell)) - { - case OBJECT_TYPE: - case BIGNUM_TYPE: - case FLOAT_TYPE: - if(cell == F) - print_string(" -- F"); - else if(cell < TYPE_COUNT<>TAG_BITS); - } - else if(cell >= data_heap->segment->start - && cell < data_heap->segment->end) - { - CELL header = get(UNTAG(cell)); - CELL type = header>>TAG_BITS; - print_string(" -- object; "); - if(TAG(header) == 0 && type < TYPE_COUNT) - { - print_string(" type "); print_cell(type); - } - else - print_string(" header corrupt"); - } - break; - } - nl(); } @@ -269,7 +241,7 @@ void dump_objects(CELL type) CELL obj; while((obj = next_object()) != F) { - if(type == TYPE_COUNT || type_of(obj) == type) + if(type == TYPE_COUNT || tagged(obj).type_p(type)) { print_cell_hex_pad(obj); print_string(" "); @@ -494,7 +466,7 @@ void factorbug(void) } } -void primitive_die(void) +PRIMITIVE(die) { print_string("The die word was called by the library. Unless you called it yourself,\n"); print_string("you have triggered a bug in Factor. Please report.\n"); diff --git a/vm/debug.hpp b/vm/debug.hpp index 002b251621..97b0c32d54 100755 --- a/vm/debug.hpp +++ b/vm/debug.hpp @@ -4,4 +4,4 @@ void dump_generations(void); void factorbug(void); void dump_zone(F_ZONE *z); -void primitive_die(void); +PRIMITIVE(die); diff --git a/vm/dispatch.cpp b/vm/dispatch.cpp index 87b172c2d3..b8c2b85779 100644 --- a/vm/dispatch.cpp +++ b/vm/dispatch.cpp @@ -23,7 +23,7 @@ static CELL search_lookup_hash(CELL table, CELL klass, CELL hashcode) { F_ARRAY *buckets = untag(table); CELL bucket = array_nth(buckets,hashcode & (array_capacity(buckets) - 1)); - if(type_of(bucket) == WORD_TYPE || bucket == F) + if(tagged(bucket).type_p(WORD_TYPE) || bucket == F) return bucket; else return search_lookup_alist(bucket,klass); @@ -56,7 +56,7 @@ static CELL lookup_tuple_method(CELL object, CELL methods) { CELL echelon_methods = array_nth(echelons,echelon); - if(type_of(echelon_methods) == WORD_TYPE) + if(tagged(echelon_methods).type_p(WORD_TYPE)) return echelon_methods; else if(echelon_methods != F) { @@ -77,7 +77,7 @@ static CELL lookup_tuple_method(CELL object, CELL methods) static CELL lookup_hi_tag_method(CELL object, CELL methods) { F_ARRAY *hi_tag_methods = untag(methods); - CELL tag = hi_tag(object) - HEADER_TYPE; + CELL tag = untag(object)->header.hi_tag() - HEADER_TYPE; #ifdef FACTOR_DEBUG assert(tag < TYPE_COUNT - HEADER_TYPE); #endif @@ -87,7 +87,7 @@ static CELL lookup_hi_tag_method(CELL object, CELL methods) static CELL lookup_hairy_method(CELL object, CELL methods) { CELL method = array_nth(untag(methods),TAG(object)); - if(type_of(method) == WORD_TYPE) + if(tagged(method).type_p(WORD_TYPE)) return method; else { @@ -108,13 +108,14 @@ static CELL lookup_hairy_method(CELL object, CELL methods) CELL lookup_method(CELL object, CELL methods) { - if(!HI_TAG_OR_TUPLE_P(object)) - return array_nth(untag(methods),TAG(object)); - else + CELL tag = TAG(object); + if(tag == TUPLE_TYPE || tag == OBJECT_TYPE) return lookup_hairy_method(object,methods); + else + return array_nth(untag(methods),TAG(object)); } -void primitive_lookup_method(void) +PRIMITIVE(lookup_method) { CELL methods = dpop(); CELL object = dpop(); @@ -123,10 +124,15 @@ void primitive_lookup_method(void) CELL object_class(CELL object) { - if(!HI_TAG_OR_TUPLE_P(object)) + switch(TAG(object)) + { + case TUPLE_TYPE: + return untag(object)->layout; + case OBJECT_TYPE: + return untag(object)->header.header; + default: return tag_fixnum(TAG(object)); - else - return get(HI_TAG_HEADER(object)); + } } static CELL method_cache_hashcode(CELL klass, F_ARRAY *array) @@ -143,7 +149,7 @@ static void update_method_cache(CELL cache, CELL klass, CELL method) set_array_nth(array,hashcode + 1,method); } -void primitive_mega_cache_miss(void) +PRIMITIVE(mega_cache_miss) { megamorphic_cache_misses++; @@ -151,7 +157,7 @@ void primitive_mega_cache_miss(void) F_FIXNUM index = untag_fixnum(dpop()); CELL methods = dpop(); - CELL object = get(ds - index * CELLS); + CELL object = ((CELL *)ds)[-index]; CELL klass = object_class(object); CELL method = lookup_method(object,methods); @@ -160,12 +166,12 @@ void primitive_mega_cache_miss(void) dpush(method); } -void primitive_reset_dispatch_stats(void) +PRIMITIVE(reset_dispatch_stats) { megamorphic_cache_hits = megamorphic_cache_misses = 0; } -void primitive_dispatch_stats(void) +PRIMITIVE(dispatch_stats) { growable_array stats; stats.add(allot_cell(megamorphic_cache_hits)); diff --git a/vm/dispatch.hpp b/vm/dispatch.hpp index be1359fc15..d86854982f 100644 --- a/vm/dispatch.hpp +++ b/vm/dispatch.hpp @@ -1,12 +1,12 @@ CELL lookup_method(CELL object, CELL methods); -void primitive_lookup_method(void); +PRIMITIVE(lookup_method); CELL object_class(CELL object); -void primitive_mega_cache_miss(void); +PRIMITIVE(mega_cache_miss); -void primitive_reset_dispatch_stats(void); -void primitive_dispatch_stats(void); +PRIMITIVE(reset_dispatch_stats); +PRIMITIVE(dispatch_stats); void jit_emit_class_lookup(jit *jit, F_FIXNUM index, CELL type); diff --git a/vm/errors.cpp b/vm/errors.cpp index 0404022802..8e21a6a13d 100755 --- a/vm/errors.cpp +++ b/vm/errors.cpp @@ -127,13 +127,13 @@ void divide_by_zero_error(void) general_error(ERROR_DIVIDE_BY_ZERO,F,F,NULL); } -void primitive_call_clear(void) +PRIMITIVE(call_clear) { throw_impl(dpop(),stack_chain->callstack_bottom); } /* For testing purposes */ -void primitive_unimplemented(void) +PRIMITIVE(unimplemented) { not_implemented_error(); } diff --git a/vm/errors.hpp b/vm/errors.hpp index 39733646f4..da7d1458f3 100755 --- a/vm/errors.hpp +++ b/vm/errors.hpp @@ -22,7 +22,8 @@ typedef enum void out_of_memory(void); void fatal_error(char* msg, CELL tagged); void critical_error(char* msg, CELL tagged); -void primitive_die(void); + +PRIMITIVE(die); void throw_error(CELL error, F_STACK_FRAME *native_stack); void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2, F_STACK_FRAME *native_stack); @@ -32,14 +33,8 @@ void signal_error(int signal, F_STACK_FRAME *native_stack); void type_error(CELL type, CELL tagged); void not_implemented_error(void); -void primitive_call_clear(void); - -INLINE void type_check(CELL type, CELL tagged) -{ - if(type_of(tagged) != type) type_error(type,tagged); -} - -void primitive_unimplemented(void); +PRIMITIVE(call_clear); +PRIMITIVE(unimplemented); /* Global variables used to pass fault handler state from signal handler to user-space */ diff --git a/vm/factor.cpp b/vm/factor.cpp index 59263e1da8..1e261a91ba 100755 --- a/vm/factor.cpp +++ b/vm/factor.cpp @@ -1,6 +1,6 @@ #include "master.hpp" -void default_parameters(F_PARAMETERS *p) +VM_C_API void default_parameters(F_PARAMETERS *p) { p->image_path = NULL; @@ -40,7 +40,7 @@ void default_parameters(F_PARAMETERS *p) p->stack_traces = true; } -INLINE bool factor_arg(const F_CHAR* str, const F_CHAR* arg, CELL* value) +static bool factor_arg(const F_CHAR* str, const F_CHAR* arg, CELL* value) { int val; if(SSCANF(str,arg,&val) > 0) @@ -52,7 +52,7 @@ INLINE bool factor_arg(const F_CHAR* str, const F_CHAR* arg, CELL* value) return false; } -void init_parameters_from_args(F_PARAMETERS *p, int argc, F_CHAR **argv) +VM_C_API void init_parameters_from_args(F_PARAMETERS *p, int argc, F_CHAR **argv) { default_parameters(p); p->executable_path = argv[0]; @@ -78,7 +78,7 @@ void init_parameters_from_args(F_PARAMETERS *p, int argc, F_CHAR **argv) } /* Do some initialization that we do once only */ -void do_stage1_init(void) +static void do_stage1_init(void) { print_string("*** Stage 2 early init... "); fflush(stdout); @@ -90,7 +90,7 @@ void do_stage1_init(void) fflush(stdout); } -void init_factor(F_PARAMETERS *p) +VM_C_API void init_factor(F_PARAMETERS *p) { /* Kilobytes */ p->ds_size = align_page(p->ds_size << 10); @@ -122,7 +122,10 @@ void init_factor(F_PARAMETERS *p) load_image(p); init_c_io(); init_inline_caching(p->max_pic_size); + +#ifndef FACTOR_DEBUG init_signals(); +#endif if(p->console) open_console(); @@ -147,7 +150,7 @@ void init_factor(F_PARAMETERS *p) } /* May allocate memory */ -void pass_args_to_factor(int argc, F_CHAR **argv) +VM_C_API void pass_args_to_factor(int argc, F_CHAR **argv) { growable_array args; int i; @@ -159,7 +162,7 @@ void pass_args_to_factor(int argc, F_CHAR **argv) userenv[ARGS_ENV] = args.array.value(); } -void start_factor(F_PARAMETERS *p) +static void start_factor(F_PARAMETERS *p) { if(p->fep) factorbug(); @@ -168,13 +171,13 @@ void start_factor(F_PARAMETERS *p) unnest_stacks(); } -void start_embedded_factor(F_PARAMETERS *p) +VM_C_API void start_embedded_factor(F_PARAMETERS *p) { userenv[EMBEDDED_ENV] = T; start_factor(p); } -void start_standalone_factor(int argc, F_CHAR **argv) +VM_C_API void start_standalone_factor(int argc, F_CHAR **argv) { F_PARAMETERS p; default_parameters(&p); @@ -184,24 +187,24 @@ void start_standalone_factor(int argc, F_CHAR **argv) start_factor(&p); } -char *factor_eval_string(char *string) +VM_C_API char *factor_eval_string(char *string) { char *(*callback)(char *) = (char *(*)(char *))alien_offset(userenv[EVAL_CALLBACK_ENV]); return callback(string); } -void factor_eval_free(char *result) +VM_C_API void factor_eval_free(char *result) { free(result); } -void factor_yield(void) +VM_C_API void factor_yield(void) { void (*callback)(void) = (void (*)(void))alien_offset(userenv[YIELD_CALLBACK_ENV]); callback(); } -void factor_sleep(long us) +VM_C_API void factor_sleep(long us) { void (*callback)(long) = (void (*)(long))alien_offset(userenv[SLEEP_CALLBACK_ENV]); callback(us); diff --git a/vm/factor.hpp b/vm/factor.hpp index a3de31a502..08fa9be6b1 100644 --- a/vm/factor.hpp +++ b/vm/factor.hpp @@ -1,11 +1,11 @@ -DLLEXPORT void default_parameters(F_PARAMETERS *p); -DLLEXPORT void init_parameters_from_args(F_PARAMETERS *p, int argc, F_CHAR **argv); -DLLEXPORT void init_factor(F_PARAMETERS *p); -DLLEXPORT void pass_args_to_factor(int argc, F_CHAR **argv); -DLLEXPORT void start_embedded_factor(F_PARAMETERS *p); -DLLEXPORT void start_standalone_factor(int argc, F_CHAR **argv); +VM_C_API void default_parameters(F_PARAMETERS *p); +VM_C_API void init_parameters_from_args(F_PARAMETERS *p, int argc, F_CHAR **argv); +VM_C_API void init_factor(F_PARAMETERS *p); +VM_C_API void pass_args_to_factor(int argc, F_CHAR **argv); +VM_C_API void start_embedded_factor(F_PARAMETERS *p); +VM_C_API void start_standalone_factor(int argc, F_CHAR **argv); -DLLEXPORT char *factor_eval_string(char *string); -DLLEXPORT void factor_eval_free(char *result); -DLLEXPORT void factor_yield(void); -DLLEXPORT void factor_sleep(long ms); +VM_C_API char *factor_eval_string(char *string); +VM_C_API void factor_eval_free(char *result); +VM_C_API void factor_yield(void); +VM_C_API void factor_sleep(long ms); diff --git a/vm/float_bits.hpp b/vm/float_bits.hpp index a60d42f97c..d380400640 100644 --- a/vm/float_bits.hpp +++ b/vm/float_bits.hpp @@ -6,14 +6,14 @@ typedef union { u64 y; } F_DOUBLE_BITS; -INLINE u64 double_bits(double x) +inline static u64 double_bits(double x) { F_DOUBLE_BITS b; b.x = x; return b.y; } -INLINE double bits_double(u64 y) +inline static double bits_double(u64 y) { F_DOUBLE_BITS b; b.y = y; @@ -25,14 +25,14 @@ typedef union { u32 y; } F_FLOAT_BITS; -INLINE u32 float_bits(float x) +inline static u32 float_bits(float x) { F_FLOAT_BITS b; b.x = x; return b.y; } -INLINE float bits_float(u32 y) +inline static float bits_float(u32 y) { F_FLOAT_BITS b; b.y = y; diff --git a/vm/generic_arrays.hpp b/vm/generic_arrays.hpp index ac5a353d83..5774f3b001 100644 --- a/vm/generic_arrays.hpp +++ b/vm/generic_arrays.hpp @@ -1,34 +1,11 @@ template CELL array_capacity(T *array) { #ifdef FACTOR_DEBUG - CELL header = untag_header(array->header); - assert(header == T::type_number); + assert(array->header.hi_tag() == T::type_number); #endif return array->capacity >> TAG_BITS; } -#define AREF(array,index) ((CELL)(array) + sizeof(F_ARRAY) + (index) * CELLS) -#define UNAREF(array,ptr) (((CELL)(ptr)-(CELL)(array)-sizeof(F_ARRAY)) / CELLS) - -template CELL array_nth(T *array, CELL slot) -{ -#ifdef FACTOR_DEBUG - assert(slot < array_capacity(array)); - assert(untag_header(array->header) == T::type_number); -#endif - return get(AREF(array,slot)); -} - -template void set_array_nth(T *array, CELL slot, CELL value) -{ -#ifdef FACTOR_DEBUG - assert(slot < array_capacity(array)); - assert(untag_header(array->header) == T::type_number); -#endif - put(AREF(array,slot),value); - write_barrier((CELL)array); -} - template CELL array_size(CELL capacity) { return sizeof(T) + capacity * T::element_size; @@ -48,7 +25,7 @@ template T *allot_array_internal(CELL capacity) template bool reallot_array_in_place_p(T *array, CELL capacity) { - return in_zone(&nursery,(CELL)array) && capacity <= array_capacity(array); + return in_zone(&nursery,array) && capacity <= array_capacity(array); } template T *reallot_array(T *array_, CELL capacity) diff --git a/vm/image.cpp b/vm/image.cpp index b6c12fafc7..d0571bb241 100755 --- a/vm/image.cpp +++ b/vm/image.cpp @@ -1,7 +1,7 @@ #include "master.hpp" /* Certain special objects in the image are known to the runtime */ -static void init_objects(F_HEADER *h) +static void init_objects(F_IMAGE_HEADER *h) { memcpy(userenv,h->userenv,sizeof(userenv)); @@ -13,7 +13,7 @@ static void init_objects(F_HEADER *h) CELL data_relocation_base; -static void load_data_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p) +static void load_data_heap(FILE *file, F_IMAGE_HEADER *h, F_PARAMETERS *p) { CELL good_size = h->data_size + (1 << 20); @@ -48,7 +48,7 @@ static void load_data_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p) CELL code_relocation_base; -static void load_code_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p) +static void load_code_heap(FILE *file, F_IMAGE_HEADER *h, F_PARAMETERS *p) { CELL good_size = h->code_size + (1 << 19); @@ -79,7 +79,7 @@ static void load_code_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p) bool save_image(const F_CHAR *filename) { FILE* file; - F_HEADER h; + F_IMAGE_HEADER h; file = OPEN_WRITE(filename); if(file == NULL) @@ -114,7 +114,7 @@ bool save_image(const F_CHAR *filename) bool ok = true; - if(fwrite(&h,sizeof(F_HEADER),1,file) != 1) ok = false; + if(fwrite(&h,sizeof(F_IMAGE_HEADER),1,file) != 1) ok = false; if(fwrite((void*)tenured->start,h.data_size,1,file) != 1) ok = false; if(fwrite(first_block(&code_heap),h.code_size,1,file) != 1) ok = false; if(fclose(file)) ok = false; @@ -127,7 +127,7 @@ bool save_image(const F_CHAR *filename) return ok; } -void primitive_save_image(void) +PRIMITIVE(save_image) { /* do a full GC to push everything into tenured space */ gc(); @@ -137,7 +137,7 @@ void primitive_save_image(void) save_image((F_CHAR *)(path.untagged() + 1)); } -void primitive_save_image_and_exit(void) +PRIMITIVE(save_image_and_exit) { /* We unbox this before doing anything else. This is the only point where we might throw an error, so we have to throw an error here since @@ -174,19 +174,20 @@ static void data_fixup(CELL *cell) *cell += (tenured->start - data_relocation_base); } -static void code_fixup(CELL cell) +template void code_fixup(T **cell) { - CELL value = get(cell); - put(cell,value + (code_heap.segment->start - code_relocation_base)); + T *ptr = *cell; + T *new_ptr = (T *)(((CELL)ptr) + (code_heap.segment->start - code_relocation_base)); + *cell = new_ptr; } static void fixup_word(F_WORD *word) { if(word->code) - code_fixup((CELL)&word->code); + code_fixup(&word->code); if(word->profiling) - code_fixup((CELL)&word->profiling); - code_fixup((CELL)&word->xt); + code_fixup(&word->profiling); + code_fixup(&word->xt); } static void fixup_quotation(F_QUOTATION *quot) @@ -195,8 +196,8 @@ static void fixup_quotation(F_QUOTATION *quot) quot->xt = (void *)lazy_jit_compile; else { - code_fixup((CELL)"->xt); - code_fixup((CELL)"->code); + code_fixup("->xt); + code_fixup("->code); } } @@ -207,8 +208,8 @@ static void fixup_alien(F_ALIEN *d) static void fixup_stack_frame(F_STACK_FRAME *frame) { - code_fixup((CELL)&frame->xt); - code_fixup((CELL)&FRAME_RETURN_ADDRESS(frame)); + code_fixup(&frame->xt); + code_fixup(&FRAME_RETURN_ADDRESS(frame)); } static void fixup_callstack_object(F_CALLSTACK *stack) @@ -217,45 +218,44 @@ static void fixup_callstack_object(F_CALLSTACK *stack) } /* Initialize an object in a newly-loaded image */ -static void relocate_object(CELL relocating) +static void relocate_object(F_OBJECT *object) { + CELL hi_tag = object->header.hi_tag(); + /* Tuple relocation is a bit trickier; we have to fix up the - fixup object before we can get the tuple size, so do_slots is + layout object before we can get the tuple size, so do_slots is out of the question */ - if(untag_header(get(relocating)) == TUPLE_TYPE) + if(hi_tag == TUPLE_TYPE) { - data_fixup((CELL *)relocating + 1); + F_TUPLE *tuple = (F_TUPLE *)object; + data_fixup(&tuple->layout); - CELL scan = relocating + 2 * CELLS; - CELL size = untagged_object_size(relocating); - CELL end = relocating + size; + CELL *scan = (CELL *)(tuple + 1); + CELL *end = (CELL *)((CELL)object + untagged_object_size(object)); - while(scan < end) - { - data_fixup((CELL *)scan); - scan += CELLS; - } + for(; scan < end; scan++) + data_fixup(scan); } else { - do_slots(relocating,data_fixup); + do_slots((CELL)object,data_fixup); - switch(untag_header(get(relocating))) + switch(hi_tag) { case WORD_TYPE: - fixup_word((F_WORD *)relocating); + fixup_word((F_WORD *)object); break; case QUOTATION_TYPE: - fixup_quotation((F_QUOTATION *)relocating); + fixup_quotation((F_QUOTATION *)object); break; case DLL_TYPE: - ffi_dlopen((F_DLL *)relocating); + ffi_dlopen((F_DLL *)object); break; case ALIEN_TYPE: - fixup_alien((F_ALIEN *)relocating); + fixup_alien((F_ALIEN *)object); break; case CALLSTACK_TYPE: - fixup_callstack_object((F_CALLSTACK *)relocating); + fixup_callstack_object((F_CALLSTACK *)object); break; } } @@ -280,10 +280,11 @@ void relocate_data() for(relocating = tenured->start; relocating < tenured->here; - relocating += untagged_object_size(relocating)) + relocating += untagged_object_size((F_OBJECT *)relocating)) { - allot_barrier(relocating); - relocate_object(relocating); + F_OBJECT *object = (F_OBJECT *)relocating; + allot_barrier(object); + relocate_object(object); } } @@ -313,8 +314,8 @@ void load_image(F_PARAMETERS *p) exit(1); } - F_HEADER h; - if(fread(&h,sizeof(F_HEADER),1,file) != 1) + F_IMAGE_HEADER h; + if(fread(&h,sizeof(F_IMAGE_HEADER),1,file) != 1) fatal_error("Cannot read image header",0); if(h.magic != IMAGE_MAGIC) diff --git a/vm/image.hpp b/vm/image.hpp index f3041dc45b..68545d1162 100755 --- a/vm/image.hpp +++ b/vm/image.hpp @@ -1,7 +1,7 @@ #define IMAGE_MAGIC 0x0f0e0d0c #define IMAGE_VERSION 4 -struct F_HEADER { +struct F_IMAGE_HEADER { CELL magic; CELL version; /* all pointers in the image file are relocated from @@ -41,5 +41,5 @@ struct F_PARAMETERS { void load_image(F_PARAMETERS *p); bool save_image(const F_CHAR *file); -void primitive_save_image(void); -void primitive_save_image_and_exit(void); +PRIMITIVE(save_image); +PRIMITIVE(save_image_and_exit); diff --git a/vm/inline_cache.cpp b/vm/inline_cache.cpp index fa672fd058..5c02c419dd 100644 --- a/vm/inline_cache.cpp +++ b/vm/inline_cache.cpp @@ -41,13 +41,12 @@ static CELL determine_inline_cache_type(F_ARRAY *cache_entries) for(i = 0; i < array_capacity(cache_entries); i += 2) { CELL klass = array_nth(cache_entries,i); - F_FIXNUM type; /* Is it a tuple layout? */ - switch(type_of(klass)) + switch(TAG(klass)) { case FIXNUM_TYPE: - type = untag_fixnum(klass); + F_FIXNUM type = untag_fixnum(klass); if(type >= HEADER_TYPE) seen_hi_tag = true; break; @@ -199,7 +198,7 @@ XT inline_cache_miss(CELL return_address) F_FIXNUM index = untag_fixnum(dpop()); gc_root methods(dpop()); gc_root generic_word(dpop()); - gc_root object(get(ds - index * CELLS)); + gc_root object(((CELL *)ds)[-index]); XT xt; @@ -234,14 +233,14 @@ XT inline_cache_miss(CELL return_address) return xt; } -void primitive_reset_inline_cache_stats(void) +PRIMITIVE(reset_inline_cache_stats) { cold_call_to_ic_transitions = ic_to_pic_transitions = pic_to_mega_transitions = 0; CELL i; for(i = 0; i < 4; i++) pic_counts[i] = 0; } -void primitive_inline_cache_stats(void) +PRIMITIVE(inline_cache_stats) { growable_array stats; stats.add(allot_cell(cold_call_to_ic_transitions)); diff --git a/vm/inline_cache.hpp b/vm/inline_cache.hpp index 46f8d5c909..a85879459f 100644 --- a/vm/inline_cache.hpp +++ b/vm/inline_cache.hpp @@ -2,7 +2,8 @@ extern CELL max_pic_size; void init_inline_caching(int max_size); -void primitive_reset_inline_cache_stats(void); -void primitive_inline_cache_stats(void); +PRIMITIVE(reset_inline_cache_stats); +PRIMITIVE(inline_cache_stats); +PRIMITIVE(inline_cache_miss); extern "C" XT inline_cache_miss(CELL return_address); diff --git a/vm/io.cpp b/vm/io.cpp index 179619e1bd..43ca5f9064 100755 --- a/vm/io.cpp +++ b/vm/io.cpp @@ -28,7 +28,7 @@ void io_error(void) general_error(ERROR_IO,tag_fixnum(errno),F,NULL); } -void primitive_fopen(void) +PRIMITIVE(fopen) { gc_root mode(dpop()); gc_root path(dpop()); @@ -49,7 +49,7 @@ void primitive_fopen(void) } } -void primitive_fgetc(void) +PRIMITIVE(fgetc) { FILE *file = (FILE *)unbox_alien(); @@ -74,7 +74,7 @@ void primitive_fgetc(void) } } -void primitive_fread(void) +PRIMITIVE(fread) { FILE *file = (FILE *)unbox_alien(); F_FIXNUM size = unbox_array_size(); @@ -114,7 +114,7 @@ void primitive_fread(void) } } -void primitive_fputc(void) +PRIMITIVE(fputc) { FILE *file = (FILE *)unbox_alien(); F_FIXNUM ch = to_fixnum(dpop()); @@ -132,7 +132,7 @@ void primitive_fputc(void) } } -void primitive_fwrite(void) +PRIMITIVE(fwrite) { FILE *file = (FILE *)unbox_alien(); F_BYTE_ARRAY *text = untag_check(dpop()); @@ -161,7 +161,7 @@ void primitive_fwrite(void) } } -void primitive_fseek(void) +PRIMITIVE(fseek) { int whence = to_fixnum(dpop()); FILE *file = (FILE *)unbox_alien(); @@ -186,7 +186,7 @@ void primitive_fseek(void) } } -void primitive_fflush(void) +PRIMITIVE(fflush) { FILE *file = (FILE *)unbox_alien(); for(;;) @@ -198,7 +198,7 @@ void primitive_fflush(void) } } -void primitive_fclose(void) +PRIMITIVE(fclose) { FILE *file = (FILE *)unbox_alien(); for(;;) @@ -213,12 +213,12 @@ void primitive_fclose(void) /* This function is used by FFI I/O. Accessing the errno global directly is not portable, since on some libc's errno is not a global but a funky macro that reads thread-local storage. */ -int err_no(void) +VM_C_API int err_no(void) { return errno; } -void clear_err_no(void) +VM_C_API void clear_err_no(void) { errno = 0; } diff --git a/vm/io.hpp b/vm/io.hpp index 63a9c35490..f857302568 100755 --- a/vm/io.hpp +++ b/vm/io.hpp @@ -1,18 +1,19 @@ void init_c_io(void); void io_error(void); -DLLEXPORT int err_no(void); -DLLEXPORT void clear_err_no(void); -void primitive_fopen(void); -void primitive_fgetc(void); -void primitive_fread(void); -void primitive_fputc(void); -void primitive_fwrite(void); -void primitive_fflush(void); -void primitive_fseek(void); -void primitive_fclose(void); +PRIMITIVE(fopen); +PRIMITIVE(fgetc); +PRIMITIVE(fread); +PRIMITIVE(fputc); +PRIMITIVE(fwrite); +PRIMITIVE(fflush); +PRIMITIVE(fseek); +PRIMITIVE(fclose); /* Platform specific primitives */ -void primitive_open_file(void); -void primitive_existsp(void); -void primitive_read_dir(void); +PRIMITIVE(open_file); +PRIMITIVE(existsp); +PRIMITIVE(read_dir); + +VM_C_API int err_no(void); +VM_C_API void clear_err_no(void); diff --git a/vm/layouts.hpp b/vm/layouts.hpp index 80f35d14a5..240cc3da18 100755 --- a/vm/layouts.hpp +++ b/vm/layouts.hpp @@ -1,5 +1,3 @@ -#define INLINE inline static - typedef unsigned char u8; typedef unsigned short u16; typedef unsigned int u32; @@ -19,6 +17,14 @@ typedef signed long long s64; #define CELLS ((signed)sizeof(CELL)) +inline static CELL align(CELL a, CELL b) +{ + return (a + (b-1)) & ~(b-1); +} + +#define align8(a) align(a,8) +#define align_page(a) align(a,getpagesize()) + #define WORD_SIZE (CELLS*8) #define HALF_WORD_SIZE (CELLS*4) #define HALF_WORD_MASK (((unsigned long)1<> TAG_BITS; } -INLINE CELL tag_fixnum(F_FIXNUM untagged) +inline static CELL tag_fixnum(F_FIXNUM untagged) { return RETAG(untagged << TAG_BITS,FIXNUM_TYPE); } +inline static CELL tag_for(CELL type) +{ + return type < HEADER_TYPE ? type : OBJECT_TYPE; +} + typedef void *XT; +class F_OBJECT; + +struct F_HEADER { + CELL header; + + F_HEADER(CELL header_) : header(header_ << TAG_BITS) {} + + void check_header() { +#ifdef FACTOR_DEBUG + assert(TAG(header) == FIXNUM_TYPE && untag_fixnum(header) < TYPE_COUNT); +#endif + } + + CELL hi_tag() { + check_header(); + return header >> TAG_BITS; + } + + void set(CELL header_) { + header = header_ << TAG_BITS; + } + + bool forwarding_pointer_p() { + return TAG(header) == GC_COLLECTED; + } + + F_OBJECT *forwarding_pointer() { + return (F_OBJECT *)UNTAG(header); + } + + void forward_to(F_OBJECT *pointer) { + header = RETAG(pointer,GC_COLLECTED); + } +}; + #define NO_TYPE_CHECK static const CELL type_number = TYPE_COUNT struct F_OBJECT { NO_TYPE_CHECK; - CELL header; + F_HEADER header; + CELL *slots() { return (CELL *)this; } }; /* Assembly code makes assumptions about the layout of this struct */ @@ -96,6 +140,8 @@ struct F_ARRAY : public F_OBJECT { static const CELL element_size = CELLS; /* tagged */ CELL capacity; + + CELL *data() { return (CELL *)(this + 1); } }; /* These are really just arrays, but certain elements have special @@ -115,6 +161,8 @@ struct F_BIGNUM : public F_OBJECT { static const CELL element_size = CELLS; /* tagged */ CELL capacity; + + CELL *data() { return (CELL *)(this + 1); } }; struct F_BYTE_ARRAY : public F_OBJECT { @@ -122,6 +170,8 @@ struct F_BYTE_ARRAY : public F_OBJECT { static const CELL element_size = 1; /* tagged */ CELL capacity; + + template T *data() { return (T *)(this + 1); } }; /* Assembly code makes assumptions about the layout of this struct */ @@ -133,6 +183,8 @@ struct F_STRING : public F_OBJECT { CELL aux; /* tagged */ CELL hashcode; + + u8 *data() { return (u8 *)(this + 1); } }; /* The compiled code heap is structured into blocks. */ @@ -206,14 +258,13 @@ struct F_WRAPPER : public F_OBJECT { }; /* Assembly code makes assumptions about the layout of this struct */ -struct F_FLOAT { -/* We use a union here to force the float value to be aligned on an -8-byte boundary. */ +struct F_FLOAT : F_OBJECT { static const CELL type_number = FLOAT_TYPE; - union { - CELL header; - long long padding; - }; + +#ifndef FACTOR_64 + CELL padding; +#endif + double n; }; @@ -270,4 +321,6 @@ struct F_TUPLE : public F_OBJECT { static const CELL type_number = TUPLE_TYPE; /* tagged layout */ CELL layout; + + CELL *data() { return (CELL *)(this + 1); } }; diff --git a/vm/local_roots.hpp b/vm/local_roots.hpp index 3f57afcdaf..05278b9f2b 100644 --- a/vm/local_roots.hpp +++ b/vm/local_roots.hpp @@ -30,7 +30,12 @@ struct gc_bignum { F_BIGNUM **addr; - gc_bignum(F_BIGNUM **addr_) : addr(addr_) { if(*addr_) check_data_pointer((CELL)*addr_); gc_bignum_push((CELL)addr); } + gc_bignum(F_BIGNUM **addr_) : addr(addr_) { + if(*addr_) + check_data_pointer(*addr_); + gc_bignum_push((CELL)addr); + } + ~gc_bignum() { assert((CELL)addr == gc_bignum_pop()); } }; diff --git a/vm/master.hpp b/vm/master.hpp index 172886c946..039ef9c1f9 100644 --- a/vm/master.hpp +++ b/vm/master.hpp @@ -23,6 +23,9 @@ #include "layouts.hpp" #include "platform.hpp" #include "primitives.hpp" +#include "stacks.hpp" +#include "segments.hpp" +#include "contexts.hpp" #include "run.hpp" #include "tagged.hpp" #include "profiler.hpp" diff --git a/vm/math.cpp b/vm/math.cpp index e3f9354b09..8d6b503512 100644 --- a/vm/math.cpp +++ b/vm/math.cpp @@ -4,62 +4,19 @@ CELL bignum_zero; CELL bignum_pos_one; CELL bignum_neg_one; -/* Fixnums */ -F_FIXNUM to_fixnum(CELL tagged) -{ - switch(TAG(tagged)) - { - case FIXNUM_TYPE: - return untag_fixnum(tagged); - case BIGNUM_TYPE: - return bignum_to_fixnum(untag(tagged)); - default: - type_error(FIXNUM_TYPE,tagged); - return -1; /* can't happen */ - } -} - -CELL to_cell(CELL tagged) -{ - return (CELL)to_fixnum(tagged); -} - -void primitive_bignum_to_fixnum(void) +PRIMITIVE(bignum_to_fixnum) { drepl(tag_fixnum(bignum_to_fixnum(untag(dpeek())))); } -void primitive_float_to_fixnum(void) +PRIMITIVE(float_to_fixnum) { drepl(tag_fixnum(float_to_fixnum(dpeek()))); } -/* The fixnum+, fixnum- and fixnum* primitives are defined in cpu_*.S. On -overflow, they call these functions. */ -F_FASTCALL void overflow_fixnum_add(F_FIXNUM x, F_FIXNUM y) -{ - drepl(tag(fixnum_to_bignum( - untag_fixnum(x) + untag_fixnum(y)))); -} - -F_FASTCALL void overflow_fixnum_subtract(F_FIXNUM x, F_FIXNUM y) -{ - drepl(tag(fixnum_to_bignum( - untag_fixnum(x) - untag_fixnum(y)))); -} - -F_FASTCALL void overflow_fixnum_multiply(F_FIXNUM x, F_FIXNUM y) -{ - F_BIGNUM *bx = fixnum_to_bignum(x); - GC_BIGNUM(bx); - F_BIGNUM *by = fixnum_to_bignum(y); - GC_BIGNUM(by); - drepl(tag(bignum_multiply(bx,by))); -} - /* Division can only overflow when we are dividing the most negative fixnum by -1. */ -void primitive_fixnum_divint(void) +PRIMITIVE(fixnum_divint) { F_FIXNUM y = untag_fixnum(dpop()); \ F_FIXNUM x = untag_fixnum(dpeek()); @@ -70,19 +27,19 @@ void primitive_fixnum_divint(void) drepl(tag_fixnum(result)); } -void primitive_fixnum_divmod(void) +PRIMITIVE(fixnum_divmod) { - CELL y = get(ds); - CELL x = get(ds - CELLS); + CELL y = ((CELL *)ds)[0]; + CELL x = ((CELL *)ds)[-1]; if(y == tag_fixnum(-1) && x == tag_fixnum(FIXNUM_MIN)) { - put(ds - CELLS,allot_integer(-FIXNUM_MIN)); - put(ds,tag_fixnum(0)); + ((CELL *)ds)[-1] = allot_integer(-FIXNUM_MIN); + ((CELL *)ds)[0] = tag_fixnum(0); } else { - put(ds - CELLS,tag_fixnum(untag_fixnum(x) / untag_fixnum(y))); - put(ds,(F_FIXNUM)x % (F_FIXNUM)y); + ((CELL *)ds)[-1] = tag_fixnum(untag_fixnum(x) / untag_fixnum(y)); + ((CELL *)ds)[0] = (F_FIXNUM)x % (F_FIXNUM)y; } } @@ -94,7 +51,7 @@ void primitive_fixnum_divmod(void) #define BRANCHLESS_MAX(x,y) ((x) - (((x) - (y)) & SIGN_MASK((x) - (y)))) #define BRANCHLESS_ABS(x) ((x ^ SIGN_MASK(x)) - SIGN_MASK(x)) -void primitive_fixnum_shift(void) +PRIMITIVE(fixnum_shift) { F_FIXNUM y = untag_fixnum(dpop()); \ F_FIXNUM x = untag_fixnum(dpeek()); @@ -121,13 +78,12 @@ void primitive_fixnum_shift(void) fixnum_to_bignum(x),y))); } -/* Bignums */ -void primitive_fixnum_to_bignum(void) +PRIMITIVE(fixnum_to_bignum) { drepl(tag(fixnum_to_bignum(untag_fixnum(dpeek())))); } -void primitive_float_to_bignum(void) +PRIMITIVE(float_to_bignum) { drepl(tag(float_to_bignum(dpeek()))); } @@ -136,37 +92,37 @@ void primitive_float_to_bignum(void) F_BIGNUM * y = untag(dpop()); \ F_BIGNUM * x = untag(dpop()); -void primitive_bignum_eq(void) +PRIMITIVE(bignum_eq) { POP_BIGNUMS(x,y); box_boolean(bignum_equal_p(x,y)); } -void primitive_bignum_add(void) +PRIMITIVE(bignum_add) { POP_BIGNUMS(x,y); dpush(tag(bignum_add(x,y))); } -void primitive_bignum_subtract(void) +PRIMITIVE(bignum_subtract) { POP_BIGNUMS(x,y); dpush(tag(bignum_subtract(x,y))); } -void primitive_bignum_multiply(void) +PRIMITIVE(bignum_multiply) { POP_BIGNUMS(x,y); dpush(tag(bignum_multiply(x,y))); } -void primitive_bignum_divint(void) +PRIMITIVE(bignum_divint) { POP_BIGNUMS(x,y); dpush(tag(bignum_quotient(x,y))); } -void primitive_bignum_divmod(void) +PRIMITIVE(bignum_divmod) { F_BIGNUM *q, *r; POP_BIGNUMS(x,y); @@ -175,74 +131,74 @@ void primitive_bignum_divmod(void) dpush(tag(r)); } -void primitive_bignum_mod(void) +PRIMITIVE(bignum_mod) { POP_BIGNUMS(x,y); dpush(tag(bignum_remainder(x,y))); } -void primitive_bignum_and(void) +PRIMITIVE(bignum_and) { POP_BIGNUMS(x,y); dpush(tag(bignum_bitwise_and(x,y))); } -void primitive_bignum_or(void) +PRIMITIVE(bignum_or) { POP_BIGNUMS(x,y); dpush(tag(bignum_bitwise_ior(x,y))); } -void primitive_bignum_xor(void) +PRIMITIVE(bignum_xor) { POP_BIGNUMS(x,y); dpush(tag(bignum_bitwise_xor(x,y))); } -void primitive_bignum_shift(void) +PRIMITIVE(bignum_shift) { F_FIXNUM y = untag_fixnum(dpop()); F_BIGNUM* x = untag(dpop()); dpush(tag(bignum_arithmetic_shift(x,y))); } -void primitive_bignum_less(void) +PRIMITIVE(bignum_less) { POP_BIGNUMS(x,y); box_boolean(bignum_compare(x,y) == bignum_comparison_less); } -void primitive_bignum_lesseq(void) +PRIMITIVE(bignum_lesseq) { POP_BIGNUMS(x,y); box_boolean(bignum_compare(x,y) != bignum_comparison_greater); } -void primitive_bignum_greater(void) +PRIMITIVE(bignum_greater) { POP_BIGNUMS(x,y); box_boolean(bignum_compare(x,y) == bignum_comparison_greater); } -void primitive_bignum_greatereq(void) +PRIMITIVE(bignum_greatereq) { POP_BIGNUMS(x,y); box_boolean(bignum_compare(x,y) != bignum_comparison_less); } -void primitive_bignum_not(void) +PRIMITIVE(bignum_not) { drepl(tag(bignum_bitwise_not(untag(dpeek())))); } -void primitive_bignum_bitp(void) +PRIMITIVE(bignum_bitp) { F_FIXNUM bit = to_fixnum(dpop()); F_BIGNUM *x = untag(dpop()); box_boolean(bignum_logbitp(bit,x)); } -void primitive_bignum_log2(void) +PRIMITIVE(bignum_log2) { drepl(tag(bignum_integer_length(untag(dpeek())))); } @@ -253,100 +209,16 @@ unsigned int bignum_producer(unsigned int digit) return *(ptr + digit); } -void primitive_byte_array_to_bignum(void) +PRIMITIVE(byte_array_to_bignum) { CELL n_digits = array_capacity(untag_check(dpeek())); F_BIGNUM * bignum = digit_stream_to_bignum(n_digits,bignum_producer,0x100,0); drepl(tag(bignum)); } -void box_signed_1(s8 n) -{ - dpush(tag_fixnum(n)); -} - -void box_unsigned_1(u8 n) -{ - dpush(tag_fixnum(n)); -} - -void box_signed_2(s16 n) -{ - dpush(tag_fixnum(n)); -} - -void box_unsigned_2(u16 n) -{ - dpush(tag_fixnum(n)); -} - -void box_signed_4(s32 n) -{ - dpush(allot_integer(n)); -} - -void box_unsigned_4(u32 n) -{ - dpush(allot_cell(n)); -} - -void box_signed_cell(F_FIXNUM integer) -{ - dpush(allot_integer(integer)); -} - -void box_unsigned_cell(CELL cell) -{ - dpush(allot_cell(cell)); -} - -void box_signed_8(s64 n) -{ - if(n < FIXNUM_MIN || n > FIXNUM_MAX) - dpush(tag(long_long_to_bignum(n))); - else - dpush(tag_fixnum(n)); -} - -s64 to_signed_8(CELL obj) -{ - switch(type_of(obj)) - { - case FIXNUM_TYPE: - return untag_fixnum(obj); - case BIGNUM_TYPE: - return bignum_to_long_long(untag(obj)); - default: - type_error(BIGNUM_TYPE,obj); - return -1; - } -} - -void box_unsigned_8(u64 n) -{ - if(n > FIXNUM_MAX) - dpush(tag(ulong_long_to_bignum(n))); - else - dpush(tag_fixnum(n)); -} - -u64 to_unsigned_8(CELL obj) -{ - switch(type_of(obj)) - { - case FIXNUM_TYPE: - return untag_fixnum(obj); - case BIGNUM_TYPE: - return bignum_to_ulong_long(untag(obj)); - default: - type_error(BIGNUM_TYPE,obj); - return -1; - } -} - CELL unbox_array_size(void) { - switch(type_of(dpeek())) + switch(tagged(dpeek()).type()) { case FIXNUM_TYPE: { @@ -377,18 +249,17 @@ CELL unbox_array_size(void) return 0; /* can't happen */ } -/* Floats */ -void primitive_fixnum_to_float(void) +PRIMITIVE(fixnum_to_float) { drepl(allot_float(fixnum_to_float(dpeek()))); } -void primitive_bignum_to_float(void) +PRIMITIVE(bignum_to_float) { drepl(allot_float(bignum_to_float(dpeek()))); } -void primitive_str_to_float(void) +PRIMITIVE(str_to_float) { F_BYTE_ARRAY *bytes = untag_check(dpeek()); CELL capacity = array_capacity(bytes); @@ -402,7 +273,7 @@ void primitive_str_to_float(void) drepl(F); } -void primitive_float_to_str(void) +PRIMITIVE(float_to_str) { F_BYTE_ARRAY *array = allot_byte_array(33); snprintf((char *)(array + 1),32,"%.16g",untag_float_check(dpop())); @@ -413,102 +284,228 @@ void primitive_float_to_str(void) double y = untag_float(dpop()); \ double x = untag_float(dpop()); -void primitive_float_eq(void) +PRIMITIVE(float_eq) { POP_FLOATS(x,y); box_boolean(x == y); } -void primitive_float_add(void) +PRIMITIVE(float_add) { POP_FLOATS(x,y); box_double(x + y); } -void primitive_float_subtract(void) +PRIMITIVE(float_subtract) { POP_FLOATS(x,y); box_double(x - y); } -void primitive_float_multiply(void) +PRIMITIVE(float_multiply) { POP_FLOATS(x,y); box_double(x * y); } -void primitive_float_divfloat(void) +PRIMITIVE(float_divfloat) { POP_FLOATS(x,y); box_double(x / y); } -void primitive_float_mod(void) +PRIMITIVE(float_mod) { POP_FLOATS(x,y); box_double(fmod(x,y)); } -void primitive_float_less(void) +PRIMITIVE(float_less) { POP_FLOATS(x,y); box_boolean(x < y); } -void primitive_float_lesseq(void) +PRIMITIVE(float_lesseq) { POP_FLOATS(x,y); box_boolean(x <= y); } -void primitive_float_greater(void) +PRIMITIVE(float_greater) { POP_FLOATS(x,y); box_boolean(x > y); } -void primitive_float_greatereq(void) +PRIMITIVE(float_greatereq) { POP_FLOATS(x,y); box_boolean(x >= y); } -void primitive_float_bits(void) +PRIMITIVE(float_bits) { box_unsigned_4(float_bits(untag_float_check(dpop()))); } -void primitive_bits_float(void) +PRIMITIVE(bits_float) { box_float(bits_float(to_cell(dpop()))); } -void primitive_double_bits(void) +PRIMITIVE(double_bits) { box_unsigned_8(double_bits(untag_float_check(dpop()))); } -void primitive_bits_double(void) +PRIMITIVE(bits_double) { box_double(bits_double(to_unsigned_8(dpop()))); } -float to_float(CELL value) +VM_C_API F_FIXNUM to_fixnum(CELL tagged) { - return untag_float_check(value); + switch(TAG(tagged)) + { + case FIXNUM_TYPE: + return untag_fixnum(tagged); + case BIGNUM_TYPE: + return bignum_to_fixnum(untag(tagged)); + default: + type_error(FIXNUM_TYPE,tagged); + return -1; /* can't happen */ + } } -double to_double(CELL value) +VM_C_API CELL to_cell(CELL tagged) { - return untag_float_check(value); + return (CELL)to_fixnum(tagged); } -void box_float(float flo) +VM_C_API void box_signed_1(s8 n) +{ + dpush(tag_fixnum(n)); +} + +VM_C_API void box_unsigned_1(u8 n) +{ + dpush(tag_fixnum(n)); +} + +VM_C_API void box_signed_2(s16 n) +{ + dpush(tag_fixnum(n)); +} + +VM_C_API void box_unsigned_2(u16 n) +{ + dpush(tag_fixnum(n)); +} + +VM_C_API void box_signed_4(s32 n) +{ + dpush(allot_integer(n)); +} + +VM_C_API void box_unsigned_4(u32 n) +{ + dpush(allot_cell(n)); +} + +VM_C_API void box_signed_cell(F_FIXNUM integer) +{ + dpush(allot_integer(integer)); +} + +VM_C_API void box_unsigned_cell(CELL cell) +{ + dpush(allot_cell(cell)); +} + +VM_C_API void box_signed_8(s64 n) +{ + if(n < FIXNUM_MIN || n > FIXNUM_MAX) + dpush(tag(long_long_to_bignum(n))); + else + dpush(tag_fixnum(n)); +} + +VM_C_API s64 to_signed_8(CELL obj) +{ + switch(tagged(obj).type()) + { + case FIXNUM_TYPE: + return untag_fixnum(obj); + case BIGNUM_TYPE: + return bignum_to_long_long(untag(obj)); + default: + type_error(BIGNUM_TYPE,obj); + return -1; + } +} + +VM_C_API void box_unsigned_8(u64 n) +{ + if(n > FIXNUM_MAX) + dpush(tag(ulong_long_to_bignum(n))); + else + dpush(tag_fixnum(n)); +} + +VM_C_API u64 to_unsigned_8(CELL obj) +{ + switch(tagged(obj).type()) + { + case FIXNUM_TYPE: + return untag_fixnum(obj); + case BIGNUM_TYPE: + return bignum_to_ulong_long(untag(obj)); + default: + type_error(BIGNUM_TYPE,obj); + return -1; + } +} + +VM_C_API void box_float(float flo) { dpush(allot_float(flo)); } -void box_double(double flo) +VM_C_API float to_float(CELL value) +{ + return untag_float_check(value); +} + +VM_C_API void box_double(double flo) { dpush(allot_float(flo)); } + +VM_C_API double to_double(CELL value) +{ + return untag_float_check(value); +} + +/* The fixnum+, fixnum- and fixnum* primitives are defined in cpu_*.S. On +overflow, they call these functions. */ +VM_ASM_API void overflow_fixnum_add(F_FIXNUM x, F_FIXNUM y) +{ + drepl(tag(fixnum_to_bignum( + untag_fixnum(x) + untag_fixnum(y)))); +} + +VM_ASM_API void overflow_fixnum_subtract(F_FIXNUM x, F_FIXNUM y) +{ + drepl(tag(fixnum_to_bignum( + untag_fixnum(x) - untag_fixnum(y)))); +} + +VM_ASM_API void overflow_fixnum_multiply(F_FIXNUM x, F_FIXNUM y) +{ + F_BIGNUM *bx = fixnum_to_bignum(x); + GC_BIGNUM(bx); + F_BIGNUM *by = fixnum_to_bignum(y); + GC_BIGNUM(by); + drepl(tag(bignum_multiply(bx,by))); +} diff --git a/vm/math.hpp b/vm/math.hpp index 2302262c9b..07257c89f0 100644 --- a/vm/math.hpp +++ b/vm/math.hpp @@ -1,49 +1,46 @@ +extern CELL bignum_zero; +extern CELL bignum_pos_one; +extern CELL bignum_neg_one; + #define CELL_MAX (CELL)(-1) #define FIXNUM_MAX (((F_FIXNUM)1 << (WORD_SIZE - TAG_BITS - 1)) - 1) #define FIXNUM_MIN (-((F_FIXNUM)1 << (WORD_SIZE - TAG_BITS - 1))) #define ARRAY_SIZE_MAX ((CELL)1 << (WORD_SIZE - TAG_BITS - 2)) -DLLEXPORT F_FIXNUM to_fixnum(CELL tagged); -DLLEXPORT CELL to_cell(CELL tagged); +PRIMITIVE(fixnum_add); +PRIMITIVE(fixnum_subtract); +PRIMITIVE(fixnum_multiply); -void primitive_bignum_to_fixnum(void); -void primitive_float_to_fixnum(void); +PRIMITIVE(bignum_to_fixnum); +PRIMITIVE(float_to_fixnum); -F_FASTCALL void overflow_fixnum_add(F_FIXNUM x, F_FIXNUM y); -F_FASTCALL void overflow_fixnum_subtract(F_FIXNUM x, F_FIXNUM y); -F_FASTCALL void overflow_fixnum_multiply(F_FIXNUM x, F_FIXNUM y); +PRIMITIVE(fixnum_divint); +PRIMITIVE(fixnum_divmod); +PRIMITIVE(fixnum_shift); -void primitive_fixnum_divint(void); -void primitive_fixnum_divmod(void); -void primitive_fixnum_shift(void); +PRIMITIVE(fixnum_to_bignum); +PRIMITIVE(float_to_bignum); +PRIMITIVE(bignum_eq); +PRIMITIVE(bignum_add); +PRIMITIVE(bignum_subtract); +PRIMITIVE(bignum_multiply); +PRIMITIVE(bignum_divint); +PRIMITIVE(bignum_divmod); +PRIMITIVE(bignum_mod); +PRIMITIVE(bignum_and); +PRIMITIVE(bignum_or); +PRIMITIVE(bignum_xor); +PRIMITIVE(bignum_shift); +PRIMITIVE(bignum_less); +PRIMITIVE(bignum_lesseq); +PRIMITIVE(bignum_greater); +PRIMITIVE(bignum_greatereq); +PRIMITIVE(bignum_not); +PRIMITIVE(bignum_bitp); +PRIMITIVE(bignum_log2); +PRIMITIVE(byte_array_to_bignum); -extern CELL bignum_zero; -extern CELL bignum_pos_one; -extern CELL bignum_neg_one; - -void primitive_fixnum_to_bignum(void); -void primitive_float_to_bignum(void); -void primitive_bignum_eq(void); -void primitive_bignum_add(void); -void primitive_bignum_subtract(void); -void primitive_bignum_multiply(void); -void primitive_bignum_divint(void); -void primitive_bignum_divmod(void); -void primitive_bignum_mod(void); -void primitive_bignum_and(void); -void primitive_bignum_or(void); -void primitive_bignum_xor(void); -void primitive_bignum_shift(void); -void primitive_bignum_less(void); -void primitive_bignum_lesseq(void); -void primitive_bignum_greater(void); -void primitive_bignum_greatereq(void); -void primitive_bignum_not(void); -void primitive_bignum_bitp(void); -void primitive_bignum_log2(void); -void primitive_byte_array_to_bignum(void); - -INLINE CELL allot_integer(F_FIXNUM x) +inline static CELL allot_integer(F_FIXNUM x) { if(x < FIXNUM_MIN || x > FIXNUM_MAX) return tag(fixnum_to_bignum(x)); @@ -51,7 +48,7 @@ INLINE CELL allot_integer(F_FIXNUM x) return tag_fixnum(x); } -INLINE CELL allot_cell(CELL x) +inline static CELL allot_cell(CELL x) { if(x > (CELL)FIXNUM_MAX) return tag(cell_to_bignum(x)); @@ -59,83 +56,89 @@ INLINE CELL allot_cell(CELL x) return tag_fixnum(x); } -/* FFI calls this */ -DLLEXPORT void box_signed_1(s8 n); -DLLEXPORT void box_unsigned_1(u8 n); -DLLEXPORT void box_signed_2(s16 n); -DLLEXPORT void box_unsigned_2(u16 n); -DLLEXPORT void box_signed_4(s32 n); -DLLEXPORT void box_unsigned_4(u32 n); -DLLEXPORT void box_signed_cell(F_FIXNUM integer); -DLLEXPORT void box_unsigned_cell(CELL cell); -DLLEXPORT void box_signed_8(s64 n); -DLLEXPORT s64 to_signed_8(CELL obj); - -DLLEXPORT void box_unsigned_8(u64 n); -DLLEXPORT u64 to_unsigned_8(CELL obj); - CELL unbox_array_size(void); -INLINE double untag_float(CELL tagged) +inline static double untag_float(CELL tagged) { return untag(tagged)->n; } -INLINE double untag_float_check(CELL tagged) +inline static double untag_float_check(CELL tagged) { return untag_check(tagged)->n; } -INLINE CELL allot_float(double n) +inline static CELL allot_float(double n) { F_FLOAT *flo = allot(sizeof(F_FLOAT)); flo->n = n; - return RETAG(flo,FLOAT_TYPE); + return tag(flo); } -INLINE F_FIXNUM float_to_fixnum(CELL tagged) +inline static F_FIXNUM float_to_fixnum(CELL tagged) { return (F_FIXNUM)untag_float(tagged); } -INLINE F_BIGNUM *float_to_bignum(CELL tagged) +inline static F_BIGNUM *float_to_bignum(CELL tagged) { return double_to_bignum(untag_float(tagged)); } -INLINE double fixnum_to_float(CELL tagged) +inline static double fixnum_to_float(CELL tagged) { return (double)untag_fixnum(tagged); } -INLINE double bignum_to_float(CELL tagged) +inline static double bignum_to_float(CELL tagged) { return bignum_to_double(untag(tagged)); } -DLLEXPORT void box_float(float flo); -DLLEXPORT float to_float(CELL value); -DLLEXPORT void box_double(double flo); -DLLEXPORT double to_double(CELL value); +PRIMITIVE(fixnum_to_float); +PRIMITIVE(bignum_to_float); +PRIMITIVE(str_to_float); +PRIMITIVE(float_to_str); +PRIMITIVE(float_to_bits); -void primitive_fixnum_to_float(void); -void primitive_bignum_to_float(void); -void primitive_str_to_float(void); -void primitive_float_to_str(void); -void primitive_float_to_bits(void); +PRIMITIVE(float_eq); +PRIMITIVE(float_add); +PRIMITIVE(float_subtract); +PRIMITIVE(float_multiply); +PRIMITIVE(float_divfloat); +PRIMITIVE(float_mod); +PRIMITIVE(float_less); +PRIMITIVE(float_lesseq); +PRIMITIVE(float_greater); +PRIMITIVE(float_greatereq); -void primitive_float_eq(void); -void primitive_float_add(void); -void primitive_float_subtract(void); -void primitive_float_multiply(void); -void primitive_float_divfloat(void); -void primitive_float_mod(void); -void primitive_float_less(void); -void primitive_float_lesseq(void); -void primitive_float_greater(void); -void primitive_float_greatereq(void); +PRIMITIVE(float_bits); +PRIMITIVE(bits_float); +PRIMITIVE(double_bits); +PRIMITIVE(bits_double); -void primitive_float_bits(void); -void primitive_bits_float(void); -void primitive_double_bits(void); -void primitive_bits_double(void); +VM_C_API void box_float(float flo); +VM_C_API float to_float(CELL value); +VM_C_API void box_double(double flo); +VM_C_API double to_double(CELL value); + +VM_C_API void box_signed_1(s8 n); +VM_C_API void box_unsigned_1(u8 n); +VM_C_API void box_signed_2(s16 n); +VM_C_API void box_unsigned_2(u16 n); +VM_C_API void box_signed_4(s32 n); +VM_C_API void box_unsigned_4(u32 n); +VM_C_API void box_signed_cell(F_FIXNUM integer); +VM_C_API void box_unsigned_cell(CELL cell); +VM_C_API void box_signed_8(s64 n); +VM_C_API void box_unsigned_8(u64 n); + +VM_C_API s64 to_signed_8(CELL obj); +VM_C_API u64 to_unsigned_8(CELL obj); + +VM_C_API F_FIXNUM to_fixnum(CELL tagged); +VM_C_API CELL to_cell(CELL tagged); + +VM_ASM_API void overflow_fixnum_add(F_FIXNUM x, F_FIXNUM y); +VM_ASM_API void overflow_fixnum_subtract(F_FIXNUM x, F_FIXNUM y); +VM_ASM_API void overflow_fixnum_multiply(F_FIXNUM x, F_FIXNUM y); diff --git a/vm/os-freebsd-x86.32.hpp b/vm/os-freebsd-x86.32.hpp index a04755e9dd..a5a96d84ca 100644 --- a/vm/os-freebsd-x86.32.hpp +++ b/vm/os-freebsd-x86.32.hpp @@ -1,6 +1,6 @@ #include -INLINE void *ucontext_stack_pointer(void *uap) +inline static void *ucontext_stack_pointer(void *uap) { ucontext_t *ucontext = (ucontext_t *)uap; return (void *)ucontext->uc_mcontext.mc_esp; diff --git a/vm/os-freebsd-x86.64.hpp b/vm/os-freebsd-x86.64.hpp index 23e1ff5733..d74278fb19 100644 --- a/vm/os-freebsd-x86.64.hpp +++ b/vm/os-freebsd-x86.64.hpp @@ -1,6 +1,6 @@ #include -INLINE void *ucontext_stack_pointer(void *uap) +inline static void *ucontext_stack_pointer(void *uap) { ucontext_t *ucontext = (ucontext_t *)uap; return (void *)ucontext->uc_mcontext.mc_rsp; diff --git a/vm/os-genunix.hpp b/vm/os-genunix.hpp index 8075e21c5e..72e9a43a1c 100644 --- a/vm/os-genunix.hpp +++ b/vm/os-genunix.hpp @@ -1,4 +1,4 @@ -#define DLLEXPORT extern "C" +#define VM_C_API extern "C" #define NULL_DLL NULL void c_to_factor_toplevel(CELL quot); diff --git a/vm/os-linux-arm.hpp b/vm/os-linux-arm.hpp index 6e078b014d..92900281cd 100644 --- a/vm/os-linux-arm.hpp +++ b/vm/os-linux-arm.hpp @@ -2,7 +2,7 @@ #include #include -INLINE void *ucontext_stack_pointer(void *uap) +inline static void *ucontext_stack_pointer(void *uap) { ucontext_t *ucontext = (ucontext_t *)uap; return (void *)ucontext->uc_mcontext.arm_sp; diff --git a/vm/os-linux-ppc.hpp b/vm/os-linux-ppc.hpp index eb28af53e4..da0333036c 100644 --- a/vm/os-linux-ppc.hpp +++ b/vm/os-linux-ppc.hpp @@ -2,7 +2,7 @@ #define FRAME_RETURN_ADDRESS(frame) *((XT *)(frame_successor(frame) + 1) + 1) -INLINE void *ucontext_stack_pointer(void *uap) +inline static void *ucontext_stack_pointer(void *uap) { ucontext_t *ucontext = (ucontext_t *)uap; return (void *)ucontext->uc_mcontext.uc_regs->gregs[PT_R1]; diff --git a/vm/os-linux-x86.32.hpp b/vm/os-linux-x86.32.hpp index b458fcbe21..2906bf2810 100644 --- a/vm/os-linux-x86.32.hpp +++ b/vm/os-linux-x86.32.hpp @@ -1,6 +1,6 @@ #include -INLINE void *ucontext_stack_pointer(void *uap) +inline static void *ucontext_stack_pointer(void *uap) { ucontext_t *ucontext = (ucontext_t *)uap; return (void *)ucontext->uc_mcontext.gregs[7]; diff --git a/vm/os-linux-x86.64.hpp b/vm/os-linux-x86.64.hpp index 911c2f1749..7c817f3b4d 100644 --- a/vm/os-linux-x86.64.hpp +++ b/vm/os-linux-x86.64.hpp @@ -1,6 +1,6 @@ #include -INLINE void *ucontext_stack_pointer(void *uap) +inline static void *ucontext_stack_pointer(void *uap) { ucontext_t *ucontext = (ucontext_t *)uap; return (void *)ucontext->uc_mcontext.gregs[15]; diff --git a/vm/os-macosx-ppc.hpp b/vm/os-macosx-ppc.hpp index 13213acbbc..07924f854b 100644 --- a/vm/os-macosx-ppc.hpp +++ b/vm/os-macosx-ppc.hpp @@ -33,7 +33,7 @@ Modified for Factor by Slava Pestov */ MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss)) #endif -INLINE CELL fix_stack_pointer(CELL sp) +inline static CELL fix_stack_pointer(CELL sp) { return sp; } diff --git a/vm/os-macosx-x86.32.hpp b/vm/os-macosx-x86.32.hpp index 7c830c775d..1ae7ca65cc 100644 --- a/vm/os-macosx-x86.32.hpp +++ b/vm/os-macosx-x86.32.hpp @@ -31,7 +31,7 @@ Modified for Factor by Slava Pestov */ MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss)) #endif -INLINE CELL fix_stack_pointer(CELL sp) +inline static CELL fix_stack_pointer(CELL sp) { return ((sp + 4) & ~15) - 4; } diff --git a/vm/os-macosx-x86.64.hpp b/vm/os-macosx-x86.64.hpp index b11aa80ce8..ee32c8f21b 100644 --- a/vm/os-macosx-x86.64.hpp +++ b/vm/os-macosx-x86.64.hpp @@ -31,7 +31,7 @@ Modified for Factor by Slava Pestov and Daniel Ehrenberg */ MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss)) #endif -INLINE CELL fix_stack_pointer(CELL sp) +inline static CELL fix_stack_pointer(CELL sp) { return ((sp + 8) & ~15) - 8; } diff --git a/vm/os-macosx.hpp b/vm/os-macosx.hpp index c77d88adfb..10aa515fd2 100644 --- a/vm/os-macosx.hpp +++ b/vm/os-macosx.hpp @@ -1,4 +1,4 @@ -#define DLLEXPORT extern "C" __attribute__((visibility("default"))) +#define VM_C_API extern "C" __attribute__((visibility("default"))) #define FACTOR_OS_STRING "macosx" #define NULL_DLL "libfactor.dylib" @@ -8,10 +8,10 @@ void early_init(void); const char *vm_executable_path(void); const char *default_image_path(void); -DLLEXPORT void c_to_factor_toplevel(CELL quot); - -INLINE void *ucontext_stack_pointer(void *uap) +inline static void *ucontext_stack_pointer(void *uap) { ucontext_t *ucontext = (ucontext_t *)uap; return ucontext->uc_stack.ss_sp; } + +void c_to_factor_toplevel(CELL quot); diff --git a/vm/os-macosx.mm b/vm/os-macosx.mm index e09655ed7c..a47bdda3d1 100644 --- a/vm/os-macosx.mm +++ b/vm/os-macosx.mm @@ -12,7 +12,7 @@ NS_DURING NS_HANDLER dpush(allot_alien(F,(CELL)localException)); quot = userenv[COCOA_EXCEPTION_ENV]; - if(type_of(quot) != QUOTATION_TYPE) + if(!tagged(quot).type_p(QUOTATION_TYPE)) { /* No Cocoa exception handler was registered, so extra/cocoa/ is not loaded. So we pass the exception diff --git a/vm/os-openbsd-x86.32.hpp b/vm/os-openbsd-x86.32.hpp index 0617e62c0d..93d66298aa 100644 --- a/vm/os-openbsd-x86.32.hpp +++ b/vm/os-openbsd-x86.32.hpp @@ -1,6 +1,6 @@ #include -INLINE void *openbsd_stack_pointer(void *uap) +inline static void *openbsd_stack_pointer(void *uap) { struct sigcontext *sc = (struct sigcontext*) uap; return (void *)sc->sc_esp; diff --git a/vm/os-openbsd-x86.64.hpp b/vm/os-openbsd-x86.64.hpp index 3386e80a4b..d318f9e3ab 100644 --- a/vm/os-openbsd-x86.64.hpp +++ b/vm/os-openbsd-x86.64.hpp @@ -1,6 +1,6 @@ #include -INLINE void *openbsd_stack_pointer(void *uap) +inline static void *openbsd_stack_pointer(void *uap) { struct sigcontext *sc = (struct sigcontext*) uap; return (void *)sc->sc_rsp; diff --git a/vm/os-solaris-x86.32.hpp b/vm/os-solaris-x86.32.hpp index 1f4ec74e17..1261f191d1 100644 --- a/vm/os-solaris-x86.32.hpp +++ b/vm/os-solaris-x86.32.hpp @@ -1,6 +1,6 @@ #include -INLINE void *ucontext_stack_pointer(void *uap) +inline static void *ucontext_stack_pointer(void *uap) { ucontext_t *ucontext = (ucontext_t *)uap; return (void *)ucontext->uc_mcontext.gregs[ESP]; diff --git a/vm/os-solaris-x86.64.hpp b/vm/os-solaris-x86.64.hpp index 54d1866d50..4dc3a118d3 100644 --- a/vm/os-solaris-x86.64.hpp +++ b/vm/os-solaris-x86.64.hpp @@ -1,6 +1,6 @@ #include -INLINE void *ucontext_stack_pointer(void *uap) +inline static void *ucontext_stack_pointer(void *uap) { ucontext_t *ucontext = (ucontext_t *)uap; return (void *)ucontext->uc_mcontext.gregs[RSP]; diff --git a/vm/os-unix.cpp b/vm/os-unix.cpp index d8fb09836f..c3d70fa354 100755 --- a/vm/os-unix.cpp +++ b/vm/os-unix.cpp @@ -52,7 +52,7 @@ void ffi_dlclose(F_DLL *dll) dll->dll = NULL; } -void primitive_existsp(void) +PRIMITIVE(existsp) { struct stat sb; char *path = (char *)(untag_check(dpop()) + 1); @@ -98,7 +98,7 @@ void dealloc_segment(F_SEGMENT *block) free(block); } -INLINE F_STACK_FRAME *uap_stack_pointer(void *uap) +static F_STACK_FRAME *uap_stack_pointer(void *uap) { /* There is a race condition here, but in practice a signal delivered during stack frame setup/teardown or while transitioning @@ -301,7 +301,7 @@ void open_console(void) start_thread(stdin_loop); } -DLLEXPORT void wait_for_stdin(void) +VM_C_API void wait_for_stdin(void) { if(write(control_write,"X",1) != 1) { diff --git a/vm/os-windows-ce.cpp b/vm/os-windows-ce.cpp index 85b24a5732..ea8a7bb159 100755 --- a/vm/os-windows-ce.cpp +++ b/vm/os-windows-ce.cpp @@ -27,7 +27,7 @@ char *getenv(char *name) return 0; /* unreachable */ } -void primitive_os_envs(void) +PRIMITIVE(os_envs) { not_implemented_error(); } diff --git a/vm/os-windows.cpp b/vm/os-windows.cpp index 0c1d3b3593..604c718a33 100755 --- a/vm/os-windows.cpp +++ b/vm/os-windows.cpp @@ -88,9 +88,9 @@ const F_CHAR *vm_executable_path(void) } -void primitive_existsp(void) +PRIMITIVE(existsp) { - F_CHAR *path = (F_CHAR *)(untag_byte_array(dpop()) + 1); + F_CHAR *path = (F_CHAR *)(untag_check(dpop()) + 1); box_boolean(windows_stat(path)); } diff --git a/vm/os-windows.hpp b/vm/os-windows.hpp index d1af660603..0b66120764 100755 --- a/vm/os-windows.hpp +++ b/vm/os-windows.hpp @@ -12,7 +12,7 @@ typedef wchar_t F_CHAR; #define STRING_LITERAL(string) L##string #define MAX_UNICODE_PATH 32768 -#define DLLEXPORT extern "C" __declspec(dllexport) +#define VM_C_API extern "C" __declspec(dllexport) #define SSCANF swscanf #define STRCMP wcscmp #define STRNCMP wcsncmp @@ -47,8 +47,8 @@ void ffi_dlclose(F_DLL *dll); void sleep_micros(u64 msec); -INLINE void init_signals(void) {} -INLINE void early_init(void) {} +inline static void init_signals(void) {} +inline static void early_init(void) {} const F_CHAR *vm_executable_path(void); const F_CHAR *default_image_path(void); long getpagesize (void); diff --git a/vm/primitives.cpp b/vm/primitives.cpp index 43c09e719c..e629bebb3c 100755 --- a/vm/primitives.cpp +++ b/vm/primitives.cpp @@ -1,154 +1,154 @@ #include "master.hpp" -F_PRIMITIVE primitives[] = { - primitive_bignum_to_fixnum, - primitive_float_to_fixnum, - primitive_fixnum_to_bignum, - primitive_float_to_bignum, - primitive_fixnum_to_float, - primitive_bignum_to_float, - primitive_str_to_float, - primitive_float_to_str, - primitive_float_bits, - primitive_double_bits, - primitive_bits_float, - primitive_bits_double, - primitive_fixnum_add, - primitive_fixnum_subtract, - primitive_fixnum_multiply, - primitive_fixnum_divint, - primitive_fixnum_divmod, - primitive_fixnum_shift, - primitive_bignum_eq, - primitive_bignum_add, - primitive_bignum_subtract, - primitive_bignum_multiply, - primitive_bignum_divint, - primitive_bignum_mod, - primitive_bignum_divmod, - primitive_bignum_and, - primitive_bignum_or, - primitive_bignum_xor, - primitive_bignum_not, - primitive_bignum_shift, - primitive_bignum_less, - primitive_bignum_lesseq, - primitive_bignum_greater, - primitive_bignum_greatereq, - primitive_bignum_bitp, - primitive_bignum_log2, - primitive_byte_array_to_bignum, - primitive_float_eq, - primitive_float_add, - primitive_float_subtract, - primitive_float_multiply, - primitive_float_divfloat, - primitive_float_mod, - primitive_float_less, - primitive_float_lesseq, - primitive_float_greater, - primitive_float_greatereq, - primitive_word, - primitive_word_xt, - primitive_getenv, - primitive_setenv, - primitive_existsp, - primitive_gc, - primitive_gc_stats, - primitive_save_image, - primitive_save_image_and_exit, - primitive_datastack, - primitive_retainstack, - primitive_callstack, - primitive_set_datastack, - primitive_set_retainstack, - primitive_set_callstack, - primitive_exit, - primitive_data_room, - primitive_code_room, - primitive_micros, - primitive_modify_code_heap, - primitive_dlopen, - primitive_dlsym, - primitive_dlclose, - primitive_byte_array, - primitive_uninitialized_byte_array, - primitive_displaced_alien, - primitive_alien_signed_cell, - primitive_set_alien_signed_cell, - primitive_alien_unsigned_cell, - primitive_set_alien_unsigned_cell, - primitive_alien_signed_8, - primitive_set_alien_signed_8, - primitive_alien_unsigned_8, - primitive_set_alien_unsigned_8, - primitive_alien_signed_4, - primitive_set_alien_signed_4, - primitive_alien_unsigned_4, - primitive_set_alien_unsigned_4, - primitive_alien_signed_2, - primitive_set_alien_signed_2, - primitive_alien_unsigned_2, - primitive_set_alien_unsigned_2, - primitive_alien_signed_1, - primitive_set_alien_signed_1, - primitive_alien_unsigned_1, - primitive_set_alien_unsigned_1, - primitive_alien_float, - primitive_set_alien_float, - primitive_alien_double, - primitive_set_alien_double, - primitive_alien_cell, - primitive_set_alien_cell, - primitive_alien_address, - primitive_set_slot, - primitive_string_nth, - primitive_set_string_nth_fast, - primitive_set_string_nth_slow, - primitive_resize_array, - primitive_resize_string, - primitive_array, - primitive_begin_scan, - primitive_next_object, - primitive_end_scan, - primitive_size, - primitive_die, - primitive_fopen, - primitive_fgetc, - primitive_fread, - primitive_fputc, - primitive_fwrite, - primitive_fflush, - primitive_fseek, - primitive_fclose, - primitive_wrapper, - primitive_clone, - primitive_string, - primitive_array_to_quotation, - primitive_quotation_xt, - primitive_tuple, - primitive_profiling, - primitive_become, - primitive_sleep, - primitive_tuple_boa, - primitive_callstack_to_array, - primitive_innermost_stack_frame_quot, - primitive_innermost_stack_frame_scan, - primitive_set_innermost_stack_frame_quot, - primitive_call_clear, - primitive_resize_byte_array, - primitive_dll_validp, - primitive_unimplemented, - primitive_clear_gc_stats, - primitive_jit_compile, - primitive_load_locals, - primitive_check_datastack, - primitive_inline_cache_miss, - primitive_mega_cache_miss, - primitive_lookup_method, - primitive_reset_dispatch_stats, - primitive_dispatch_stats, - primitive_reset_inline_cache_stats, - primitive_inline_cache_stats, - primitive_optimized_p, +void *primitives[] = { + (void *)primitive_bignum_to_fixnum, + (void *)primitive_float_to_fixnum, + (void *)primitive_fixnum_to_bignum, + (void *)primitive_float_to_bignum, + (void *)primitive_fixnum_to_float, + (void *)primitive_bignum_to_float, + (void *)primitive_str_to_float, + (void *)primitive_float_to_str, + (void *)primitive_float_bits, + (void *)primitive_double_bits, + (void *)primitive_bits_float, + (void *)primitive_bits_double, + (void *)primitive_fixnum_add, + (void *)primitive_fixnum_subtract, + (void *)primitive_fixnum_multiply, + (void *)primitive_fixnum_divint, + (void *)primitive_fixnum_divmod, + (void *)primitive_fixnum_shift, + (void *)primitive_bignum_eq, + (void *)primitive_bignum_add, + (void *)primitive_bignum_subtract, + (void *)primitive_bignum_multiply, + (void *)primitive_bignum_divint, + (void *)primitive_bignum_mod, + (void *)primitive_bignum_divmod, + (void *)primitive_bignum_and, + (void *)primitive_bignum_or, + (void *)primitive_bignum_xor, + (void *)primitive_bignum_not, + (void *)primitive_bignum_shift, + (void *)primitive_bignum_less, + (void *)primitive_bignum_lesseq, + (void *)primitive_bignum_greater, + (void *)primitive_bignum_greatereq, + (void *)primitive_bignum_bitp, + (void *)primitive_bignum_log2, + (void *)primitive_byte_array_to_bignum, + (void *)primitive_float_eq, + (void *)primitive_float_add, + (void *)primitive_float_subtract, + (void *)primitive_float_multiply, + (void *)primitive_float_divfloat, + (void *)primitive_float_mod, + (void *)primitive_float_less, + (void *)primitive_float_lesseq, + (void *)primitive_float_greater, + (void *)primitive_float_greatereq, + (void *)primitive_word, + (void *)primitive_word_xt, + (void *)primitive_getenv, + (void *)primitive_setenv, + (void *)primitive_existsp, + (void *)primitive_gc, + (void *)primitive_gc_stats, + (void *)primitive_save_image, + (void *)primitive_save_image_and_exit, + (void *)primitive_datastack, + (void *)primitive_retainstack, + (void *)primitive_callstack, + (void *)primitive_set_datastack, + (void *)primitive_set_retainstack, + (void *)primitive_set_callstack, + (void *)primitive_exit, + (void *)primitive_data_room, + (void *)primitive_code_room, + (void *)primitive_micros, + (void *)primitive_modify_code_heap, + (void *)primitive_dlopen, + (void *)primitive_dlsym, + (void *)primitive_dlclose, + (void *)primitive_byte_array, + (void *)primitive_uninitialized_byte_array, + (void *)primitive_displaced_alien, + (void *)primitive_alien_signed_cell, + (void *)primitive_set_alien_signed_cell, + (void *)primitive_alien_unsigned_cell, + (void *)primitive_set_alien_unsigned_cell, + (void *)primitive_alien_signed_8, + (void *)primitive_set_alien_signed_8, + (void *)primitive_alien_unsigned_8, + (void *)primitive_set_alien_unsigned_8, + (void *)primitive_alien_signed_4, + (void *)primitive_set_alien_signed_4, + (void *)primitive_alien_unsigned_4, + (void *)primitive_set_alien_unsigned_4, + (void *)primitive_alien_signed_2, + (void *)primitive_set_alien_signed_2, + (void *)primitive_alien_unsigned_2, + (void *)primitive_set_alien_unsigned_2, + (void *)primitive_alien_signed_1, + (void *)primitive_set_alien_signed_1, + (void *)primitive_alien_unsigned_1, + (void *)primitive_set_alien_unsigned_1, + (void *)primitive_alien_float, + (void *)primitive_set_alien_float, + (void *)primitive_alien_double, + (void *)primitive_set_alien_double, + (void *)primitive_alien_cell, + (void *)primitive_set_alien_cell, + (void *)primitive_alien_address, + (void *)primitive_set_slot, + (void *)primitive_string_nth, + (void *)primitive_set_string_nth_fast, + (void *)primitive_set_string_nth_slow, + (void *)primitive_resize_array, + (void *)primitive_resize_string, + (void *)primitive_array, + (void *)primitive_begin_scan, + (void *)primitive_next_object, + (void *)primitive_end_scan, + (void *)primitive_size, + (void *)primitive_die, + (void *)primitive_fopen, + (void *)primitive_fgetc, + (void *)primitive_fread, + (void *)primitive_fputc, + (void *)primitive_fwrite, + (void *)primitive_fflush, + (void *)primitive_fseek, + (void *)primitive_fclose, + (void *)primitive_wrapper, + (void *)primitive_clone, + (void *)primitive_string, + (void *)primitive_array_to_quotation, + (void *)primitive_quotation_xt, + (void *)primitive_tuple, + (void *)primitive_profiling, + (void *)primitive_become, + (void *)primitive_sleep, + (void *)primitive_tuple_boa, + (void *)primitive_callstack_to_array, + (void *)primitive_innermost_stack_frame_quot, + (void *)primitive_innermost_stack_frame_scan, + (void *)primitive_set_innermost_stack_frame_quot, + (void *)primitive_call_clear, + (void *)primitive_resize_byte_array, + (void *)primitive_dll_validp, + (void *)primitive_unimplemented, + (void *)primitive_clear_gc_stats, + (void *)primitive_jit_compile, + (void *)primitive_load_locals, + (void *)primitive_check_datastack, + (void *)primitive_inline_cache_miss, + (void *)primitive_mega_cache_miss, + (void *)primitive_lookup_method, + (void *)primitive_reset_dispatch_stats, + (void *)primitive_dispatch_stats, + (void *)primitive_reset_inline_cache_stats, + (void *)primitive_inline_cache_stats, + (void *)primitive_optimized_p, }; diff --git a/vm/primitives.hpp b/vm/primitives.hpp index 69157f02c4..68c6f17e9d 100644 --- a/vm/primitives.hpp +++ b/vm/primitives.hpp @@ -1,3 +1,5 @@ -typedef void (*F_PRIMITIVE)(void); +//typedef extern "C" void (*F_PRIMITIVE)(void); -extern F_PRIMITIVE primitives[]; +extern void *primitives[]; + +#define PRIMITIVE(name) extern "C" void primitive_##name() diff --git a/vm/profiler.cpp b/vm/profiler.cpp index 0dea08254b..7790578cb1 100755 --- a/vm/profiler.cpp +++ b/vm/profiler.cpp @@ -46,7 +46,7 @@ static void set_profiling(bool profiling) iterate_code_heap(relocate_code_block); } -void primitive_profiling(void) +PRIMITIVE(profiling) { set_profiling(to_boolean(dpop())); } diff --git a/vm/profiler.hpp b/vm/profiler.hpp index 01ecc83bd2..fc31ef4002 100755 --- a/vm/profiler.hpp +++ b/vm/profiler.hpp @@ -1,4 +1,4 @@ extern bool profiling_p; void init_profiler(void); F_CODE_BLOCK *compile_profiling_stub(CELL word); -void primitive_profiling(void); +PRIMITIVE(profiling); diff --git a/vm/quotations.cpp b/vm/quotations.cpp index 25d48decbb..b9c538f45c 100755 --- a/vm/quotations.cpp +++ b/vm/quotations.cpp @@ -36,45 +36,45 @@ so this results in a big speedup for relatively little effort. */ bool quotation_jit::primitive_call_p(CELL i) { return (i + 2) == array_capacity(array.untagged()) - && type_of(array_nth(array.untagged(),i)) == FIXNUM_TYPE + && tagged(array_nth(array.untagged(),i)).type_p(FIXNUM_TYPE) && array_nth(array.untagged(),i + 1) == userenv[JIT_PRIMITIVE_WORD]; } bool quotation_jit::fast_if_p(CELL i) { return (i + 3) == array_capacity(array.untagged()) - && type_of(array_nth(array.untagged(),i)) == QUOTATION_TYPE - && type_of(array_nth(array.untagged(),i + 1)) == QUOTATION_TYPE + && tagged(array_nth(array.untagged(),i)).type_p(QUOTATION_TYPE) + && tagged(array_nth(array.untagged(),i + 1)).type_p(QUOTATION_TYPE) && array_nth(array.untagged(),i + 2) == userenv[JIT_IF_WORD]; } bool quotation_jit::fast_dip_p(CELL i) { return (i + 2) <= array_capacity(array.untagged()) - && type_of(array_nth(array.untagged(),i)) == QUOTATION_TYPE + && tagged(array_nth(array.untagged(),i)).type_p(QUOTATION_TYPE) && array_nth(array.untagged(),i + 1) == userenv[JIT_DIP_WORD]; } bool quotation_jit::fast_2dip_p(CELL i) { return (i + 2) <= array_capacity(array.untagged()) - && type_of(array_nth(array.untagged(),i)) == QUOTATION_TYPE + && tagged(array_nth(array.untagged(),i)).type_p(QUOTATION_TYPE) && array_nth(array.untagged(),i + 1) == userenv[JIT_2DIP_WORD]; } bool quotation_jit::fast_3dip_p(CELL i) { return (i + 2) <= array_capacity(array.untagged()) - && type_of(array_nth(array.untagged(),i)) == QUOTATION_TYPE + && tagged(array_nth(array.untagged(),i)).type_p(QUOTATION_TYPE) && array_nth(array.untagged(),i + 1) == userenv[JIT_3DIP_WORD]; } bool quotation_jit::mega_lookup_p(CELL i) { return (i + 3) < array_capacity(array.untagged()) - && type_of(array_nth(array.untagged(),i)) == ARRAY_TYPE - && type_of(array_nth(array.untagged(),i + 1)) == FIXNUM_TYPE - && type_of(array_nth(array.untagged(),i + 2)) == ARRAY_TYPE + && tagged(array_nth(array.untagged(),i)).type_p(ARRAY_TYPE) + && tagged(array_nth(array.untagged(),i + 1)).type_p(FIXNUM_TYPE) + && tagged(array_nth(array.untagged(),i + 2)).type_p(ARRAY_TYPE) && array_nth(array.untagged(),i + 3) == userenv[MEGA_LOOKUP_WORD]; } @@ -86,15 +86,18 @@ bool quotation_jit::stack_frame_p() for(i = 0; i < length - 1; i++) { CELL obj = array_nth(array.untagged(),i); - if(type_of(obj) == WORD_TYPE) + switch(tagged(obj).type()) { + case WORD_TYPE: if(untag(obj)->subprimitive == F) return true; - } - else if(type_of(obj) == QUOTATION_TYPE) - { + break; + case QUOTATION_TYPE: if(fast_dip_p(i) || fast_2dip_p(i) || fast_3dip_p(i)) return true; + break; + default: + break; } } @@ -268,21 +271,13 @@ void jit_compile(CELL quot_, bool relocating) if(relocating) relocate_code_block(compiled); } -F_FASTCALL CELL lazy_jit_compile_impl(CELL quot_, F_STACK_FRAME *stack) -{ - gc_root quot(quot_); - stack_chain->callstack_top = stack; - jit_compile(quot.value(),true); - return quot.value(); -} - -void primitive_jit_compile(void) +PRIMITIVE(jit_compile) { jit_compile(dpop(),true); } /* push a new quotation on the stack */ -void primitive_array_to_quotation(void) +PRIMITIVE(array_to_quotation) { F_QUOTATION *quot = allot(sizeof(F_QUOTATION)); quot->array = dpeek(); @@ -293,7 +288,7 @@ void primitive_array_to_quotation(void) drepl(tag(quot)); } -void primitive_quotation_xt(void) +PRIMITIVE(quotation_xt) { F_QUOTATION *quot = untag_check(dpeek()); drepl(allot_cell((CELL)quot->xt)); @@ -331,3 +326,11 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot_, CELL offset) return jit.get_position(); } + +VM_ASM_API CELL lazy_jit_compile_impl(CELL quot_, F_STACK_FRAME *stack) +{ + gc_root quot(quot_); + stack_chain->callstack_top = stack; + jit_compile(quot.value(),true); + return quot.value(); +} diff --git a/vm/quotations.hpp b/vm/quotations.hpp index 5cdea06031..92f49732d5 100755 --- a/vm/quotations.hpp +++ b/vm/quotations.hpp @@ -23,12 +23,11 @@ void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code); void jit_compile(CELL quot, bool relocate); F_FIXNUM quot_code_offset_to_scan(CELL quot, CELL offset); -void primitive_jit_compile(void); - -F_FASTCALL CELL lazy_jit_compile_impl(CELL quot, F_STACK_FRAME *stack); +PRIMITIVE(jit_compile); void compile_all_words(void); -void primitive_array_to_quotation(void); -void primitive_quotation_xt(void); +PRIMITIVE(array_to_quotation); +PRIMITIVE(quotation_xt); +VM_ASM_API CELL lazy_jit_compile_impl(CELL quot, F_STACK_FRAME *stack); diff --git a/vm/run.cpp b/vm/run.cpp index e880255dc5..c979ca1750 100755 --- a/vm/run.cpp +++ b/vm/run.cpp @@ -2,228 +2,46 @@ CELL userenv[USER_ENV]; CELL T; -F_CONTEXT *stack_chain; -CELL ds_size, rs_size; -F_CONTEXT *unused_contexts; -void reset_datastack(void) -{ - ds = ds_bot - CELLS; -} - -void reset_retainstack(void) -{ - rs = rs_bot - CELLS; -} - -#define RESERVED (64 * CELLS) - -void fix_stacks(void) -{ - if(ds + CELLS < ds_bot || ds + RESERVED >= ds_top) reset_datastack(); - if(rs + CELLS < rs_bot || rs + RESERVED >= rs_top) reset_retainstack(); -} - -/* called before entry into foreign C code. Note that ds and rs might -be stored in registers, so callbacks must save and restore the correct values */ -void save_stacks(void) -{ - if(stack_chain) - { - stack_chain->datastack = ds; - stack_chain->retainstack = rs; - } -} - -F_CONTEXT *alloc_context(void) -{ - F_CONTEXT *context; - - if(unused_contexts) - { - context = unused_contexts; - unused_contexts = unused_contexts->next; - } - else - { - context = (F_CONTEXT *)safe_malloc(sizeof(F_CONTEXT)); - context->datastack_region = alloc_segment(ds_size); - context->retainstack_region = alloc_segment(rs_size); - } - - return context; -} - -void dealloc_context(F_CONTEXT *context) -{ - context->next = unused_contexts; - unused_contexts = context; -} - -/* called on entry into a compiled callback */ -void nest_stacks(void) -{ - F_CONTEXT *new_stacks = alloc_context(); - - new_stacks->callstack_bottom = (F_STACK_FRAME *)-1; - new_stacks->callstack_top = (F_STACK_FRAME *)-1; - - /* note that these register values are not necessarily valid stack - pointers. they are merely saved non-volatile registers, and are - restored in unnest_stacks(). consider this scenario: - - factor code calls C function - - C function saves ds/cs registers (since they're non-volatile) - - C function clobbers them - - C function calls Factor callback - - Factor callback returns - - C function restores registers - - C function returns to Factor code */ - new_stacks->datastack_save = ds; - new_stacks->retainstack_save = rs; - - /* save per-callback userenv */ - new_stacks->current_callback_save = userenv[CURRENT_CALLBACK_ENV]; - new_stacks->catchstack_save = userenv[CATCHSTACK_ENV]; - - new_stacks->next = stack_chain; - stack_chain = new_stacks; - - reset_datastack(); - reset_retainstack(); -} - -/* called when leaving a compiled callback */ -void unnest_stacks(void) -{ - ds = stack_chain->datastack_save; - rs = stack_chain->retainstack_save; - - /* restore per-callback userenv */ - userenv[CURRENT_CALLBACK_ENV] = stack_chain->current_callback_save; - userenv[CATCHSTACK_ENV] = stack_chain->catchstack_save; - - F_CONTEXT *old_stacks = stack_chain; - stack_chain = old_stacks->next; - dealloc_context(old_stacks); -} - -/* called on startup */ -void init_stacks(CELL ds_size_, CELL rs_size_) -{ - ds_size = ds_size_; - rs_size = rs_size_; - stack_chain = NULL; - unused_contexts = NULL; -} - -bool stack_to_array(CELL bottom, CELL top) -{ - F_FIXNUM depth = (F_FIXNUM)(top - bottom + CELLS); - - if(depth < 0) - return false; - else - { - F_ARRAY *a = allot_array_internal(depth / CELLS); - memcpy(a + 1,(void*)bottom,depth); - dpush(tag(a)); - return true; - } -} - -void primitive_datastack(void) -{ - if(!stack_to_array(ds_bot,ds)) - general_error(ERROR_DS_UNDERFLOW,F,F,NULL); -} - -void primitive_retainstack(void) -{ - if(!stack_to_array(rs_bot,rs)) - general_error(ERROR_RS_UNDERFLOW,F,F,NULL); -} - -/* returns pointer to top of stack */ -CELL array_to_stack(F_ARRAY *array, CELL bottom) -{ - CELL depth = array_capacity(array) * CELLS; - memcpy((void*)bottom,array + 1,depth); - return bottom + depth - CELLS; -} - -void primitive_set_datastack(void) -{ - ds = array_to_stack(untag_check(dpop()),ds_bot); -} - -void primitive_set_retainstack(void) -{ - rs = array_to_stack(untag_check(dpop()),rs_bot); -} - -/* Used to implement call( */ -void primitive_check_datastack(void) -{ - F_FIXNUM out = to_fixnum(dpop()); - F_FIXNUM in = to_fixnum(dpop()); - F_FIXNUM height = out - in; - F_ARRAY *array = untag_check(dpop()); - F_FIXNUM length = array_capacity(array); - F_FIXNUM depth = (ds - ds_bot + CELLS) / CELLS; - if(depth - height != length) - dpush(F); - else - { - F_FIXNUM i; - for(i = 0; i < length - in; i++) - { - if(get(ds_bot + i * CELLS) != array_nth(array,i)) - { - dpush(F); - return; - } - } - dpush(T); - } -} - -void primitive_getenv(void) +PRIMITIVE(getenv) { F_FIXNUM e = untag_fixnum(dpeek()); drepl(userenv[e]); } -void primitive_setenv(void) +PRIMITIVE(setenv) { F_FIXNUM e = untag_fixnum(dpop()); CELL value = dpop(); userenv[e] = value; } -void primitive_exit(void) +PRIMITIVE(exit) { exit(to_fixnum(dpop())); } -void primitive_micros(void) +PRIMITIVE(micros) { box_unsigned_8(current_micros()); } -void primitive_sleep(void) +PRIMITIVE(sleep) { sleep_micros(to_cell(dpop())); } -void primitive_set_slot(void) +PRIMITIVE(set_slot) { F_FIXNUM slot = untag_fixnum(dpop()); - CELL obj = dpop(); + F_OBJECT *object = untag(dpop()); CELL value = dpop(); - set_slot(obj,slot,value); + + object->slots()[slot] = value; + write_barrier(object); } -void primitive_load_locals(void) +PRIMITIVE(load_locals) { F_FIXNUM count = untag_fixnum(dpop()); memcpy((CELL *)(rs + CELLS),(CELL *)(ds - CELLS * (count - 1)),CELLS * count); @@ -235,20 +53,18 @@ static CELL clone_object(CELL object_) { gc_root object(object_); - CELL size = object_size(object.value()); - if(size == 0) + if(immediate_p(object.value())) return object.value(); else { - void *new_obj = allot_object(object.type(),size); - - CELL tag = TAG(object.value()); + CELL size = object_size(object.value()); + F_OBJECT *new_obj = allot_object(object.type(),size); memcpy(new_obj,object.untagged(),size); - return RETAG(new_obj,tag); + return tag_dynamic(new_obj); } } -void primitive_clone(void) +PRIMITIVE(clone) { drepl(clone_object(dpeek())); } diff --git a/vm/run.hpp b/vm/run.hpp index 3fbc0ec9e8..c82c8d678d 100755 --- a/vm/run.hpp +++ b/vm/run.hpp @@ -93,173 +93,14 @@ typedef enum { /* TAGGED user environment data; see getenv/setenv prims */ extern CELL userenv[USER_ENV]; -/* macros for reading/writing memory, useful when working around -C's type system */ -INLINE CELL get(CELL where) -{ - return *((CELL*)where); -} - -INLINE void put(CELL where, CELL what) -{ - *((CELL*)where) = what; -} - -INLINE CELL cget(CELL where) -{ - return *((u16 *)where); -} - -INLINE void cput(CELL where, CELL what) -{ - *((u16 *)where) = what; -} - -INLINE CELL bget(CELL where) -{ - return *((u8 *)where); -} - -INLINE void bput(CELL where, CELL what) -{ - *((u8 *)where) = what; -} - -INLINE CELL align(CELL a, CELL b) -{ - return (a + (b-1)) & ~(b-1); -} - -#define align8(a) align(a,8) -#define align_page(a) align(a,getpagesize()) - /* Canonical T object. It's just a word */ extern CELL T; -INLINE CELL tag_header(CELL cell) -{ - return cell << TAG_BITS; -} - -INLINE void check_header(CELL cell) -{ -#ifdef FACTOR_DEBUG - assert(TAG(cell) == FIXNUM_TYPE && untag_fixnum(cell) < TYPE_COUNT); -#endif -} - -INLINE CELL untag_header(CELL cell) -{ - check_header(cell); - return cell >> TAG_BITS; -} - -INLINE CELL hi_tag(CELL tagged) -{ - return untag_header(get(UNTAG(tagged))); -} - -INLINE CELL type_of(CELL tagged) -{ - CELL tag = TAG(tagged); - if(tag == OBJECT_TYPE) - return hi_tag(tagged); - else - return tag; -} - -#define DEFPUSHPOP(prefix,ptr) \ - INLINE CELL prefix##pop(void) \ - { \ - CELL value = get(ptr); \ - ptr -= CELLS; \ - return value; \ - } \ - INLINE void prefix##push(CELL tagged) \ - { \ - ptr += CELLS; \ - put(ptr,tagged); \ - } \ - INLINE void prefix##repl(CELL tagged) \ - { \ - put(ptr,tagged); \ - } \ - INLINE CELL prefix##peek() \ - { \ - return get(ptr); \ - } - -DEFPUSHPOP(d,ds) -DEFPUSHPOP(r,rs) - -struct F_SEGMENT { - CELL start; - CELL size; - CELL end; -}; - -/* Assembly code makes assumptions about the layout of this struct: - - callstack_top field is 0 - - callstack_bottom field is 1 - - datastack field is 2 - - retainstack field is 3 */ -struct F_CONTEXT { - /* C stack pointer on entry */ - F_STACK_FRAME *callstack_top; - F_STACK_FRAME *callstack_bottom; - - /* current datastack top pointer */ - CELL datastack; - - /* current retain stack top pointer */ - CELL retainstack; - - /* saved contents of ds register on entry to callback */ - CELL datastack_save; - - /* saved contents of rs register on entry to callback */ - CELL retainstack_save; - - /* memory region holding current datastack */ - F_SEGMENT *datastack_region; - - /* memory region holding current retain stack */ - F_SEGMENT *retainstack_region; - - /* saved userenv slots on entry to callback */ - CELL catchstack_save; - CELL current_callback_save; - - F_CONTEXT *next; -}; - -extern F_CONTEXT *stack_chain; - -extern CELL ds_size, rs_size; - -#define ds_bot (stack_chain->datastack_region->start) -#define ds_top (stack_chain->datastack_region->end) -#define rs_bot (stack_chain->retainstack_region->start) -#define rs_top (stack_chain->retainstack_region->end) - -void reset_datastack(void); -void reset_retainstack(void); -void fix_stacks(void); -DLLEXPORT void save_stacks(void); -DLLEXPORT void nest_stacks(void); -DLLEXPORT void unnest_stacks(void); -void init_stacks(CELL ds_size, CELL rs_size); - -void primitive_datastack(void); -void primitive_retainstack(void); -void primitive_set_datastack(void); -void primitive_set_retainstack(void); -void primitive_check_datastack(void); -void primitive_getenv(void); -void primitive_setenv(void); -void primitive_exit(void); -void primitive_micros(void); -void primitive_sleep(void); -void primitive_set_slot(void); -void primitive_load_locals(void); -void primitive_clone(void); +PRIMITIVE(getenv); +PRIMITIVE(setenv); +PRIMITIVE(exit); +PRIMITIVE(micros); +PRIMITIVE(sleep); +PRIMITIVE(set_slot); +PRIMITIVE(load_locals); +PRIMITIVE(clone); diff --git a/vm/segments.hpp b/vm/segments.hpp new file mode 100644 index 0000000000..2a33b35cfd --- /dev/null +++ b/vm/segments.hpp @@ -0,0 +1,5 @@ +struct F_SEGMENT { + CELL start; + CELL size; + CELL end; +}; diff --git a/vm/stacks.hpp b/vm/stacks.hpp new file mode 100644 index 0000000000..f11481b18f --- /dev/null +++ b/vm/stacks.hpp @@ -0,0 +1,14 @@ +#define DEFPUSHPOP(prefix,ptr) \ + inline static CELL prefix##peek() { return *(CELL *)ptr; } \ + inline static void prefix##repl(CELL tagged) { *(CELL *)ptr = tagged; } \ + inline static CELL prefix##pop(void) \ + { \ + CELL value = prefix##peek(); \ + ptr -= CELLS; \ + return value; \ + } \ + inline static void prefix##push(CELL tagged) \ + { \ + ptr += CELLS; \ + prefix##repl(tagged); \ + } diff --git a/vm/strings.cpp b/vm/strings.cpp index fe8059a996..d7f2bc884b 100644 --- a/vm/strings.cpp +++ b/vm/strings.cpp @@ -7,19 +7,21 @@ CELL string_nth(F_STRING* string, CELL index) corresponding aux vector entry is negated, so that we can XOR the two components together and get the original code point back. */ - CELL ch = bget(SREF(string,index)); - if((ch & 0x80) == 0) - return ch; + CELL lo_bits = string->data()[index]; + + if((lo_bits & 0x80) == 0) + return lo_bits; else { F_BYTE_ARRAY *aux = untag(string->aux); - return (cget(BREF(aux,index * sizeof(u16))) << 7) ^ ch; + CELL hi_bits = aux->data()[index]; + return (hi_bits << 7) ^ lo_bits; } } void set_string_nth_fast(F_STRING *string, CELL index, CELL ch) { - bput(SREF(string,index),ch); + string->data()[index] = ch; } void set_string_nth_slow(F_STRING *string_, CELL index, CELL ch) @@ -28,7 +30,7 @@ void set_string_nth_slow(F_STRING *string_, CELL index, CELL ch) F_BYTE_ARRAY *aux; - bput(SREF(string.untagged(),index),(ch & 0x7f) | 0x80); + string->data()[index] = ((ch & 0x7f) | 0x80); if(string->aux == F) { @@ -42,13 +44,13 @@ void set_string_nth_slow(F_STRING *string_, CELL index, CELL ch) untag_fixnum(string->length) * sizeof(u16)); - write_barrier(string.value()); + write_barrier(string.untagged()); string->aux = tag(aux); } else aux = untag(string->aux); - cput(BREF(aux,index * sizeof(u16)),(ch >> 7) ^ 1); + aux->data()[index] = ((ch >> 7) ^ 1); } /* allocates memory */ @@ -78,7 +80,7 @@ void fill_string(F_STRING *string_, CELL start, CELL capacity, CELL fill) gc_root string(string_); if(fill <= 0x7f) - memset((void *)SREF(string.untagged(),start),fill,capacity - start); + memset(&string->data()[start],fill,capacity - start); else { CELL i; @@ -96,7 +98,7 @@ F_STRING *allot_string(CELL capacity, CELL fill) return string.untagged(); } -void primitive_string(void) +PRIMITIVE(string) { CELL initial = to_cell(dpop()); CELL length = unbox_array_size(); @@ -105,7 +107,7 @@ void primitive_string(void) static bool reallot_string_in_place_p(F_STRING *string, CELL capacity) { - return in_zone(&nursery,(CELL)string) && capacity <= string_capacity(string); + return in_zone(&nursery,string) && capacity <= string_capacity(string); } F_STRING* reallot_string(F_STRING *string_, CELL capacity) @@ -132,17 +134,17 @@ F_STRING* reallot_string(F_STRING *string_, CELL capacity) gc_root new_string(allot_string_internal(capacity)); - memcpy(new_string.untagged() + 1,string.untagged() + 1,to_copy); + memcpy(new_string->data(),string->data(),to_copy); if(string->aux != F) { F_BYTE_ARRAY *new_aux = allot_byte_array(capacity * sizeof(u16)); - write_barrier(new_string.value()); + write_barrier(new_string.untagged()); new_string->aux = tag(new_aux); F_BYTE_ARRAY *aux = untag(string->aux); - memcpy(new_aux + 1,aux + 1,to_copy * sizeof(u16)); + memcpy(new_aux->data(),aux->data(),to_copy * sizeof(u16)); } fill_string(new_string.untagged(),to_copy,capacity,'\0'); @@ -150,29 +152,21 @@ F_STRING* reallot_string(F_STRING *string_, CELL capacity) } } -void primitive_resize_string(void) +PRIMITIVE(resize_string) { F_STRING* string = untag_check(dpop()); CELL capacity = unbox_array_size(); dpush(tag(reallot_string(string,capacity))); } -void primitive_string_nth(void) +PRIMITIVE(string_nth) { F_STRING *string = untag(dpop()); CELL index = untag_fixnum(dpop()); dpush(tag_fixnum(string_nth(string,index))); } -void primitive_set_string_nth(void) -{ - F_STRING *string = untag(dpop()); - CELL index = untag_fixnum(dpop()); - CELL value = untag_fixnum(dpop()); - set_string_nth(string,index,value); -} - -void primitive_set_string_nth_fast(void) +PRIMITIVE(set_string_nth_fast) { F_STRING *string = untag(dpop()); CELL index = untag_fixnum(dpop()); @@ -180,7 +174,7 @@ void primitive_set_string_nth_fast(void) set_string_nth_fast(string,index,value); } -void primitive_set_string_nth_slow(void) +PRIMITIVE(set_string_nth_slow) { F_STRING *string = untag(dpop()); CELL index = untag_fixnum(dpop()); diff --git a/vm/strings.hpp b/vm/strings.hpp index c482595b87..f35053e78d 100644 --- a/vm/strings.hpp +++ b/vm/strings.hpp @@ -1,26 +1,23 @@ -INLINE CELL string_capacity(F_STRING *str) +inline static CELL string_capacity(F_STRING *str) { return untag_fixnum(str->length); } -INLINE CELL string_size(CELL size) +inline static CELL string_size(CELL size) { return sizeof(F_STRING) + size; } -#define BREF(byte_array,index) ((CELL)byte_array + sizeof(F_BYTE_ARRAY) + (index)) -#define SREF(string,index) ((CELL)string + sizeof(F_STRING) + (index)) - F_STRING* allot_string_internal(CELL capacity); F_STRING* allot_string(CELL capacity, CELL fill); -void primitive_string(void); +PRIMITIVE(string); F_STRING *reallot_string(F_STRING *string, CELL capacity); -void primitive_resize_string(void); +PRIMITIVE(resize_string); /* String getters and setters */ CELL string_nth(F_STRING* string, CELL index); void set_string_nth(F_STRING* string, CELL index, CELL value); -void primitive_string_nth(void); -void primitive_set_string_nth_slow(void); -void primitive_set_string_nth_fast(void); +PRIMITIVE(string_nth); +PRIMITIVE(set_string_nth_slow); +PRIMITIVE(set_string_nth_fast); diff --git a/vm/tagged.hpp b/vm/tagged.hpp index 9bf9118d7f..fb14e7fa70 100644 --- a/vm/tagged.hpp +++ b/vm/tagged.hpp @@ -1,9 +1,11 @@ template CELL tag(T *value) { - if(T::type_number < HEADER_TYPE) - return RETAG(value,T::type_number); - else - return RETAG(value,OBJECT_TYPE); + return RETAG(value,tag_for(T::type_number)); +} + +inline static CELL tag_dynamic(F_OBJECT *value) +{ + return RETAG(value,tag_for(value->header.hi_tag())); } template @@ -11,12 +13,25 @@ struct tagged { CELL value_; + CELL value() const { return value_; } + T *untagged() const { return (T *)(UNTAG(value_)); } + + CELL type() const { + CELL tag = TAG(value_); + if(tag == OBJECT_TYPE) + return untagged()->header.hi_tag(); + else + return tag; + } + + bool type_p(CELL type_) const { return type() == type_; } + T *untag_check() const { - if(T::type_number != TYPE_COUNT) - type_check(T::type_number,value_); + if(T::type_number != TYPE_COUNT && !type_p(T::type_number)) + type_error(T::type_number,value_); return untagged(); } - + explicit tagged(CELL tagged) : value_(tagged) { #ifdef FACTOR_DEBUG untag_check(); @@ -26,20 +41,17 @@ struct tagged explicit tagged(T *untagged) : value_(::tag(untagged)) { #ifdef FACTOR_DEBUG untag_check(); -#endif +#endif } - CELL value() const { return value_; } - T *untagged() const { return (T *)(UNTAG(value_)); } - T *operator->() const { return untagged(); } CELL *operator&() const { return &value_; } const tagged& operator=(const T *x) { value_ = tag(x); return *this; } const tagged& operator=(const CELL &x) { value_ = x; return *this; } - CELL type() const { return type_of(value_); } - bool isa(CELL type_) const { return type() == type_; } + bool operator==(const tagged &x) { return value_ == x.value_; } + bool operator!=(const tagged &x) { return value_ != x.value_; } template tagged as() { return tagged(value_); } }; diff --git a/vm/tuples.cpp b/vm/tuples.cpp index 8e77bfaee1..ec93cc4adc 100644 --- a/vm/tuples.cpp +++ b/vm/tuples.cpp @@ -9,24 +9,24 @@ F_TUPLE *allot_tuple(CELL layout_) return tuple.untagged(); } -void primitive_tuple(void) +PRIMITIVE(tuple) { gc_root layout(dpop()); F_TUPLE *tuple = allot_tuple(layout.value()); F_FIXNUM i; for(i = tuple_size(layout.untagged()) - 1; i >= 0; i--) - put(AREF(tuple,i),F); + tuple->data()[i] = F; dpush(tag(tuple)); } /* push a new tuple on the stack, filling its slots from the stack */ -void primitive_tuple_boa(void) +PRIMITIVE(tuple_boa) { gc_root layout(dpop()); gc_root tuple(allot_tuple(layout.value())); CELL size = untag_fixnum(layout.untagged()->size) * CELLS; - memcpy(tuple.untagged() + 1,(CELL *)(ds - (size - CELLS)),size); + memcpy(tuple->data(),(CELL *)(ds - (size - CELLS)),size); ds -= size; dpush(tuple.value()); } diff --git a/vm/tuples.hpp b/vm/tuples.hpp index 1d6317a5ab..bcbc268d72 100644 --- a/vm/tuples.hpp +++ b/vm/tuples.hpp @@ -1,20 +1,20 @@ -INLINE CELL tuple_size(F_TUPLE_LAYOUT *layout) +inline static CELL tuple_size(F_TUPLE_LAYOUT *layout) { CELL size = untag_fixnum(layout->size); return sizeof(F_TUPLE) + size * CELLS; } -INLINE CELL tuple_nth(F_TUPLE *tuple, CELL slot) +inline static CELL tuple_nth(F_TUPLE *tuple, CELL slot) { - return get(AREF(tuple,slot)); + return tuple->data()[slot]; } -INLINE void set_tuple_nth(F_TUPLE *tuple, CELL slot, CELL value) +inline static void set_tuple_nth(F_TUPLE *tuple, CELL slot, CELL value) { - put(AREF(tuple,slot),value); - write_barrier((CELL)tuple); + tuple->data()[slot] = value; + write_barrier(tuple); } -void primitive_tuple(void); -void primitive_tuple_boa(void); -void primitive_tuple_layout(void); +PRIMITIVE(tuple); +PRIMITIVE(tuple_boa); +PRIMITIVE(tuple_layout); diff --git a/vm/words.cpp b/vm/words.cpp index fe5fb327a9..17ddc9b747 100644 --- a/vm/words.cpp +++ b/vm/words.cpp @@ -28,7 +28,7 @@ F_WORD *allot_word(CELL vocab_, CELL name_) } /* ( name vocabulary -- word ) */ -void primitive_word(void) +PRIMITIVE(word) { CELL vocab = dpop(); CELL name = dpop(); @@ -36,7 +36,7 @@ void primitive_word(void) } /* word-xt ( word -- start end ) */ -void primitive_word_xt(void) +PRIMITIVE(word_xt) { F_WORD *word = untag_check(dpop()); F_CODE_BLOCK *code = (profiling_p ? word->profiling : word->code); @@ -63,12 +63,12 @@ void update_word_xt(CELL word_) word->xt = (XT)(word->code + 1); } -void primitive_optimized_p(void) +PRIMITIVE(optimized_p) { drepl(tag_boolean(word_optimized_p(untag_check(dpeek())))); } -void primitive_wrapper(void) +PRIMITIVE(wrapper) { F_WRAPPER *wrapper = allot(sizeof(F_WRAPPER)); wrapper->object = dpeek(); diff --git a/vm/words.hpp b/vm/words.hpp index aa29d46bd7..d976dccbdd 100644 --- a/vm/words.hpp +++ b/vm/words.hpp @@ -1,14 +1,14 @@ F_WORD *allot_word(CELL vocab, CELL name); -void primitive_word(void); -void primitive_word_xt(void); +PRIMITIVE(word); +PRIMITIVE(word_xt); void update_word_xt(CELL word); -INLINE bool word_optimized_p(F_WORD *word) +inline bool word_optimized_p(F_WORD *word) { return word->code->block.type == WORD_TYPE; } -void primitive_optimized_p(void); +PRIMITIVE(optimized_p); -void primitive_wrapper(void); +PRIMITIVE(wrapper); diff --git a/vm/write_barrier.hpp b/vm/write_barrier.hpp index fbd5fa8b82..f207547cec 100644 --- a/vm/write_barrier.hpp +++ b/vm/write_barrier.hpp @@ -43,24 +43,16 @@ extern "C" CELL allot_markers_offset; /* the write barrier must be called any time we are potentially storing a pointer from an older generation to a younger one */ -INLINE void write_barrier(CELL address) +inline static void write_barrier(F_OBJECT *address) { *ADDR_TO_CARD(address) = CARD_MARK_MASK; *ADDR_TO_DECK(address) = CARD_MARK_MASK; } -#define SLOT(obj,slot) (UNTAG(obj) + (slot) * CELLS) - -INLINE void set_slot(CELL obj, CELL slot, CELL value) -{ - put(SLOT(obj,slot),value); - write_barrier(obj); -} - /* we need to remember the first object allocated in the card */ -INLINE void allot_barrier(CELL address) +inline static void allot_barrier(F_OBJECT *address) { F_CARD *ptr = ADDR_TO_ALLOT_MARKER(address); if(*ptr == INVALID_ALLOT_MARKER) - *ptr = (address & ADDR_CARD_MASK); + *ptr = ((CELL)address & ADDR_CARD_MASK); } From edecac508e10d4a7ccf294c22319c211cd07264a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 May 2009 01:46:13 -0500 Subject: [PATCH 34/44] Use C++ namespaces --- vm/alien.cpp | 5 +++++ vm/alien.hpp | 5 +++++ vm/arrays.cpp | 5 +++++ vm/arrays.hpp | 5 +++++ vm/bignum.cpp | 5 +++++ vm/bignum.hpp | 5 +++++ vm/bignumint.hpp | 5 +++++ vm/booleans.cpp | 5 +++++ vm/booleans.hpp | 5 +++++ vm/byte_arrays.cpp | 5 +++++ vm/byte_arrays.hpp | 5 +++++ vm/callstack.cpp | 5 +++++ vm/callstack.hpp | 5 +++++ vm/code_block.cpp | 8 ++++++++ vm/code_block.hpp | 5 +++++ vm/code_gc.cpp | 5 +++++ vm/code_gc.hpp | 5 +++++ vm/code_heap.cpp | 5 +++++ vm/code_heap.hpp | 5 +++++ vm/contexts.cpp | 8 +++++++- vm/contexts.hpp | 9 +++++++-- vm/cpu-arm.hpp | 5 +++++ vm/cpu-ppc.hpp | 5 +++++ vm/cpu-x86.32.hpp | 5 +++++ vm/cpu-x86.64.hpp | 5 +++++ vm/cpu-x86.hpp | 5 +++++ vm/data_gc.cpp | 5 +++++ vm/data_gc.hpp | 5 +++++ vm/data_heap.cpp | 9 +++++++-- vm/data_heap.hpp | 10 +++++++--- vm/debug.cpp | 5 +++++ vm/debug.hpp | 5 +++++ vm/dispatch.cpp | 5 +++++ vm/dispatch.hpp | 5 +++++ vm/errors.cpp | 5 +++++ vm/errors.hpp | 5 +++++ vm/factor.cpp | 5 +++++ vm/factor.hpp | 5 +++++ vm/float_bits.hpp | 5 +++++ vm/generic_arrays.hpp | 5 +++++ vm/image.cpp | 5 +++++ vm/image.hpp | 5 +++++ vm/inline_cache.cpp | 5 +++++ vm/inline_cache.hpp | 5 +++++ vm/io.cpp | 5 +++++ vm/io.hpp | 5 +++++ vm/jit.cpp | 5 +++++ vm/jit.hpp | 5 +++++ vm/layouts.hpp | 5 +++++ vm/local_roots.cpp | 5 +++++ vm/local_roots.hpp | 5 +++++ vm/mach_signal.cpp | 7 ++++++- vm/mach_signal.hpp | 5 +++++ vm/main-unix.cpp | 2 +- vm/main-windows-ce.cpp | 2 +- vm/main-windows-nt.cpp | 5 +---- vm/math.cpp | 5 +++++ vm/math.hpp | 5 +++++ vm/os-freebsd-x86.32.hpp | 5 +++++ vm/os-freebsd-x86.64.hpp | 5 +++++ vm/os-freebsd.cpp | 5 +++++ vm/os-freebsd.hpp | 5 ++--- vm/os-genunix.cpp | 5 +++++ vm/os-genunix.hpp | 5 +++++ vm/os-linux-arm.cpp | 5 +++++ vm/os-linux-arm.hpp | 5 +++++ vm/os-linux-ppc.hpp | 5 +++++ vm/os-linux-x86.32.hpp | 5 +++++ vm/os-linux-x86.64.hpp | 5 +++++ vm/os-linux.cpp | 5 +++++ vm/os-linux.hpp | 5 +++++ vm/os-macosx-ppc.hpp | 9 +++++++-- vm/os-macosx-x86.32.hpp | 9 +++++++-- vm/os-macosx-x86.64.hpp | 9 +++++++-- vm/os-macosx.hpp | 5 +++++ vm/os-macosx.mm | 5 +++++ vm/os-netbsd-x86.32.hpp | 5 +++++ vm/os-netbsd-x86.64.hpp | 5 +++++ vm/os-netbsd.cpp | 5 +++++ vm/os-netbsd.hpp | 5 +++++ vm/os-openbsd-x86.32.hpp | 5 +++++ vm/os-openbsd-x86.64.hpp | 5 +++++ vm/os-openbsd.cpp | 5 +++++ vm/os-solaris-x86.32.hpp | 5 +++++ vm/os-solaris-x86.64.hpp | 5 +++++ vm/os-solaris.cpp | 5 +++++ vm/os-unix.cpp | 5 +++++ vm/os-unix.hpp | 7 +++++-- vm/os-windows-ce.cpp | 5 +++++ vm/os-windows-ce.hpp | 5 +++++ vm/os-windows-nt.32.hpp | 5 +++++ vm/os-windows-nt.64.hpp | 5 +++++ vm/os-windows-nt.cpp | 5 +++++ vm/os-windows-nt.hpp | 6 ++++++ vm/os-windows.cpp | 5 +++++ vm/os-windows.hpp | 6 ++++-- vm/primitives.cpp | 5 +++++ vm/primitives.hpp | 5 +++++ vm/profiler.cpp | 5 +++++ vm/profiler.hpp | 5 +++++ vm/quotations.cpp | 5 +++++ vm/quotations.hpp | 5 +++++ vm/run.cpp | 8 +++++++- vm/run.hpp | 11 ++++++++--- vm/segments.hpp | 5 +++++ vm/stacks.hpp | 5 +++++ vm/strings.cpp | 5 +++++ vm/strings.hpp | 5 +++++ vm/tagged.hpp | 7 ++++++- vm/test.cpp | 16 ---------------- vm/tuples.cpp | 5 +++++ vm/tuples.hpp | 5 +++++ vm/utilities.cpp | 5 +++++ vm/utilities.hpp | 5 +++++ vm/words.cpp | 5 +++++ vm/words.hpp | 5 +++++ vm/write_barrier.cpp | 2 ++ vm/write_barrier.hpp | 11 ++++++++--- 118 files changed, 594 insertions(+), 52 deletions(-) delete mode 100644 vm/test.cpp diff --git a/vm/alien.cpp b/vm/alien.cpp index fdfa887a8f..c53890f3b4 100755 --- a/vm/alien.cpp +++ b/vm/alien.cpp @@ -1,5 +1,8 @@ #include "master.hpp" +namespace factor +{ + /* gets the address of an object representing a C pointer, with the intention of storing the pointer across code which may potentially GC. */ char *pinned_alien_offset(CELL object) @@ -222,3 +225,5 @@ VM_C_API void box_medium_struct(CELL x1, CELL x2, CELL x3, CELL x4, CELL size) data[3] = x4; box_value_struct(data,size); } + +} diff --git a/vm/alien.hpp b/vm/alien.hpp index 377a4317bc..18678af0cf 100755 --- a/vm/alien.hpp +++ b/vm/alien.hpp @@ -1,3 +1,6 @@ +namespace factor +{ + CELL allot_alien(CELL delegate, CELL displacement); PRIMITIVE(displaced_alien); @@ -42,3 +45,5 @@ VM_C_API void to_value_struct(CELL src, void *dest, CELL size); VM_C_API void box_value_struct(void *src, CELL size); VM_C_API void box_small_struct(CELL x, CELL y, CELL size); VM_C_API void box_medium_struct(CELL x1, CELL x2, CELL x3, CELL x4, CELL size); + +} diff --git a/vm/arrays.cpp b/vm/arrays.cpp index 3aa725e434..fde0d3b942 100644 --- a/vm/arrays.cpp +++ b/vm/arrays.cpp @@ -1,5 +1,8 @@ #include "master.hpp" +namespace factor +{ + /* make a new array with an initial element */ F_ARRAY *allot_array(CELL capacity, CELL fill_) { @@ -80,3 +83,5 @@ void growable_array::trim() { array = reallot_array(array.untagged(),count); } + +} diff --git a/vm/arrays.hpp b/vm/arrays.hpp index a42bc81833..87432404fb 100644 --- a/vm/arrays.hpp +++ b/vm/arrays.hpp @@ -1,3 +1,6 @@ +namespace factor +{ + inline static CELL array_nth(F_ARRAY *array, CELL slot) { #ifdef FACTOR_DEBUG @@ -36,3 +39,5 @@ struct growable_array { void add(CELL elt); void trim(); }; + +} diff --git a/vm/bignum.cpp b/vm/bignum.cpp index 8cd17f7dc6..f5f9091750 100755 --- a/vm/bignum.cpp +++ b/vm/bignum.cpp @@ -56,6 +56,9 @@ MIT in each case. */ #include #include +namespace factor +{ + /* Exports */ int @@ -1841,3 +1844,5 @@ digit_stream_to_bignum(unsigned int n_digits, } } } + +} diff --git a/vm/bignum.hpp b/vm/bignum.hpp index 208a0e436d..f8058c9497 100644 --- a/vm/bignum.hpp +++ b/vm/bignum.hpp @@ -1,3 +1,6 @@ +namespace factor +{ + /* :tabSize=2:indentSize=2:noTabs=true: Copyright (C) 1989-1992 Massachusetts Institute of Technology @@ -124,3 +127,5 @@ F_BIGNUM * digit_stream_to_bignum(unsigned int n_digits, unsigned int (*producer)(unsigned int), unsigned int radix, int negative_p); + +} diff --git a/vm/bignumint.hpp b/vm/bignumint.hpp index 72430eaa8e..deed0bd910 100644 --- a/vm/bignumint.hpp +++ b/vm/bignumint.hpp @@ -33,6 +33,9 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ +namespace factor +{ + /* Internal Interface to Bignum Code */ #undef BIGNUM_ZERO_P #undef BIGNUM_NEGATIVE_P @@ -98,3 +101,5 @@ typedef F_FIXNUM bignum_length_type; } #endif /* not BIGNUM_DISABLE_ASSERTION_CHECKS */ + +} diff --git a/vm/booleans.cpp b/vm/booleans.cpp index b63a67cd1c..9ff848058f 100644 --- a/vm/booleans.cpp +++ b/vm/booleans.cpp @@ -1,5 +1,8 @@ #include "master.hpp" +namespace factor +{ + VM_C_API void box_boolean(bool value) { dpush(value ? T : F); @@ -9,3 +12,5 @@ VM_C_API bool to_boolean(CELL value) { return value != F; } + +} diff --git a/vm/booleans.hpp b/vm/booleans.hpp index 7634afa02c..f5310de498 100644 --- a/vm/booleans.hpp +++ b/vm/booleans.hpp @@ -1,3 +1,6 @@ +namespace factor +{ + inline static CELL tag_boolean(CELL untagged) { return (untagged ? T : F); @@ -5,3 +8,5 @@ inline static CELL tag_boolean(CELL untagged) VM_C_API void box_boolean(bool value); VM_C_API bool to_boolean(CELL value); + +} diff --git a/vm/byte_arrays.cpp b/vm/byte_arrays.cpp index eaf0eff4b1..18ec087d93 100644 --- a/vm/byte_arrays.cpp +++ b/vm/byte_arrays.cpp @@ -1,5 +1,8 @@ #include "master.hpp" +namespace factor +{ + F_BYTE_ARRAY *allot_byte_array(CELL size) { F_BYTE_ARRAY *array = allot_array_internal(size); @@ -57,3 +60,5 @@ void growable_byte_array::trim() { array = reallot_array(array.untagged(),count); } + +} diff --git a/vm/byte_arrays.hpp b/vm/byte_arrays.hpp index dcc6658976..3dd4138aef 100644 --- a/vm/byte_arrays.hpp +++ b/vm/byte_arrays.hpp @@ -1,3 +1,6 @@ +namespace factor +{ + F_BYTE_ARRAY *allot_byte_array(CELL size); PRIMITIVE(byte_array); @@ -16,3 +19,5 @@ struct growable_byte_array { void trim(); }; + +} diff --git a/vm/callstack.cpp b/vm/callstack.cpp index 3597716dcc..dc0d5a1af1 100755 --- a/vm/callstack.cpp +++ b/vm/callstack.cpp @@ -1,5 +1,8 @@ #include "master.hpp" +namespace factor +{ + static void check_frame(F_STACK_FRAME *frame) { #ifdef FACTOR_DEBUG @@ -223,3 +226,5 @@ VM_ASM_API void save_callstack_bottom(F_STACK_FRAME *callstack_bottom) { stack_chain->callstack_bottom = callstack_bottom; } + +} diff --git a/vm/callstack.hpp b/vm/callstack.hpp index fbdadcc859..922a52bf27 100755 --- a/vm/callstack.hpp +++ b/vm/callstack.hpp @@ -1,3 +1,6 @@ +namespace factor +{ + inline static CELL callstack_size(CELL size) { return sizeof(F_CALLSTACK) + size; @@ -24,3 +27,5 @@ PRIMITIVE(innermost_stack_frame_scan); PRIMITIVE(set_innermost_stack_frame_quot); VM_ASM_API void save_callstack_bottom(F_STACK_FRAME *callstack_bottom); + +} diff --git a/vm/code_block.cpp b/vm/code_block.cpp index 97a2e141da..4b49027ff6 100644 --- a/vm/code_block.cpp +++ b/vm/code_block.cpp @@ -1,5 +1,8 @@ #include "master.hpp" +namespace factor +{ + void flush_icache_for(F_CODE_BLOCK *block) { flush_icache((CELL)block,block->block.size); @@ -321,7 +324,10 @@ void *get_rel_symbol(F_ARRAY *literals, CELL index) if(sym) return sym; else + { + printf("%s\n",name); return (void *)undefined_symbol; + } case ARRAY_TYPE: CELL i; F_ARRAY *names = untag(symbol); @@ -485,3 +491,5 @@ F_CODE_BLOCK *add_code_block( return compiled; } + +} diff --git a/vm/code_block.hpp b/vm/code_block.hpp index 94bf0bddfc..4e33022262 100644 --- a/vm/code_block.hpp +++ b/vm/code_block.hpp @@ -1,3 +1,6 @@ +namespace factor +{ + typedef enum { /* arg is a primitive number */ RT_PRIMITIVE, @@ -85,3 +88,5 @@ inline static bool stack_traces_p(void) } F_CODE_BLOCK *add_code_block(CELL type, CELL code, CELL labels, CELL relocation, CELL literals); + +} diff --git a/vm/code_gc.cpp b/vm/code_gc.cpp index 174622ff17..94c1fe286d 100755 --- a/vm/code_gc.cpp +++ b/vm/code_gc.cpp @@ -1,5 +1,8 @@ #include "master.hpp" +namespace factor +{ + static void clear_free_list(F_HEAP *heap) { memset(&heap->free,0,sizeof(F_HEAP_FREE_LIST)); @@ -334,3 +337,5 @@ void compact_heap(F_HEAP *heap) scan = next; } } + +} diff --git a/vm/code_gc.hpp b/vm/code_gc.hpp index eef3b24629..c0531472de 100755 --- a/vm/code_gc.hpp +++ b/vm/code_gc.hpp @@ -1,3 +1,6 @@ +namespace factor +{ + #define FREE_LIST_COUNT 16 #define BLOCK_SIZE_INCREMENT 32 @@ -43,3 +46,5 @@ inline static F_BLOCK *last_block(F_HEAP *heap) { return (F_BLOCK *)heap->segment->end; } + +} diff --git a/vm/code_heap.cpp b/vm/code_heap.cpp index 00fb56c81a..b4fea25f59 100755 --- a/vm/code_heap.cpp +++ b/vm/code_heap.cpp @@ -1,5 +1,8 @@ #include "master.hpp" +namespace factor +{ + F_HEAP code_heap; /* Allocate a code heap during startup */ @@ -220,3 +223,5 @@ void compact_code_heap(void) the end */ build_free_list(&code_heap,size); } + +} diff --git a/vm/code_heap.hpp b/vm/code_heap.hpp index 6baff94988..57200ba8df 100755 --- a/vm/code_heap.hpp +++ b/vm/code_heap.hpp @@ -1,3 +1,6 @@ +namespace factor +{ + /* compiled code */ extern F_HEAP code_heap; @@ -25,3 +28,5 @@ inline static void check_code_pointer(CELL pointer) assert(pointer >= code_heap.segment->start && pointer < code_heap.segment->end); #endif } + +} diff --git a/vm/contexts.cpp b/vm/contexts.cpp index f800191630..3356e365e3 100644 --- a/vm/contexts.cpp +++ b/vm/contexts.cpp @@ -1,6 +1,10 @@ #include "master.hpp" -F_CONTEXT *stack_chain; +factor::F_CONTEXT *stack_chain; + +namespace factor +{ + CELL ds_size, rs_size; F_CONTEXT *unused_contexts; @@ -184,3 +188,5 @@ PRIMITIVE(check_datastack) dpush(T); } } + +} diff --git a/vm/contexts.hpp b/vm/contexts.hpp index 2c4ba71d37..3bf54e3171 100644 --- a/vm/contexts.hpp +++ b/vm/contexts.hpp @@ -1,3 +1,6 @@ +namespace factor +{ + /* Assembly code makes assumptions about the layout of this struct: - callstack_top field is 0 - callstack_bottom field is 1 @@ -33,8 +36,6 @@ struct F_CONTEXT { F_CONTEXT *next; }; -extern F_CONTEXT *stack_chain; - extern CELL ds_size, rs_size; #define ds_bot (stack_chain->datastack_region->start) @@ -59,3 +60,7 @@ PRIMITIVE(check_datastack); VM_C_API void save_stacks(void); VM_C_API void nest_stacks(void); VM_C_API void unnest_stacks(void); + +} + +VM_C_API factor::F_CONTEXT *stack_chain; diff --git a/vm/cpu-arm.hpp b/vm/cpu-arm.hpp index e6ea0a1158..1438199a02 100755 --- a/vm/cpu-arm.hpp +++ b/vm/cpu-arm.hpp @@ -1,3 +1,6 @@ +namespace factor +{ + #define FACTOR_CPU_STRING "arm" register CELL ds asm("r5"); @@ -11,3 +14,5 @@ void c_to_factor(CELL quot); void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy); void throw_impl(CELL quot, F_STACK_FRAME *rewind); void lazy_jit_compile(CELL quot); + +} diff --git a/vm/cpu-ppc.hpp b/vm/cpu-ppc.hpp index 20dfb9855a..cebb104a81 100755 --- a/vm/cpu-ppc.hpp +++ b/vm/cpu-ppc.hpp @@ -1,3 +1,6 @@ +namespace factor +{ + #define FACTOR_CPU_STRING "ppc" #define VM_ASM_API @@ -10,3 +13,5 @@ void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *me void throw_impl(CELL quot, F_STACK_FRAME *rewind); void lazy_jit_compile(CELL quot); void flush_icache(CELL start, CELL len); + +} diff --git a/vm/cpu-x86.32.hpp b/vm/cpu-x86.32.hpp index 97713d9ba2..0629571aed 100755 --- a/vm/cpu-x86.32.hpp +++ b/vm/cpu-x86.32.hpp @@ -1,6 +1,11 @@ +namespace factor +{ + #define FACTOR_CPU_STRING "x86.32" register CELL ds asm("esi"); register CELL rs asm("edi"); #define VM_ASM_API extern "C" __attribute__ ((regparm (2))) + +} diff --git a/vm/cpu-x86.64.hpp b/vm/cpu-x86.64.hpp index 497c85d998..fdc5158a73 100644 --- a/vm/cpu-x86.64.hpp +++ b/vm/cpu-x86.64.hpp @@ -1,6 +1,11 @@ +namespace factor +{ + #define FACTOR_CPU_STRING "x86.64" register CELL ds asm("r14"); register CELL rs asm("r15"); #define VM_ASM_API extern "C" + +} diff --git a/vm/cpu-x86.hpp b/vm/cpu-x86.hpp index 58a13b5d95..f730d38c2f 100755 --- a/vm/cpu-x86.hpp +++ b/vm/cpu-x86.hpp @@ -1,5 +1,8 @@ #include +namespace factor +{ + #define FRAME_RETURN_ADDRESS(frame) *(XT *)(frame_successor(frame) + 1) inline static void flush_icache(CELL start, CELL len) {} @@ -37,3 +40,5 @@ VM_C_API void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *(*memcpy)(void*,const void*, size_t)); + +} diff --git a/vm/data_gc.cpp b/vm/data_gc.cpp index dd229c7ad2..302859ebfb 100755 --- a/vm/data_gc.cpp +++ b/vm/data_gc.cpp @@ -1,5 +1,8 @@ #include "master.hpp" +namespace factor +{ + /* used during garbage collection only */ F_ZONE *newspace; bool performing_gc; @@ -682,3 +685,5 @@ VM_C_API void minor_gc(void) { garbage_collection(NURSERY,false,0); } + +} diff --git a/vm/data_gc.hpp b/vm/data_gc.hpp index 068429bfdd..1d911b1828 100755 --- a/vm/data_gc.hpp +++ b/vm/data_gc.hpp @@ -1,3 +1,6 @@ +namespace factor +{ + /* statistics */ struct F_GC_STATS { CELL collections; @@ -133,3 +136,5 @@ inline static void check_tagged_pointer(CELL tagged) VM_C_API void minor_gc(void); + +} diff --git a/vm/data_heap.cpp b/vm/data_heap.cpp index 39d58d6796..fe8d887b89 100644 --- a/vm/data_heap.cpp +++ b/vm/data_heap.cpp @@ -1,5 +1,10 @@ #include "master.hpp" +factor::F_ZONE nursery; + +namespace factor +{ + /* Set by the -securegc command line argument */ bool secure_gc; @@ -11,8 +16,6 @@ bool gc_off; F_DATA_HEAP *data_heap; -F_ZONE nursery; - CELL init_zone(F_ZONE *z, CELL size, CELL start) { z->size = size; @@ -375,3 +378,5 @@ CELL find_all_words(void) words.trim(); return words.array.value(); } + +} diff --git a/vm/data_heap.hpp b/vm/data_heap.hpp index d32f53fb2b..5d48dfb009 100644 --- a/vm/data_heap.hpp +++ b/vm/data_heap.hpp @@ -1,3 +1,6 @@ +namespace factor +{ + /* Set by the -securegc command line argument */ extern bool secure_gc; @@ -46,9 +49,6 @@ extern F_DATA_HEAP *data_heap; #define MIN_GEN_COUNT 1 #define MAX_GEN_COUNT 3 -/* new objects are allocated here */ -extern F_ZONE nursery; - inline static bool in_zone(F_ZONE *z, F_OBJECT *pointer) { return (CELL)pointer >= z->start && (CELL)pointer < z->end; @@ -128,3 +128,7 @@ inline static void do_slots(CELL obj, void (* iter)(CELL *)) } } +} + +/* new objects are allocated here */ +VM_C_API factor::F_ZONE nursery; diff --git a/vm/debug.cpp b/vm/debug.cpp index 411570b50d..513b6d550e 100755 --- a/vm/debug.cpp +++ b/vm/debug.cpp @@ -1,5 +1,8 @@ #include "master.hpp" +namespace factor +{ + static bool fep_disabled; static bool full_output; @@ -472,3 +475,5 @@ PRIMITIVE(die) print_string("you have triggered a bug in Factor. Please report.\n"); factorbug(); } + +} diff --git a/vm/debug.hpp b/vm/debug.hpp index 97b0c32d54..008776c6a6 100755 --- a/vm/debug.hpp +++ b/vm/debug.hpp @@ -1,3 +1,6 @@ +namespace factor +{ + void print_obj(CELL obj); void print_nested_obj(CELL obj, F_FIXNUM nesting); void dump_generations(void); @@ -5,3 +8,5 @@ void factorbug(void); void dump_zone(F_ZONE *z); PRIMITIVE(die); + +} diff --git a/vm/dispatch.cpp b/vm/dispatch.cpp index b8c2b85779..e178157446 100644 --- a/vm/dispatch.cpp +++ b/vm/dispatch.cpp @@ -1,5 +1,8 @@ #include "master.hpp" +namespace factor +{ + CELL megamorphic_cache_hits; CELL megamorphic_cache_misses; @@ -205,3 +208,5 @@ void quotation_jit::emit_mega_cache_lookup(CELL methods_, F_FIXNUM index, CELL c emit(userenv[JIT_EPILOG]); emit(userenv[JIT_EXECUTE_JUMP]); } + +} diff --git a/vm/dispatch.hpp b/vm/dispatch.hpp index d86854982f..6b86fabd7f 100644 --- a/vm/dispatch.hpp +++ b/vm/dispatch.hpp @@ -1,3 +1,6 @@ +namespace factor +{ + CELL lookup_method(CELL object, CELL methods); PRIMITIVE(lookup_method); @@ -11,3 +14,5 @@ PRIMITIVE(dispatch_stats); void jit_emit_class_lookup(jit *jit, F_FIXNUM index, CELL type); void jit_emit_mega_cache_lookup(jit *jit, CELL methods, F_FIXNUM index, CELL cache); + +} diff --git a/vm/errors.cpp b/vm/errors.cpp index 8e21a6a13d..45954c5d9f 100755 --- a/vm/errors.cpp +++ b/vm/errors.cpp @@ -1,5 +1,8 @@ #include "master.hpp" +namespace factor +{ + /* Global variables used to pass fault handler state from signal handler to user-space */ CELL signal_number; @@ -147,3 +150,5 @@ void misc_signal_handler_impl(void) { signal_error(signal_number,signal_callstack_top); } + +} diff --git a/vm/errors.hpp b/vm/errors.hpp index da7d1458f3..fae3949a54 100755 --- a/vm/errors.hpp +++ b/vm/errors.hpp @@ -1,3 +1,6 @@ +namespace factor +{ + /* Runtime errors */ typedef enum { @@ -44,3 +47,5 @@ extern F_STACK_FRAME *signal_callstack_top; void memory_signal_handler_impl(void); void misc_signal_handler_impl(void); + +} diff --git a/vm/factor.cpp b/vm/factor.cpp index 1e261a91ba..9c6af72264 100755 --- a/vm/factor.cpp +++ b/vm/factor.cpp @@ -1,5 +1,8 @@ #include "master.hpp" +namespace factor +{ + VM_C_API void default_parameters(F_PARAMETERS *p) { p->image_path = NULL; @@ -209,3 +212,5 @@ VM_C_API void factor_sleep(long us) void (*callback)(long) = (void (*)(long))alien_offset(userenv[SLEEP_CALLBACK_ENV]); callback(us); } + +} diff --git a/vm/factor.hpp b/vm/factor.hpp index 08fa9be6b1..0ae87736d1 100644 --- a/vm/factor.hpp +++ b/vm/factor.hpp @@ -1,3 +1,6 @@ +namespace factor +{ + VM_C_API void default_parameters(F_PARAMETERS *p); VM_C_API void init_parameters_from_args(F_PARAMETERS *p, int argc, F_CHAR **argv); VM_C_API void init_factor(F_PARAMETERS *p); @@ -9,3 +12,5 @@ VM_C_API char *factor_eval_string(char *string); VM_C_API void factor_eval_free(char *result); VM_C_API void factor_yield(void); VM_C_API void factor_sleep(long ms); + +} diff --git a/vm/float_bits.hpp b/vm/float_bits.hpp index d380400640..829fe8d3ca 100644 --- a/vm/float_bits.hpp +++ b/vm/float_bits.hpp @@ -1,3 +1,6 @@ +namespace factor +{ + /* Some functions for converting floating point numbers to binary representations and vice versa */ @@ -38,3 +41,5 @@ inline static float bits_float(u32 y) b.y = y; return b.x; } + +} diff --git a/vm/generic_arrays.hpp b/vm/generic_arrays.hpp index 5774f3b001..6147c0eeed 100644 --- a/vm/generic_arrays.hpp +++ b/vm/generic_arrays.hpp @@ -1,3 +1,6 @@ +namespace factor +{ + template CELL array_capacity(T *array) { #ifdef FACTOR_DEBUG @@ -52,3 +55,5 @@ template T *reallot_array(T *array_, CELL capacity) return new_array; } } + +} diff --git a/vm/image.cpp b/vm/image.cpp index d0571bb241..6e13c5fa36 100755 --- a/vm/image.cpp +++ b/vm/image.cpp @@ -1,5 +1,8 @@ #include "master.hpp" +namespace factor +{ + /* Certain special objects in the image are known to the runtime */ static void init_objects(F_IMAGE_HEADER *h) { @@ -337,3 +340,5 @@ void load_image(F_PARAMETERS *p) /* Store image path name */ userenv[IMAGE_ENV] = allot_alien(F,(CELL)p->image_path); } + +} diff --git a/vm/image.hpp b/vm/image.hpp index 68545d1162..0f7001ad99 100755 --- a/vm/image.hpp +++ b/vm/image.hpp @@ -1,3 +1,6 @@ +namespace factor +{ + #define IMAGE_MAGIC 0x0f0e0d0c #define IMAGE_VERSION 4 @@ -43,3 +46,5 @@ bool save_image(const F_CHAR *file); PRIMITIVE(save_image); PRIMITIVE(save_image_and_exit); + +} diff --git a/vm/inline_cache.cpp b/vm/inline_cache.cpp index 5c02c419dd..15008fafa0 100644 --- a/vm/inline_cache.cpp +++ b/vm/inline_cache.cpp @@ -1,5 +1,8 @@ #include "master.hpp" +namespace factor +{ + CELL max_pic_size; CELL cold_call_to_ic_transitions; @@ -252,3 +255,5 @@ PRIMITIVE(inline_cache_stats) stats.trim(); dpush(stats.array.value()); } + +} diff --git a/vm/inline_cache.hpp b/vm/inline_cache.hpp index a85879459f..d1d4226b15 100644 --- a/vm/inline_cache.hpp +++ b/vm/inline_cache.hpp @@ -1,3 +1,6 @@ +namespace factor +{ + extern CELL max_pic_size; void init_inline_caching(int max_size); @@ -7,3 +10,5 @@ PRIMITIVE(inline_cache_stats); PRIMITIVE(inline_cache_miss); extern "C" XT inline_cache_miss(CELL return_address); + +} diff --git a/vm/io.cpp b/vm/io.cpp index 43ca5f9064..e73735fb85 100755 --- a/vm/io.cpp +++ b/vm/io.cpp @@ -1,5 +1,8 @@ #include "master.hpp" +namespace factor +{ + /* Simple wrappers for ANSI C I/O functions, used for bootstrapping. Note the ugly loop logic in almost every function; we have to handle EINTR @@ -222,3 +225,5 @@ VM_C_API void clear_err_no(void) { errno = 0; } + +} diff --git a/vm/io.hpp b/vm/io.hpp index f857302568..968e96f0b5 100755 --- a/vm/io.hpp +++ b/vm/io.hpp @@ -1,3 +1,6 @@ +namespace factor +{ + void init_c_io(void); void io_error(void); @@ -17,3 +20,5 @@ PRIMITIVE(read_dir); VM_C_API int err_no(void); VM_C_API void clear_err_no(void); + +} diff --git a/vm/jit.cpp b/vm/jit.cpp index fee8c4684b..0174faa351 100644 --- a/vm/jit.cpp +++ b/vm/jit.cpp @@ -1,5 +1,8 @@ #include "master.hpp" +namespace factor +{ + /* Simple code generator used by: - profiler (profiler.cpp), - quotation compiler (quotations.cpp), @@ -112,3 +115,5 @@ F_CODE_BLOCK *jit::code_block() } + +} diff --git a/vm/jit.hpp b/vm/jit.hpp index 07f33ce2e3..ae6c133141 100644 --- a/vm/jit.hpp +++ b/vm/jit.hpp @@ -1,3 +1,6 @@ +namespace factor +{ + struct jit { CELL type; gc_root owner; @@ -57,3 +60,5 @@ struct jit { F_CODE_BLOCK *code_block(); }; + +} diff --git a/vm/layouts.hpp b/vm/layouts.hpp index 240cc3da18..abdd99be21 100755 --- a/vm/layouts.hpp +++ b/vm/layouts.hpp @@ -1,3 +1,6 @@ +namespace factor +{ + typedef unsigned char u8; typedef unsigned short u16; typedef unsigned int u32; @@ -324,3 +327,5 @@ struct F_TUPLE : public F_OBJECT { CELL *data() { return (CELL *)(this + 1); } }; + +} diff --git a/vm/local_roots.cpp b/vm/local_roots.cpp index 05d5602f0e..41bb8191ea 100644 --- a/vm/local_roots.cpp +++ b/vm/local_roots.cpp @@ -1,7 +1,12 @@ #include "master.hpp" +namespace factor +{ + F_SEGMENT *gc_locals_region; CELL gc_locals; F_SEGMENT *gc_bignums_region; CELL gc_bignums; + +} diff --git a/vm/local_roots.hpp b/vm/local_roots.hpp index 05278b9f2b..bd4eed7f67 100644 --- a/vm/local_roots.hpp +++ b/vm/local_roots.hpp @@ -1,3 +1,6 @@ +namespace factor +{ + /* If a runtime function needs to call another function which potentially allocates memory, it must wrap any local variable references to Factor objects in gc_root instances */ @@ -40,3 +43,5 @@ struct gc_bignum }; #define GC_BIGNUM(x) gc_bignum x##__gc_root(&x) + +} diff --git a/vm/mach_signal.cpp b/vm/mach_signal.cpp index 74f2e724ca..901f3de971 100644 --- a/vm/mach_signal.cpp +++ b/vm/mach_signal.cpp @@ -1,5 +1,6 @@ /* Fault handler information. MacOSX version. Copyright (C) 1993-1999, 2002-2003 Bruno Haible + Copyright (C) 2003 Paolo Bonzini Used under BSD license with permission from Paolo Bonzini and Bruno Haible, @@ -11,6 +12,9 @@ Modified for Factor by Slava Pestov */ #include "master.hpp" +namespace factor +{ + /* The exception port on which our thread listens. */ mach_port_t our_exception_port; @@ -164,7 +168,6 @@ mach_exception_thread (void *arg) } } - /* Initialize the Mach exception handler thread. */ void mach_initialize (void) { @@ -201,3 +204,5 @@ void mach_initialize (void) != KERN_SUCCESS) fatal_error("task_set_exception_ports() failed",0); } + +} diff --git a/vm/mach_signal.hpp b/vm/mach_signal.hpp index fdeef7b2a5..5dd344c080 100644 --- a/vm/mach_signal.hpp +++ b/vm/mach_signal.hpp @@ -76,4 +76,9 @@ catch_exception_raise_state_identity (mach_port_t exception_port, thread_state_t out_state, mach_msg_type_number_t *out_state_count); +namespace factor +{ + void mach_initialize (void); + +} diff --git a/vm/main-unix.cpp b/vm/main-unix.cpp index 33fd471d42..bc605e3cfd 100644 --- a/vm/main-unix.cpp +++ b/vm/main-unix.cpp @@ -2,6 +2,6 @@ int main(int argc, char **argv) { - start_standalone_factor(argc,argv); + factor::start_standalone_factor(argc,argv); return 0; } diff --git a/vm/main-windows-ce.cpp b/vm/main-windows-ce.cpp index 61aeb12729..526f3b2c36 100644 --- a/vm/main-windows-ce.cpp +++ b/vm/main-windows-ce.cpp @@ -128,7 +128,7 @@ WinMain( int nCmdShow) { parse_args(&__argc, &__argv, lpCmdLine); - start_standalone_factor(__argc,(LPWSTR*)__argv); + factor::start_standalone_factor(__argc,(LPWSTR*)__argv); // memory leak from malloc, wcsdup return 0; } diff --git a/vm/main-windows-nt.cpp b/vm/main-windows-nt.cpp index 026947c4f0..eaaad0f55b 100755 --- a/vm/main-windows-nt.cpp +++ b/vm/main-windows-nt.cpp @@ -1,6 +1,3 @@ -#include -#include -#include #include "master.hpp" int WINAPI WinMain( @@ -19,7 +16,7 @@ int WINAPI WinMain( return 1; } - start_standalone_factor(nArgs,szArglist); + factor::start_standalone_factor(nArgs,szArglist); LocalFree(szArglist); diff --git a/vm/math.cpp b/vm/math.cpp index 8d6b503512..7a01b1adb4 100644 --- a/vm/math.cpp +++ b/vm/math.cpp @@ -1,5 +1,8 @@ #include "master.hpp" +namespace factor +{ + CELL bignum_zero; CELL bignum_pos_one; CELL bignum_neg_one; @@ -509,3 +512,5 @@ VM_ASM_API void overflow_fixnum_multiply(F_FIXNUM x, F_FIXNUM y) GC_BIGNUM(by); drepl(tag(bignum_multiply(bx,by))); } + +} diff --git a/vm/math.hpp b/vm/math.hpp index 07257c89f0..05624d56e2 100644 --- a/vm/math.hpp +++ b/vm/math.hpp @@ -1,3 +1,6 @@ +namespace factor +{ + extern CELL bignum_zero; extern CELL bignum_pos_one; extern CELL bignum_neg_one; @@ -142,3 +145,5 @@ VM_C_API CELL to_cell(CELL tagged); VM_ASM_API void overflow_fixnum_add(F_FIXNUM x, F_FIXNUM y); VM_ASM_API void overflow_fixnum_subtract(F_FIXNUM x, F_FIXNUM y); VM_ASM_API void overflow_fixnum_multiply(F_FIXNUM x, F_FIXNUM y); + +} diff --git a/vm/os-freebsd-x86.32.hpp b/vm/os-freebsd-x86.32.hpp index a5a96d84ca..c276ce6174 100644 --- a/vm/os-freebsd-x86.32.hpp +++ b/vm/os-freebsd-x86.32.hpp @@ -1,5 +1,8 @@ #include +namespace factor +{ + inline static void *ucontext_stack_pointer(void *uap) { ucontext_t *ucontext = (ucontext_t *)uap; @@ -7,3 +10,5 @@ inline static void *ucontext_stack_pointer(void *uap) } #define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)(ucontext))->uc_mcontext.mc_eip) + +} diff --git a/vm/os-freebsd-x86.64.hpp b/vm/os-freebsd-x86.64.hpp index d74278fb19..6ee491f3ae 100644 --- a/vm/os-freebsd-x86.64.hpp +++ b/vm/os-freebsd-x86.64.hpp @@ -1,5 +1,8 @@ #include +namespace factor +{ + inline static void *ucontext_stack_pointer(void *uap) { ucontext_t *ucontext = (ucontext_t *)uap; @@ -7,3 +10,5 @@ inline static void *ucontext_stack_pointer(void *uap) } #define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)(ucontext))->uc_mcontext.mc_rip) + +} diff --git a/vm/os-freebsd.cpp b/vm/os-freebsd.cpp index c5bb0a7837..63313f61e0 100644 --- a/vm/os-freebsd.cpp +++ b/vm/os-freebsd.cpp @@ -1,5 +1,8 @@ #include "master.hpp" +namespace factor +{ + /* From SBCL */ const char *vm_executable_path(void) { @@ -32,3 +35,5 @@ const char *vm_executable_path(void) return safe_strdup(path); } + +} diff --git a/vm/os-freebsd.hpp b/vm/os-freebsd.hpp index 617a6686c2..0acf537d45 100644 --- a/vm/os-freebsd.hpp +++ b/vm/os-freebsd.hpp @@ -1,9 +1,8 @@ #include - -extern int getosreldate(void); - #include +extern "C" int getosreldate(void); + #ifndef KERN_PROC_PATHNAME #define KERN_PROC_PATHNAME 12 #endif diff --git a/vm/os-genunix.cpp b/vm/os-genunix.cpp index 6f5087bc6e..53b65b1f7d 100755 --- a/vm/os-genunix.cpp +++ b/vm/os-genunix.cpp @@ -1,5 +1,8 @@ #include "master.hpp" +namespace factor +{ + void c_to_factor_toplevel(CELL quot) { c_to_factor(quot); @@ -33,3 +36,5 @@ const char *default_image_path(void) memcpy(new_path + len,SUFFIX,SUFFIX_LEN + 1); return new_path; } + +} diff --git a/vm/os-genunix.hpp b/vm/os-genunix.hpp index 72e9a43a1c..91cdba9d2c 100644 --- a/vm/os-genunix.hpp +++ b/vm/os-genunix.hpp @@ -1,3 +1,6 @@ +namespace factor +{ + #define VM_C_API extern "C" #define NULL_DLL NULL @@ -6,3 +9,5 @@ void init_signals(void); void early_init(void); const char *vm_executable_path(void); const char *default_image_path(void); + +} diff --git a/vm/os-linux-arm.cpp b/vm/os-linux-arm.cpp index d8131f1ffb..fe98226369 100644 --- a/vm/os-linux-arm.cpp +++ b/vm/os-linux-arm.cpp @@ -1,5 +1,8 @@ #include "master.hpp" +namespace factor +{ + void flush_icache(CELL start, CELL len) { int result; @@ -24,3 +27,5 @@ void flush_icache(CELL start, CELL len) if(result < 0) critical_error("flush_icache() failed",result); } + +} diff --git a/vm/os-linux-arm.hpp b/vm/os-linux-arm.hpp index 92900281cd..c767ec858e 100644 --- a/vm/os-linux-arm.hpp +++ b/vm/os-linux-arm.hpp @@ -2,6 +2,9 @@ #include #include +namespace factor +{ + inline static void *ucontext_stack_pointer(void *uap) { ucontext_t *ucontext = (ucontext_t *)uap; @@ -12,3 +15,5 @@ inline static void *ucontext_stack_pointer(void *uap) (((ucontext_t *)(ucontext))->uc_mcontext.arm_pc) void flush_icache(CELL start, CELL len); + +} diff --git a/vm/os-linux-ppc.hpp b/vm/os-linux-ppc.hpp index da0333036c..da098ddeaf 100644 --- a/vm/os-linux-ppc.hpp +++ b/vm/os-linux-ppc.hpp @@ -1,5 +1,8 @@ #include +namespace factor +{ + #define FRAME_RETURN_ADDRESS(frame) *((XT *)(frame_successor(frame) + 1) + 1) inline static void *ucontext_stack_pointer(void *uap) @@ -10,3 +13,5 @@ inline static void *ucontext_stack_pointer(void *uap) #define UAP_PROGRAM_COUNTER(ucontext) \ (((ucontext_t *)(ucontext))->uc_mcontext.uc_regs->gregs[PT_NIP]) + +} diff --git a/vm/os-linux-x86.32.hpp b/vm/os-linux-x86.32.hpp index 2906bf2810..4ba7c77e4b 100644 --- a/vm/os-linux-x86.32.hpp +++ b/vm/os-linux-x86.32.hpp @@ -1,5 +1,8 @@ #include +namespace factor +{ + inline static void *ucontext_stack_pointer(void *uap) { ucontext_t *ucontext = (ucontext_t *)uap; @@ -8,3 +11,5 @@ inline static void *ucontext_stack_pointer(void *uap) #define UAP_PROGRAM_COUNTER(ucontext) \ (((ucontext_t *)(ucontext))->uc_mcontext.gregs[14]) + +} diff --git a/vm/os-linux-x86.64.hpp b/vm/os-linux-x86.64.hpp index 7c817f3b4d..477e21708c 100644 --- a/vm/os-linux-x86.64.hpp +++ b/vm/os-linux-x86.64.hpp @@ -1,5 +1,8 @@ #include +namespace factor +{ + inline static void *ucontext_stack_pointer(void *uap) { ucontext_t *ucontext = (ucontext_t *)uap; @@ -8,3 +11,5 @@ inline static void *ucontext_stack_pointer(void *uap) #define UAP_PROGRAM_COUNTER(ucontext) \ (((ucontext_t *)(ucontext))->uc_mcontext.gregs[16]) + +} diff --git a/vm/os-linux.cpp b/vm/os-linux.cpp index fcffd75a8e..c3e10668e7 100644 --- a/vm/os-linux.cpp +++ b/vm/os-linux.cpp @@ -1,5 +1,8 @@ #include "master.hpp" +namespace factor +{ + /* Snarfed from SBCL linux-so.c. You must free() this yourself. */ const char *vm_executable_path(void) { @@ -56,3 +59,5 @@ int inotify_rm_watch(int fd, u32 wd) } #endif + +} diff --git a/vm/os-linux.hpp b/vm/os-linux.hpp index 8e78595687..4e2f22b95f 100644 --- a/vm/os-linux.hpp +++ b/vm/os-linux.hpp @@ -1,5 +1,10 @@ #include +namespace factor +{ + int inotify_init(void); int inotify_add_watch(int fd, const char *name, u32 mask); int inotify_rm_watch(int fd, u32 wd); + +} diff --git a/vm/os-macosx-ppc.hpp b/vm/os-macosx-ppc.hpp index 07924f854b..026b523b16 100644 --- a/vm/os-macosx-ppc.hpp +++ b/vm/os-macosx-ppc.hpp @@ -1,3 +1,8 @@ +#include + +namespace factor +{ + /* Fault handler information. MacOSX version. Copyright (C) 1993-1999, 2002-2003 Bruno Haible Copyright (C) 2003 Paolo Bonzini @@ -8,8 +13,6 @@ Used under BSD license with permission from Paolo Bonzini and Bruno Haible, http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org Modified for Factor by Slava Pestov */ -#include - #define FRAME_RETURN_ADDRESS(frame) *((XT *)(frame_successor(frame) + 1) + 2) #define MACH_EXC_STATE_TYPE ppc_exception_state_t @@ -37,3 +40,5 @@ inline static CELL fix_stack_pointer(CELL sp) { return sp; } + +} diff --git a/vm/os-macosx-x86.32.hpp b/vm/os-macosx-x86.32.hpp index 1ae7ca65cc..9f781631c2 100644 --- a/vm/os-macosx-x86.32.hpp +++ b/vm/os-macosx-x86.32.hpp @@ -1,3 +1,8 @@ +#include + +namespace factor +{ + /* Fault handler information. MacOSX version. Copyright (C) 1993-1999, 2002-2003 Bruno Haible Copyright (C) 2003 Paolo Bonzini @@ -8,8 +13,6 @@ Used under BSD license with permission from Paolo Bonzini and Bruno Haible, http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org Modified for Factor by Slava Pestov */ -#include - #define MACH_EXC_STATE_TYPE i386_exception_state_t #define MACH_EXC_STATE_FLAVOR i386_EXCEPTION_STATE #define MACH_EXC_STATE_COUNT i386_EXCEPTION_STATE_COUNT @@ -35,3 +38,5 @@ inline static CELL fix_stack_pointer(CELL sp) { return ((sp + 4) & ~15) - 4; } + +} diff --git a/vm/os-macosx-x86.64.hpp b/vm/os-macosx-x86.64.hpp index ee32c8f21b..cd4253bcc8 100644 --- a/vm/os-macosx-x86.64.hpp +++ b/vm/os-macosx-x86.64.hpp @@ -1,3 +1,8 @@ +#include + +namespace factor +{ + /* Fault handler information. MacOSX version. Copyright (C) 1993-1999, 2002-2003 Bruno Haible Copyright (C) 2003 Paolo Bonzini @@ -8,8 +13,6 @@ Used under BSD license with permission from Paolo Bonzini and Bruno Haible, http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org Modified for Factor by Slava Pestov and Daniel Ehrenberg */ -#include - #define MACH_EXC_STATE_TYPE x86_exception_state64_t #define MACH_EXC_STATE_FLAVOR x86_EXCEPTION_STATE64 #define MACH_EXC_STATE_COUNT x86_EXCEPTION_STATE64_COUNT @@ -35,3 +38,5 @@ inline static CELL fix_stack_pointer(CELL sp) { return ((sp + 8) & ~15) - 8; } + +} diff --git a/vm/os-macosx.hpp b/vm/os-macosx.hpp index 10aa515fd2..bb54592364 100644 --- a/vm/os-macosx.hpp +++ b/vm/os-macosx.hpp @@ -1,3 +1,6 @@ +namespace factor +{ + #define VM_C_API extern "C" __attribute__((visibility("default"))) #define FACTOR_OS_STRING "macosx" #define NULL_DLL "libfactor.dylib" @@ -15,3 +18,5 @@ inline static void *ucontext_stack_pointer(void *uap) } void c_to_factor_toplevel(CELL quot); + +} diff --git a/vm/os-macosx.mm b/vm/os-macosx.mm index a47bdda3d1..e7c2c1d602 100644 --- a/vm/os-macosx.mm +++ b/vm/os-macosx.mm @@ -2,6 +2,9 @@ #include "master.hpp" +namespace factor +{ + void c_to_factor_toplevel(CELL quot) { for(;;) @@ -80,3 +83,5 @@ Protocol *objc_getProtocol(char *name) else return nil; } + +} diff --git a/vm/os-netbsd-x86.32.hpp b/vm/os-netbsd-x86.32.hpp index ca4a9f88f5..ebba4f356d 100644 --- a/vm/os-netbsd-x86.32.hpp +++ b/vm/os-netbsd-x86.32.hpp @@ -1,3 +1,8 @@ #include +namespace factor +{ + #define ucontext_stack_pointer(uap) ((void *)_UC_MACHINE_SP((ucontext_t *)uap)) + +} diff --git a/vm/os-netbsd-x86.64.hpp b/vm/os-netbsd-x86.64.hpp index 587dc85ec7..1a062cc6ef 100644 --- a/vm/os-netbsd-x86.64.hpp +++ b/vm/os-netbsd-x86.64.hpp @@ -1,4 +1,9 @@ #include +namespace factor +{ + #define ucontext_stack_pointer(uap) \ ((void *)(((ucontext_t *)(uap))->uc_mcontext.__gregs[_REG_URSP])) + +} diff --git a/vm/os-netbsd.cpp b/vm/os-netbsd.cpp index 088f6eb9cf..cd397bdae1 100755 --- a/vm/os-netbsd.cpp +++ b/vm/os-netbsd.cpp @@ -1,5 +1,8 @@ #include "master.hpp" +namespace factor +{ + extern int main(); const char *vm_executable_path(void) @@ -9,3 +12,5 @@ const char *vm_executable_path(void) dladdr(main, &info); return info.dli_fname; } + +} diff --git a/vm/os-netbsd.hpp b/vm/os-netbsd.hpp index 6486acda4a..635361e3e4 100644 --- a/vm/os-netbsd.hpp +++ b/vm/os-netbsd.hpp @@ -1,5 +1,10 @@ #include +namespace factor +{ + #define UAP_PROGRAM_COUNTER(uap) _UC_MACHINE_PC((ucontext_t *)uap) #define DIRECTORY_P(file) ((file)->d_type == DT_DIR) + +} diff --git a/vm/os-openbsd-x86.32.hpp b/vm/os-openbsd-x86.32.hpp index 93d66298aa..6065d96a5f 100644 --- a/vm/os-openbsd-x86.32.hpp +++ b/vm/os-openbsd-x86.32.hpp @@ -1,5 +1,8 @@ #include +namespace factor +{ + inline static void *openbsd_stack_pointer(void *uap) { struct sigcontext *sc = (struct sigcontext*) uap; @@ -8,3 +11,5 @@ inline static void *openbsd_stack_pointer(void *uap) #define ucontext_stack_pointer openbsd_stack_pointer #define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_eip) + +} diff --git a/vm/os-openbsd-x86.64.hpp b/vm/os-openbsd-x86.64.hpp index d318f9e3ab..7338b04e6f 100644 --- a/vm/os-openbsd-x86.64.hpp +++ b/vm/os-openbsd-x86.64.hpp @@ -1,5 +1,8 @@ #include +namespace factor +{ + inline static void *openbsd_stack_pointer(void *uap) { struct sigcontext *sc = (struct sigcontext*) uap; @@ -8,3 +11,5 @@ inline static void *openbsd_stack_pointer(void *uap) #define ucontext_stack_pointer openbsd_stack_pointer #define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_rip) + +} diff --git a/vm/os-openbsd.cpp b/vm/os-openbsd.cpp index 855298a810..fc8aac8cf7 100644 --- a/vm/os-openbsd.cpp +++ b/vm/os-openbsd.cpp @@ -1,6 +1,11 @@ #include "master.hpp" +namespace factor +{ + const char *vm_executable_path(void) { return NULL; } + +} diff --git a/vm/os-solaris-x86.32.hpp b/vm/os-solaris-x86.32.hpp index 1261f191d1..b89b8d541b 100644 --- a/vm/os-solaris-x86.32.hpp +++ b/vm/os-solaris-x86.32.hpp @@ -1,5 +1,8 @@ #include +namespace factor +{ + inline static void *ucontext_stack_pointer(void *uap) { ucontext_t *ucontext = (ucontext_t *)uap; @@ -8,3 +11,5 @@ inline static void *ucontext_stack_pointer(void *uap) #define UAP_PROGRAM_COUNTER(ucontext) \ (((ucontext_t *)(ucontext))->uc_mcontext.gregs[EIP]) + +} diff --git a/vm/os-solaris-x86.64.hpp b/vm/os-solaris-x86.64.hpp index 4dc3a118d3..0d3a74e11d 100644 --- a/vm/os-solaris-x86.64.hpp +++ b/vm/os-solaris-x86.64.hpp @@ -1,5 +1,8 @@ #include +namespace factor +{ + inline static void *ucontext_stack_pointer(void *uap) { ucontext_t *ucontext = (ucontext_t *)uap; @@ -8,3 +11,5 @@ inline static void *ucontext_stack_pointer(void *uap) #define UAP_PROGRAM_COUNTER(ucontext) \ (((ucontext_t *)(ucontext))->uc_mcontext.gregs[RIP]) + +} diff --git a/vm/os-solaris.cpp b/vm/os-solaris.cpp index 855298a810..fc8aac8cf7 100644 --- a/vm/os-solaris.cpp +++ b/vm/os-solaris.cpp @@ -1,6 +1,11 @@ #include "master.hpp" +namespace factor +{ + const char *vm_executable_path(void) { return NULL; } + +} diff --git a/vm/os-unix.cpp b/vm/os-unix.cpp index c3d70fa354..417f79c5ba 100755 --- a/vm/os-unix.cpp +++ b/vm/os-unix.cpp @@ -1,5 +1,8 @@ #include "master.hpp" +namespace factor +{ + void start_thread(void *(*start_routine)(void *)) { pthread_attr_t attr; @@ -311,3 +314,5 @@ VM_C_API void wait_for_stdin(void) fatal_error("Error writing control fd",errno); } } + +} diff --git a/vm/os-unix.hpp b/vm/os-unix.hpp index 6ea11cbf14..cb0afc4e61 100755 --- a/vm/os-unix.hpp +++ b/vm/os-unix.hpp @@ -8,11 +8,12 @@ #include #include +namespace factor +{ + typedef char F_CHAR; typedef char F_SYMBOL; -#define string_to_native_alien(string) string_to_char_alien(string,true) - #define STRING_LITERAL(string) string #define SSCANF sscanf @@ -54,3 +55,5 @@ s64 current_micros(void); void sleep_micros(CELL usec); void open_console(void); + +} diff --git a/vm/os-windows-ce.cpp b/vm/os-windows-ce.cpp index ea8a7bb159..af127016de 100755 --- a/vm/os-windows-ce.cpp +++ b/vm/os-windows-ce.cpp @@ -1,5 +1,8 @@ #include "master.hpp" +namespace factor +{ + s64 current_micros(void) { SYSTEMTIME st; @@ -38,3 +41,5 @@ void c_to_factor_toplevel(CELL quot) } void open_console(void) { } + +} diff --git a/vm/os-windows-ce.hpp b/vm/os-windows-ce.hpp index bc10017262..49b6d73077 100755 --- a/vm/os-windows-ce.hpp +++ b/vm/os-windows-ce.hpp @@ -5,6 +5,9 @@ #include #include +namespace factor +{ + typedef wchar_t F_SYMBOL; #define FACTOR_OS_STRING "wince" @@ -22,3 +25,5 @@ char *getenv(char *name); s64 current_micros(void); void c_to_factor_toplevel(CELL quot); void open_console(void); + +} diff --git a/vm/os-windows-nt.32.hpp b/vm/os-windows-nt.32.hpp index 9b10671ba0..ed67e28b8b 100644 --- a/vm/os-windows-nt.32.hpp +++ b/vm/os-windows-nt.32.hpp @@ -1,2 +1,7 @@ +namespace factor +{ + #define ESP Esp #define EIP Eip + +} diff --git a/vm/os-windows-nt.64.hpp b/vm/os-windows-nt.64.hpp index 1f61c2335f..30ce150754 100644 --- a/vm/os-windows-nt.64.hpp +++ b/vm/os-windows-nt.64.hpp @@ -1,2 +1,7 @@ +namespace factor +{ + #define ESP Rsp #define EIP Rip + +} diff --git a/vm/os-windows-nt.cpp b/vm/os-windows-nt.cpp index 2f449e15cf..d148a32df6 100755 --- a/vm/os-windows-nt.cpp +++ b/vm/os-windows-nt.cpp @@ -1,5 +1,8 @@ #include "master.hpp" +namespace factor +{ + s64 current_micros(void) { FILETIME t; @@ -49,3 +52,5 @@ void c_to_factor_toplevel(CELL quot) void open_console(void) { } + +} diff --git a/vm/os-windows-nt.hpp b/vm/os-windows-nt.hpp index 8ae4121ae6..e55d6ee97c 100755 --- a/vm/os-windows-nt.hpp +++ b/vm/os-windows-nt.hpp @@ -5,8 +5,12 @@ #define UNICODE #endif +#include #include +namespace factor +{ + typedef char F_SYMBOL; #define FACTOR_OS_STRING "winnt" @@ -16,3 +20,5 @@ typedef char F_SYMBOL; void c_to_factor_toplevel(CELL quot); long exception_handler(PEXCEPTION_POINTERS pe); void open_console(void); + +} diff --git a/vm/os-windows.cpp b/vm/os-windows.cpp index 604c718a33..24b49ff61b 100755 --- a/vm/os-windows.cpp +++ b/vm/os-windows.cpp @@ -1,5 +1,8 @@ #include "master.hpp" +namespace factor +{ + HMODULE hFactorDll; void init_ffi(void) @@ -144,3 +147,5 @@ void sleep_micros(u64 usec) { Sleep((DWORD)(usec / 1000)); } + +} diff --git a/vm/os-windows.hpp b/vm/os-windows.hpp index 0b66120764..db83688b13 100755 --- a/vm/os-windows.hpp +++ b/vm/os-windows.hpp @@ -5,9 +5,10 @@ #include #endif -typedef wchar_t F_CHAR; +namespace factor +{ -#define string_to_native_alien(string) string_to_u16_alien(string,true) +typedef wchar_t F_CHAR; #define STRING_LITERAL(string) L##string @@ -55,3 +56,4 @@ long getpagesize (void); s64 current_micros(void); +} diff --git a/vm/primitives.cpp b/vm/primitives.cpp index e629bebb3c..0c9fc32dff 100755 --- a/vm/primitives.cpp +++ b/vm/primitives.cpp @@ -1,5 +1,8 @@ #include "master.hpp" +namespace factor +{ + void *primitives[] = { (void *)primitive_bignum_to_fixnum, (void *)primitive_float_to_fixnum, @@ -152,3 +155,5 @@ void *primitives[] = { (void *)primitive_inline_cache_stats, (void *)primitive_optimized_p, }; + +} diff --git a/vm/primitives.hpp b/vm/primitives.hpp index 68c6f17e9d..b26638274b 100644 --- a/vm/primitives.hpp +++ b/vm/primitives.hpp @@ -1,5 +1,10 @@ +namespace factor +{ + //typedef extern "C" void (*F_PRIMITIVE)(void); extern void *primitives[]; #define PRIMITIVE(name) extern "C" void primitive_##name() + +} diff --git a/vm/profiler.cpp b/vm/profiler.cpp index 7790578cb1..7a832e6219 100755 --- a/vm/profiler.cpp +++ b/vm/profiler.cpp @@ -1,5 +1,8 @@ #include "master.hpp" +namespace factor +{ + bool profiling_p; void init_profiler(void) @@ -50,3 +53,5 @@ PRIMITIVE(profiling) { set_profiling(to_boolean(dpop())); } + +} diff --git a/vm/profiler.hpp b/vm/profiler.hpp index fc31ef4002..60f83721b2 100755 --- a/vm/profiler.hpp +++ b/vm/profiler.hpp @@ -1,4 +1,9 @@ +namespace factor +{ + extern bool profiling_p; void init_profiler(void); F_CODE_BLOCK *compile_profiling_stub(CELL word); PRIMITIVE(profiling); + +} diff --git a/vm/quotations.cpp b/vm/quotations.cpp index b9c538f45c..d0d995cd65 100755 --- a/vm/quotations.cpp +++ b/vm/quotations.cpp @@ -1,5 +1,8 @@ #include "master.hpp" +namespace factor +{ + /* Simple non-optimizing compiler. This is one of the two compilers implementing Factor; the second one is written @@ -334,3 +337,5 @@ VM_ASM_API CELL lazy_jit_compile_impl(CELL quot_, F_STACK_FRAME *stack) jit_compile(quot.value(),true); return quot.value(); } + +} diff --git a/vm/quotations.hpp b/vm/quotations.hpp index 92f49732d5..6472cb1329 100755 --- a/vm/quotations.hpp +++ b/vm/quotations.hpp @@ -1,3 +1,6 @@ +namespace factor +{ + struct quotation_jit : public jit { gc_root array; bool compiling, relocate; @@ -31,3 +34,5 @@ PRIMITIVE(array_to_quotation); PRIMITIVE(quotation_xt); VM_ASM_API CELL lazy_jit_compile_impl(CELL quot, F_STACK_FRAME *stack); + +} diff --git a/vm/run.cpp b/vm/run.cpp index c979ca1750..b10fd0e96b 100755 --- a/vm/run.cpp +++ b/vm/run.cpp @@ -1,6 +1,10 @@ #include "master.hpp" -CELL userenv[USER_ENV]; +factor::CELL userenv[USER_ENV]; + +namespace factor +{ + CELL T; PRIMITIVE(getenv) @@ -68,3 +72,5 @@ PRIMITIVE(clone) { drepl(clone_object(dpeek())); } + +} diff --git a/vm/run.hpp b/vm/run.hpp index c82c8d678d..48c3f9f6c2 100755 --- a/vm/run.hpp +++ b/vm/run.hpp @@ -1,3 +1,6 @@ +namespace factor +{ + #define USER_ENV 70 typedef enum { @@ -90,9 +93,6 @@ typedef enum { #define FIRST_SAVE_ENV BOOT_ENV #define LAST_SAVE_ENV STAGE2_ENV -/* TAGGED user environment data; see getenv/setenv prims */ -extern CELL userenv[USER_ENV]; - /* Canonical T object. It's just a word */ extern CELL T; @@ -104,3 +104,8 @@ PRIMITIVE(sleep); PRIMITIVE(set_slot); PRIMITIVE(load_locals); PRIMITIVE(clone); + +} + +/* TAGGED user environment data; see getenv/setenv prims */ +VM_C_API factor::CELL userenv[USER_ENV]; diff --git a/vm/segments.hpp b/vm/segments.hpp index 2a33b35cfd..6e8ea3f491 100644 --- a/vm/segments.hpp +++ b/vm/segments.hpp @@ -1,5 +1,10 @@ +namespace factor +{ + struct F_SEGMENT { CELL start; CELL size; CELL end; }; + +} diff --git a/vm/stacks.hpp b/vm/stacks.hpp index f11481b18f..3a4e88cb9d 100644 --- a/vm/stacks.hpp +++ b/vm/stacks.hpp @@ -1,3 +1,6 @@ +namespace factor +{ + #define DEFPUSHPOP(prefix,ptr) \ inline static CELL prefix##peek() { return *(CELL *)ptr; } \ inline static void prefix##repl(CELL tagged) { *(CELL *)ptr = tagged; } \ @@ -12,3 +15,5 @@ ptr += CELLS; \ prefix##repl(tagged); \ } + +} diff --git a/vm/strings.cpp b/vm/strings.cpp index d7f2bc884b..a6905aad25 100644 --- a/vm/strings.cpp +++ b/vm/strings.cpp @@ -1,5 +1,8 @@ #include "master.hpp" +namespace factor +{ + CELL string_nth(F_STRING* string, CELL index) { /* If high bit is set, the most significant 16 bits of the char @@ -181,3 +184,5 @@ PRIMITIVE(set_string_nth_slow) CELL value = untag_fixnum(dpop()); set_string_nth_slow(string,index,value); } + +} diff --git a/vm/strings.hpp b/vm/strings.hpp index f35053e78d..f9cdc74bb1 100644 --- a/vm/strings.hpp +++ b/vm/strings.hpp @@ -1,3 +1,6 @@ +namespace factor +{ + inline static CELL string_capacity(F_STRING *str) { return untag_fixnum(str->length); @@ -21,3 +24,5 @@ void set_string_nth(F_STRING* string, CELL index, CELL value); PRIMITIVE(string_nth); PRIMITIVE(set_string_nth_slow); PRIMITIVE(set_string_nth_fast); + +} diff --git a/vm/tagged.hpp b/vm/tagged.hpp index fb14e7fa70..c31389f6b0 100644 --- a/vm/tagged.hpp +++ b/vm/tagged.hpp @@ -1,3 +1,6 @@ +namespace factor +{ + template CELL tag(T *value) { return RETAG(value,tag_for(T::type_number)); @@ -38,7 +41,7 @@ struct tagged #endif } - explicit tagged(T *untagged) : value_(::tag(untagged)) { + explicit tagged(T *untagged) : value_(factor::tag(untagged)) { #ifdef FACTOR_DEBUG untag_check(); #endif @@ -65,3 +68,5 @@ template T *untag(CELL value) { return tagged(value).untagged(); } + +} diff --git a/vm/test.cpp b/vm/test.cpp deleted file mode 100644 index 694416031d..0000000000 --- a/vm/test.cpp +++ /dev/null @@ -1,16 +0,0 @@ -#include "master.hpp" - - -template struct blah { - const T *x_; - blah(T *x) : x_(x) {} - - blah& operator=(const T *x) { x_ = x; } -}; - -CELL test() -{ - int x = 100; - blah u(&x); - u = &x; -} diff --git a/vm/tuples.cpp b/vm/tuples.cpp index ec93cc4adc..5807d4baf4 100644 --- a/vm/tuples.cpp +++ b/vm/tuples.cpp @@ -1,5 +1,8 @@ #include "master.hpp" +namespace factor +{ + /* push a new tuple on the stack */ F_TUPLE *allot_tuple(CELL layout_) { @@ -30,3 +33,5 @@ PRIMITIVE(tuple_boa) ds -= size; dpush(tuple.value()); } + +} diff --git a/vm/tuples.hpp b/vm/tuples.hpp index bcbc268d72..477510307b 100644 --- a/vm/tuples.hpp +++ b/vm/tuples.hpp @@ -1,3 +1,6 @@ +namespace factor +{ + inline static CELL tuple_size(F_TUPLE_LAYOUT *layout) { CELL size = untag_fixnum(layout->size); @@ -18,3 +21,5 @@ inline static void set_tuple_nth(F_TUPLE *tuple, CELL slot, CELL value) PRIMITIVE(tuple); PRIMITIVE(tuple_boa); PRIMITIVE(tuple_layout); + +} diff --git a/vm/utilities.cpp b/vm/utilities.cpp index b567c4d0a9..2ccc0aaf78 100755 --- a/vm/utilities.cpp +++ b/vm/utilities.cpp @@ -1,5 +1,8 @@ #include "master.hpp" +namespace factor +{ + /* If memory allocation fails, bail out */ void *safe_malloc(size_t size) { @@ -53,3 +56,5 @@ CELL read_cell_hex(void) if(scanf(CELL_HEX_FORMAT,&cell) < 0) exit(1); return cell; }; + +} diff --git a/vm/utilities.hpp b/vm/utilities.hpp index d2b3223ce4..249ea562f5 100755 --- a/vm/utilities.hpp +++ b/vm/utilities.hpp @@ -1,3 +1,6 @@ +namespace factor +{ + void *safe_malloc(size_t size); F_CHAR *safe_strdup(const F_CHAR *str); @@ -8,3 +11,5 @@ void print_cell_hex(CELL x); void print_cell_hex_pad(CELL x); void print_fixnum(F_FIXNUM x); CELL read_cell_hex(void); + +} diff --git a/vm/words.cpp b/vm/words.cpp index 17ddc9b747..d1523ebccf 100644 --- a/vm/words.cpp +++ b/vm/words.cpp @@ -1,5 +1,8 @@ #include "master.hpp" +namespace factor +{ + F_WORD *allot_word(CELL vocab_, CELL name_) { gc_root vocab(vocab_); @@ -74,3 +77,5 @@ PRIMITIVE(wrapper) wrapper->object = dpeek(); drepl(tag(wrapper)); } + +} diff --git a/vm/words.hpp b/vm/words.hpp index d976dccbdd..15c541e9ea 100644 --- a/vm/words.hpp +++ b/vm/words.hpp @@ -1,3 +1,6 @@ +namespace factor +{ + F_WORD *allot_word(CELL vocab, CELL name); PRIMITIVE(word); @@ -12,3 +15,5 @@ inline bool word_optimized_p(F_WORD *word) PRIMITIVE(optimized_p); PRIMITIVE(wrapper); + +} diff --git a/vm/write_barrier.cpp b/vm/write_barrier.cpp index a97caff69e..3ea138f456 100644 --- a/vm/write_barrier.cpp +++ b/vm/write_barrier.cpp @@ -1,5 +1,7 @@ #include "master.hpp" +using namespace factor; + CELL cards_offset; CELL decks_offset; CELL allot_markers_offset; diff --git a/vm/write_barrier.hpp b/vm/write_barrier.hpp index f207547cec..9c317d45b4 100644 --- a/vm/write_barrier.hpp +++ b/vm/write_barrier.hpp @@ -6,6 +6,9 @@ card has a slot written to. the offset of the first object is set by the allocator. */ +namespace factor +{ + /* if CARD_POINTS_TO_NURSERY is set, CARD_POINTS_TO_AGING must also be set. */ #define CARD_POINTS_TO_NURSERY 0x80 #define CARD_POINTS_TO_AGING 0x40 @@ -16,7 +19,7 @@ typedef u8 F_CARD; #define CARD_SIZE (1<> CARD_BITS) + cards_offset) #define CARD_TO_ADDR(c) (CELL*)(((CELL)(c) - cards_offset)<> DECK_BITS) + decks_offset) #define DECK_TO_ADDR(c) (CELL*)(((CELL)(c) - decks_offset) << DECK_BITS) @@ -39,7 +42,7 @@ extern "C" CELL decks_offset; #define INVALID_ALLOT_MARKER 0xff -extern "C" CELL allot_markers_offset; +VM_C_API CELL allot_markers_offset; /* the write barrier must be called any time we are potentially storing a pointer from an older generation to a younger one */ @@ -56,3 +59,5 @@ inline static void allot_barrier(F_OBJECT *address) if(*ptr == INVALID_ALLOT_MARKER) *ptr = ((CELL)address & ADDR_CARD_MASK); } + +} From 8872c40b1e08c195487175700d6cbc3153fa6b8c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 May 2009 04:50:24 -0500 Subject: [PATCH 35/44] The great type renaming --- vm/alien.cpp | 108 ++++++++-------- vm/alien.hpp | 12 +- vm/arrays.cpp | 64 ++++----- vm/arrays.hpp | 24 ++-- vm/bignum.cpp | 280 ++++++++++++++++++++-------------------- vm/bignum.hpp | 122 ++++++++--------- vm/bignumint.hpp | 10 +- vm/booleans.cpp | 2 +- vm/booleans.hpp | 4 +- vm/byte_arrays.cpp | 44 +++---- vm/byte_arrays.hpp | 12 +- vm/callstack.cpp | 118 ++++++++--------- vm/callstack.hpp | 26 ++-- vm/code_block.cpp | 274 +++++++++++++++++++-------------------- vm/code_block.hpp | 42 +++--- vm/code_gc.cpp | 110 ++++++++-------- vm/code_gc.hpp | 52 ++++---- vm/code_heap.cpp | 98 +++++++------- vm/code_heap.hpp | 16 +-- vm/contexts.cpp | 96 +++++++------- vm/contexts.hpp | 30 ++--- vm/cpu-arm.hpp | 14 +- vm/cpu-ppc.hpp | 16 +-- vm/cpu-x86.32.hpp | 4 +- vm/cpu-x86.64.hpp | 4 +- vm/cpu-x86.hpp | 26 ++-- vm/data_gc.cpp | 250 +++++++++++++++++------------------ vm/data_gc.hpp | 70 +++++----- vm/data_heap.cpp | 259 ++++++++++++++++++------------------- vm/data_heap.hpp | 117 ++++++++--------- vm/debug.cpp | 152 +++++++++++----------- vm/debug.hpp | 6 +- vm/dispatch.cpp | 125 +++++++++--------- vm/dispatch.hpp | 8 +- vm/errors.cpp | 28 ++-- vm/errors.hpp | 24 ++-- vm/factor.cpp | 48 +++---- vm/factor.hpp | 12 +- vm/float_bits.hpp | 16 +-- vm/generic_arrays.hpp | 16 +-- vm/image.cpp | 120 ++++++++--------- vm/image.hpp | 42 +++--- vm/inline_cache.cpp | 128 +++++++++--------- vm/inline_cache.hpp | 4 +- vm/io.cpp | 24 ++-- vm/jit.cpp | 46 ++++--- vm/jit.hpp | 40 +++--- vm/layouts.hpp | 234 ++++++++++++++++----------------- vm/local_roots.cpp | 8 +- vm/local_roots.hpp | 24 ++-- vm/mach_signal.cpp | 6 +- vm/master.hpp | 2 +- vm/math.cpp | 154 +++++++++++----------- vm/math.hpp | 72 +++++------ vm/os-genunix.cpp | 2 +- vm/os-genunix.hpp | 2 +- vm/os-linux-arm.cpp | 2 +- vm/os-linux-arm.hpp | 2 +- vm/os-linux-ppc.hpp | 2 +- vm/os-macosx-ppc.hpp | 4 +- vm/os-macosx-x86.32.hpp | 2 +- vm/os-macosx-x86.64.hpp | 2 +- vm/os-macosx.hpp | 2 +- vm/os-macosx.mm | 6 +- vm/os-unix.cpp | 34 ++--- vm/os-unix.hpp | 20 +-- vm/os-windows-ce.cpp | 4 +- vm/os-windows-ce.hpp | 6 +- vm/os-windows-nt.cpp | 6 +- vm/os-windows-nt.hpp | 4 +- vm/os-windows.cpp | 36 +++--- vm/os-windows.hpp | 24 ++-- vm/primitives.hpp | 2 - vm/profiler.cpp | 14 +- vm/profiler.hpp | 2 +- vm/quotations.cpp | 130 +++++++++---------- vm/quotations.hpp | 28 ++-- vm/run.cpp | 42 +++--- vm/run.hpp | 10 +- vm/segments.hpp | 8 +- vm/stacks.hpp | 14 +- vm/strings.cpp | 140 ++++++++++---------- vm/strings.hpp | 16 +-- vm/tagged.hpp | 28 ++-- vm/tuples.cpp | 30 ++--- vm/tuples.hpp | 17 +-- vm/utilities.cpp | 24 ++-- vm/utilities.hpp | 12 +- vm/words.cpp | 73 +++++------ vm/words.hpp | 6 +- vm/write_barrier.cpp | 6 +- vm/write_barrier.hpp | 60 ++++++--- 92 files changed, 2223 insertions(+), 2242 deletions(-) diff --git a/vm/alien.cpp b/vm/alien.cpp index c53890f3b4..7bb458c8cd 100755 --- a/vm/alien.cpp +++ b/vm/alien.cpp @@ -5,55 +5,55 @@ namespace factor /* gets the address of an object representing a C pointer, with the intention of storing the pointer across code which may potentially GC. */ -char *pinned_alien_offset(CELL object) +char *pinned_alien_offset(cell obj) { - switch(tagged(object).type()) + switch(tagged(obj).type()) { case ALIEN_TYPE: - F_ALIEN *alien = untag(object); - if(alien->expired != F) - general_error(ERROR_EXPIRED,object,F,NULL); - return pinned_alien_offset(alien->alien) + alien->displacement; + alien *ptr = untag(obj); + if(ptr->expired != F) + general_error(ERROR_EXPIRED,obj,F,NULL); + return pinned_alien_offset(ptr->alien) + ptr->displacement; case F_TYPE: return NULL; default: - type_error(ALIEN_TYPE,object); + type_error(ALIEN_TYPE,obj); return NULL; /* can't happen */ } } /* make an alien */ -CELL allot_alien(CELL delegate_, CELL displacement) +cell allot_alien(cell delegate_, cell displacement) { - gc_root delegate(delegate_); - gc_root alien(allot(sizeof(F_ALIEN))); + gc_root delegate(delegate_); + gc_root new_alien(allot(sizeof(alien))); if(delegate.type_p(ALIEN_TYPE)) { - tagged delegate_alien = delegate.as(); + tagged delegate_alien = delegate.as(); displacement += delegate_alien->displacement; - alien->alien = delegate_alien->alien; + new_alien->alien = delegate_alien->alien; } else - alien->alien = delegate.value(); + new_alien->alien = delegate.value(); - alien->displacement = displacement; - alien->expired = F; + new_alien->displacement = displacement; + new_alien->expired = F; - return alien.value(); + return new_alien.value(); } /* make an alien pointing at an offset of another alien */ PRIMITIVE(displaced_alien) { - CELL alien = dpop(); - CELL displacement = to_cell(dpop()); + cell alien = dpop(); + cell displacement = to_cell(dpop()); if(alien == F && displacement == 0) dpush(F); else { - switch(tagged(alien).type()) + switch(tagged(alien).type()) { case BYTE_ARRAY_TYPE: case ALIEN_TYPE: @@ -71,13 +71,13 @@ PRIMITIVE(displaced_alien) if the object is a byte array, as a sanity check. */ PRIMITIVE(alien_address) { - box_unsigned_cell((CELL)pinned_alien_offset(dpop())); + box_unsigned_cell((cell)pinned_alien_offset(dpop())); } /* pop ( alien n ) from datastack, return alien's address plus n */ static void *alien_pointer(void) { - F_FIXNUM offset = to_fixnum(dpop()); + fixnum offset = to_fixnum(dpop()); return unbox_alien() + offset; } @@ -94,8 +94,8 @@ static void *alien_pointer(void) *ptr = value; \ } -DEFINE_ALIEN_ACCESSOR(signed_cell,F_FIXNUM,box_signed_cell,to_fixnum) -DEFINE_ALIEN_ACCESSOR(unsigned_cell,CELL,box_unsigned_cell,to_cell) +DEFINE_ALIEN_ACCESSOR(signed_cell,fixnum,box_signed_cell,to_fixnum) +DEFINE_ALIEN_ACCESSOR(unsigned_cell,cell,box_unsigned_cell,to_cell) DEFINE_ALIEN_ACCESSOR(signed_8,s64,box_signed_8,to_signed_8) DEFINE_ALIEN_ACCESSOR(unsigned_8,u64,box_unsigned_8,to_unsigned_8) DEFINE_ALIEN_ACCESSOR(signed_4,s32,box_signed_4,to_fixnum) @@ -111,9 +111,9 @@ DEFINE_ALIEN_ACCESSOR(cell,void *,box_alien,pinned_alien_offset) /* open a native library and push a handle */ PRIMITIVE(dlopen) { - gc_root path(dpop()); + gc_root path(dpop()); path.untag_check(); - gc_root dll(allot(sizeof(F_DLL))); + gc_root dll(allot(sizeof(dll))); dll->path = path.value(); ffi_dlopen(dll.untagged()); dpush(dll.value()); @@ -122,18 +122,19 @@ PRIMITIVE(dlopen) /* look up a symbol in a native library */ PRIMITIVE(dlsym) { - gc_root dll(dpop()); - gc_root name(dpop()); - dll.untag_check(); + gc_root library(dpop()); + gc_root name(dpop()); name.untag_check(); - F_CHAR *sym = (F_CHAR *)(name.untagged() + 1); + vm_char *sym = (vm_char *)(name.untagged() + 1); - if(dll.value() == F) + if(library.value() == F) box_alien(ffi_dlsym(NULL,sym)); else { - tagged d = dll.as(); + tagged d = library.as(); + d.untag_check(); + if(d->dll == NULL) dpush(F); else @@ -144,35 +145,34 @@ PRIMITIVE(dlsym) /* close a native library handle */ PRIMITIVE(dlclose) { - ffi_dlclose(untag_check(dpop())); + ffi_dlclose(untag_check(dpop())); } PRIMITIVE(dll_validp) { - CELL dll = dpop(); - if(dll == F) + cell library = dpop(); + if(library == F) dpush(T); else - dpush(tagged(dll)->dll == NULL ? F : T); + dpush(tagged(library)->dll == NULL ? F : T); } /* gets the address of an object representing a C pointer */ -VM_C_API char *alien_offset(CELL object) +VM_C_API char *alien_offset(cell obj) { - switch(tagged(object).type()) + switch(tagged(obj).type()) { case BYTE_ARRAY_TYPE: - F_BYTE_ARRAY *byte_array = untag(object); - return (char *)(byte_array + 1); + return untag(obj)->data(); case ALIEN_TYPE: - F_ALIEN *alien = untag(object); - if(alien->expired != F) - general_error(ERROR_EXPIRED,object,F,NULL); - return alien_offset(alien->alien) + alien->displacement; + alien *ptr = untag(obj); + if(ptr->expired != F) + general_error(ERROR_EXPIRED,obj,F,NULL); + return alien_offset(ptr->alien) + ptr->displacement; case F_TYPE: return NULL; default: - type_error(ALIEN_TYPE,object); + type_error(ALIEN_TYPE,obj); return NULL; /* can't happen */ } } @@ -189,36 +189,36 @@ VM_C_API void box_alien(void *ptr) if(ptr == NULL) dpush(F); else - dpush(allot_alien(F,(CELL)ptr)); + dpush(allot_alien(F,(cell)ptr)); } /* for FFI calls passing structs by value */ -VM_C_API void to_value_struct(CELL src, void *dest, CELL size) +VM_C_API void to_value_struct(cell src, void *dest, cell size) { memcpy(dest,alien_offset(src),size); } /* for FFI callbacks receiving structs by value */ -VM_C_API void box_value_struct(void *src, CELL size) +VM_C_API void box_value_struct(void *src, cell size) { - F_BYTE_ARRAY *array = allot_byte_array(size); - memcpy(array + 1,src,size); - dpush(tag(array)); + byte_array *bytes = allot_byte_array(size); + memcpy(bytes->data(),src,size); + dpush(tag(bytes)); } /* On some x86 OSes, structs <= 8 bytes are returned in registers. */ -VM_C_API void box_small_struct(CELL x, CELL y, CELL size) +VM_C_API void box_small_struct(cell x, cell y, cell size) { - CELL data[2]; + cell data[2]; data[0] = x; data[1] = y; box_value_struct(data,size); } /* On OS X/PPC, complex numbers are returned in registers. */ -VM_C_API void box_medium_struct(CELL x1, CELL x2, CELL x3, CELL x4, CELL size) +VM_C_API void box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size) { - CELL data[4]; + cell data[4]; data[0] = x1; data[1] = x2; data[2] = x3; diff --git a/vm/alien.hpp b/vm/alien.hpp index 18678af0cf..a66135cf92 100755 --- a/vm/alien.hpp +++ b/vm/alien.hpp @@ -1,7 +1,7 @@ namespace factor { -CELL allot_alien(CELL delegate, CELL displacement); +cell allot_alien(cell delegate, cell displacement); PRIMITIVE(displaced_alien); PRIMITIVE(alien_address); @@ -38,12 +38,12 @@ PRIMITIVE(dlsym); PRIMITIVE(dlclose); PRIMITIVE(dll_validp); -VM_C_API char *alien_offset(CELL object); +VM_C_API char *alien_offset(cell object); VM_C_API char *unbox_alien(void); VM_C_API void box_alien(void *ptr); -VM_C_API void to_value_struct(CELL src, void *dest, CELL size); -VM_C_API void box_value_struct(void *src, CELL size); -VM_C_API void box_small_struct(CELL x, CELL y, CELL size); -VM_C_API void box_medium_struct(CELL x1, CELL x2, CELL x3, CELL x4, CELL size); +VM_C_API void to_value_struct(cell src, void *dest, cell size); +VM_C_API void box_value_struct(void *src, cell size); +VM_C_API void box_small_struct(cell x, cell y, cell size); +VM_C_API void box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size); } diff --git a/vm/arrays.cpp b/vm/arrays.cpp index fde0d3b942..f9a3f211d0 100644 --- a/vm/arrays.cpp +++ b/vm/arrays.cpp @@ -4,58 +4,58 @@ namespace factor { /* make a new array with an initial element */ -F_ARRAY *allot_array(CELL capacity, CELL fill_) +array *allot_array(cell capacity, cell fill_) { - gc_root fill(fill_); - gc_root array(allot_array_internal(capacity)); + gc_root fill(fill_); + gc_root new_array(allot_array_internal(capacity)); if(fill.value() == tag_fixnum(0)) - memset(array->data(),'\0',capacity * CELLS); + memset(new_array->data(),'\0',capacity * sizeof(cell)); else { /* No need for write barrier here. Either the object is in the nursery, or it was allocated directly in tenured space and the write barrier is already hit for us in that case. */ - CELL i; + cell i; for(i = 0; i < capacity; i++) - array->data()[i] = fill.value(); + new_array->data()[i] = fill.value(); } - return array.untagged(); + return new_array.untagged(); } /* push a new array on the stack */ PRIMITIVE(array) { - CELL initial = dpop(); - CELL size = unbox_array_size(); - dpush(tag(allot_array(size,initial))); + cell initial = dpop(); + cell size = unbox_array_size(); + dpush(tag(allot_array(size,initial))); } -CELL allot_array_1(CELL obj_) +cell allot_array_1(cell obj_) { - gc_root obj(obj_); - gc_root a(allot_array_internal(1)); + gc_root obj(obj_); + gc_root a(allot_array_internal(1)); set_array_nth(a.untagged(),0,obj.value()); return a.value(); } -CELL allot_array_2(CELL v1_, CELL v2_) +cell allot_array_2(cell v1_, cell v2_) { - gc_root v1(v1_); - gc_root v2(v2_); - gc_root a(allot_array_internal(2)); + gc_root v1(v1_); + gc_root v2(v2_); + gc_root a(allot_array_internal(2)); set_array_nth(a.untagged(),0,v1.value()); set_array_nth(a.untagged(),1,v2.value()); return a.value(); } -CELL allot_array_4(CELL v1_, CELL v2_, CELL v3_, CELL v4_) +cell allot_array_4(cell v1_, cell v2_, cell v3_, cell v4_) { - gc_root v1(v1_); - gc_root v2(v2_); - gc_root v3(v3_); - gc_root v4(v4_); - gc_root a(allot_array_internal(4)); + gc_root v1(v1_); + gc_root v2(v2_); + gc_root v3(v3_); + gc_root v4(v4_); + gc_root a(allot_array_internal(4)); set_array_nth(a.untagged(),0,v1.value()); set_array_nth(a.untagged(),1,v2.value()); set_array_nth(a.untagged(),2,v3.value()); @@ -65,23 +65,23 @@ CELL allot_array_4(CELL v1_, CELL v2_, CELL v3_, CELL v4_) PRIMITIVE(resize_array) { - F_ARRAY* array = untag_check(dpop()); - CELL capacity = unbox_array_size(); - dpush(tag(reallot_array(array,capacity))); + array* a = untag_check(dpop()); + cell capacity = unbox_array_size(); + dpush(tag(reallot_array(a,capacity))); } -void growable_array::add(CELL elt_) +void growable_array::add(cell elt_) { - gc_root elt(elt_); - if(count == array_capacity(array.untagged())) - array = reallot_array(array.untagged(),count * 2); + gc_root elt(elt_); + if(count == array_capacity(elements.untagged())) + elements = reallot_array(elements.untagged(),count * 2); - set_array_nth(array.untagged(),count++,elt.value()); + set_array_nth(elements.untagged(),count++,elt.value()); } void growable_array::trim() { - array = reallot_array(array.untagged(),count); + elements = reallot_array(elements.untagged(),count); } } diff --git a/vm/arrays.hpp b/vm/arrays.hpp index 87432404fb..82da3bb71d 100644 --- a/vm/arrays.hpp +++ b/vm/arrays.hpp @@ -1,42 +1,42 @@ namespace factor { -inline static CELL array_nth(F_ARRAY *array, CELL slot) +inline static cell array_nth(array *array, cell slot) { #ifdef FACTOR_DEBUG assert(slot < array_capacity(array)); - assert(array->header.hi_tag() == ARRAY_TYPE); + assert(array->h.hi_tag() == ARRAY_TYPE); #endif return array->data()[slot]; } -inline static void set_array_nth(F_ARRAY *array, CELL slot, CELL value) +inline static void set_array_nth(array *array, cell slot, cell value) { #ifdef FACTOR_DEBUG assert(slot < array_capacity(array)); - assert(array->header.hi_tag() == ARRAY_TYPE); + assert(array->h.hi_tag() == ARRAY_TYPE); check_tagged_pointer(value); #endif array->data()[slot] = value; write_barrier(array); } -F_ARRAY *allot_array(CELL capacity, CELL fill); +array *allot_array(cell capacity, cell fill); -CELL allot_array_1(CELL obj); -CELL allot_array_2(CELL v1, CELL v2); -CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4); +cell allot_array_1(cell obj); +cell allot_array_2(cell v1, cell v2); +cell allot_array_4(cell v1, cell v2, cell v3, cell v4); PRIMITIVE(array); PRIMITIVE(resize_array); struct growable_array { - CELL count; - gc_root array; + cell count; + gc_root elements; - growable_array() : count(0), array(allot_array(2,F)) {} + growable_array() : count(0), elements(allot_array(2,F)) {} - void add(CELL elt); + void add(cell elt); void trim(); }; diff --git a/vm/bignum.cpp b/vm/bignum.cpp index f5f9091750..c487186da0 100755 --- a/vm/bignum.cpp +++ b/vm/bignum.cpp @@ -62,7 +62,7 @@ namespace factor /* Exports */ int -bignum_equal_p(F_BIGNUM * x, F_BIGNUM * y) +bignum_equal_p(bignum * x, bignum * y) { return ((BIGNUM_ZERO_P (x)) @@ -75,7 +75,7 @@ bignum_equal_p(F_BIGNUM * x, F_BIGNUM * y) } enum bignum_comparison -bignum_compare(F_BIGNUM * x, F_BIGNUM * y) +bignum_compare(bignum * x, bignum * y) { return ((BIGNUM_ZERO_P (x)) @@ -98,8 +98,8 @@ bignum_compare(F_BIGNUM * x, F_BIGNUM * y) } /* allocates memory */ -F_BIGNUM * -bignum_add(F_BIGNUM * x, F_BIGNUM * y) +bignum * +bignum_add(bignum * x, bignum * y) { return ((BIGNUM_ZERO_P (x)) @@ -116,8 +116,8 @@ bignum_add(F_BIGNUM * x, F_BIGNUM * y) } /* allocates memory */ -F_BIGNUM * -bignum_subtract(F_BIGNUM * x, F_BIGNUM * y) +bignum * +bignum_subtract(bignum * x, bignum * y) { return ((BIGNUM_ZERO_P (x)) @@ -136,8 +136,8 @@ bignum_subtract(F_BIGNUM * x, F_BIGNUM * y) } /* allocates memory */ -F_BIGNUM * -bignum_multiply(F_BIGNUM * x, F_BIGNUM * y) +bignum * +bignum_multiply(bignum * x, bignum * y) { bignum_length_type x_length = (BIGNUM_LENGTH (x)); bignum_length_type y_length = (BIGNUM_LENGTH (y)); @@ -170,8 +170,8 @@ bignum_multiply(F_BIGNUM * x, F_BIGNUM * y) /* allocates memory */ void -bignum_divide(F_BIGNUM * numerator, F_BIGNUM * denominator, - F_BIGNUM * * quotient, F_BIGNUM * * remainder) +bignum_divide(bignum * numerator, bignum * denominator, + bignum * * quotient, bignum * * remainder) { if (BIGNUM_ZERO_P (denominator)) { @@ -242,8 +242,8 @@ bignum_divide(F_BIGNUM * numerator, F_BIGNUM * denominator, } /* allocates memory */ -F_BIGNUM * -bignum_quotient(F_BIGNUM * numerator, F_BIGNUM * denominator) +bignum * +bignum_quotient(bignum * numerator, bignum * denominator) { if (BIGNUM_ZERO_P (denominator)) { @@ -266,7 +266,7 @@ bignum_quotient(F_BIGNUM * numerator, F_BIGNUM * denominator) case bignum_comparison_greater: default: /* to appease gcc -Wall */ { - F_BIGNUM * quotient; + bignum * quotient; if ((BIGNUM_LENGTH (denominator)) == 1) { bignum_digit_type digit = (BIGNUM_REF (denominator, 0)); @@ -275,18 +275,18 @@ bignum_quotient(F_BIGNUM * numerator, F_BIGNUM * denominator) if (digit < BIGNUM_RADIX_ROOT) bignum_divide_unsigned_small_denominator (numerator, digit, - ("ient), ((F_BIGNUM * *) 0), + ("ient), ((bignum * *) 0), q_negative_p, 0); else bignum_divide_unsigned_medium_denominator (numerator, digit, - ("ient), ((F_BIGNUM * *) 0), + ("ient), ((bignum * *) 0), q_negative_p, 0); } else bignum_divide_unsigned_large_denominator (numerator, denominator, - ("ient), ((F_BIGNUM * *) 0), + ("ient), ((bignum * *) 0), q_negative_p, 0); return (quotient); } @@ -295,8 +295,8 @@ bignum_quotient(F_BIGNUM * numerator, F_BIGNUM * denominator) } /* allocates memory */ -F_BIGNUM * -bignum_remainder(F_BIGNUM * numerator, F_BIGNUM * denominator) +bignum * +bignum_remainder(bignum * numerator, bignum * denominator) { if (BIGNUM_ZERO_P (denominator)) { @@ -314,7 +314,7 @@ bignum_remainder(F_BIGNUM * numerator, F_BIGNUM * denominator) case bignum_comparison_greater: default: /* to appease gcc -Wall */ { - F_BIGNUM * remainder; + bignum * remainder; if ((BIGNUM_LENGTH (denominator)) == 1) { bignum_digit_type digit = (BIGNUM_REF (denominator, 0)); @@ -326,13 +326,13 @@ bignum_remainder(F_BIGNUM * numerator, F_BIGNUM * denominator) (numerator, digit, (BIGNUM_NEGATIVE_P (numerator)))); bignum_divide_unsigned_medium_denominator (numerator, digit, - ((F_BIGNUM * *) 0), (&remainder), + ((bignum * *) 0), (&remainder), 0, (BIGNUM_NEGATIVE_P (numerator))); } else bignum_divide_unsigned_large_denominator (numerator, denominator, - ((F_BIGNUM * *) 0), (&remainder), + ((bignum * *) 0), (&remainder), 0, (BIGNUM_NEGATIVE_P (numerator))); return (remainder); } @@ -340,7 +340,7 @@ bignum_remainder(F_BIGNUM * numerator, F_BIGNUM * denominator) } #define FOO_TO_BIGNUM(name,type,utype) \ - F_BIGNUM * name##_to_bignum(type n) \ + bignum * name##_to_bignum(type n) \ { \ int negative_p; \ bignum_digit_type result_digits [BIGNUM_DIGITS_FOR(type)]; \ @@ -359,7 +359,7 @@ bignum_remainder(F_BIGNUM * numerator, F_BIGNUM * denominator) while (accumulator != 0); \ } \ { \ - F_BIGNUM * result = \ + bignum * result = \ (allot_bignum ((end_digits - result_digits), negative_p)); \ bignum_digit_type * scan_digits = result_digits; \ bignum_digit_type * scan_result = (BIGNUM_START_PTR (result)); \ @@ -370,13 +370,13 @@ bignum_remainder(F_BIGNUM * numerator, F_BIGNUM * denominator) } /* all below allocate memory */ -FOO_TO_BIGNUM(cell,CELL,CELL) -FOO_TO_BIGNUM(fixnum,F_FIXNUM,CELL) +FOO_TO_BIGNUM(cell,cell,cell) +FOO_TO_BIGNUM(fixnum,fixnum,cell) FOO_TO_BIGNUM(long_long,s64,u64) FOO_TO_BIGNUM(ulong_long,u64,u64) #define BIGNUM_TO_FOO(name,type,utype) \ - type bignum_to_##name(F_BIGNUM * bignum) \ + type bignum_to_##name(bignum * bignum) \ { \ if (BIGNUM_ZERO_P (bignum)) \ return (0); \ @@ -391,13 +391,13 @@ FOO_TO_BIGNUM(ulong_long,u64,u64) } /* all of the below allocate memory */ -BIGNUM_TO_FOO(cell,CELL,CELL); -BIGNUM_TO_FOO(fixnum,F_FIXNUM,CELL); +BIGNUM_TO_FOO(cell,cell,cell); +BIGNUM_TO_FOO(fixnum,fixnum,cell); BIGNUM_TO_FOO(long_long,s64,u64) BIGNUM_TO_FOO(ulong_long,u64,u64) double -bignum_to_double(F_BIGNUM * bignum) +bignum_to_double(bignum * bignum) { if (BIGNUM_ZERO_P (bignum)) return (0); @@ -422,7 +422,7 @@ bignum_to_double(F_BIGNUM * bignum) /* allocates memory */ #define inf std::numeric_limits::infinity() -F_BIGNUM * +bignum * double_to_bignum(double x) { if (x == inf || x == -inf || x != x) return (BIGNUM_ZERO ()); @@ -433,13 +433,13 @@ double_to_bignum(double x) if (significand < 0) significand = (-significand); { bignum_length_type length = (BIGNUM_BITS_TO_DIGITS (exponent)); - F_BIGNUM * result = (allot_bignum (length, (x < 0))); + bignum * result = (allot_bignum (length, (x < 0))); bignum_digit_type * start = (BIGNUM_START_PTR (result)); bignum_digit_type * scan = (start + length); bignum_digit_type digit; int odd_bits = (exponent % BIGNUM_DIGIT_LENGTH); if (odd_bits > 0) - DTB_WRITE_DIGIT ((F_FIXNUM)1 << odd_bits); + DTB_WRITE_DIGIT ((fixnum)1 << odd_bits); while (start < scan) { if (significand == 0) @@ -459,7 +459,7 @@ double_to_bignum(double x) /* Comparisons */ int -bignum_equal_p_unsigned(F_BIGNUM * x, F_BIGNUM * y) +bignum_equal_p_unsigned(bignum * x, bignum * y) { bignum_length_type length = (BIGNUM_LENGTH (x)); if (length != (BIGNUM_LENGTH (y))) @@ -477,7 +477,7 @@ bignum_equal_p_unsigned(F_BIGNUM * x, F_BIGNUM * y) } enum bignum_comparison -bignum_compare_unsigned(F_BIGNUM * x, F_BIGNUM * y) +bignum_compare_unsigned(bignum * x, bignum * y) { bignum_length_type x_length = (BIGNUM_LENGTH (x)); bignum_length_type y_length = (BIGNUM_LENGTH (y)); @@ -505,21 +505,21 @@ bignum_compare_unsigned(F_BIGNUM * x, F_BIGNUM * y) /* Addition */ /* allocates memory */ -F_BIGNUM * -bignum_add_unsigned(F_BIGNUM * x, F_BIGNUM * y, int negative_p) +bignum * +bignum_add_unsigned(bignum * x, bignum * y, int negative_p) { GC_BIGNUM(x); GC_BIGNUM(y); if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x))) { - F_BIGNUM * z = x; + bignum * z = x; x = y; y = z; } { bignum_length_type x_length = (BIGNUM_LENGTH (x)); - F_BIGNUM * r = (allot_bignum ((x_length + 1), negative_p)); + bignum * r = (allot_bignum ((x_length + 1), negative_p)); bignum_digit_type sum; bignum_digit_type carry = 0; @@ -573,8 +573,8 @@ bignum_add_unsigned(F_BIGNUM * x, F_BIGNUM * y, int negative_p) /* Subtraction */ /* allocates memory */ -F_BIGNUM * -bignum_subtract_unsigned(F_BIGNUM * x, F_BIGNUM * y) +bignum * +bignum_subtract_unsigned(bignum * x, bignum * y) { GC_BIGNUM(x); GC_BIGNUM(y); @@ -585,7 +585,7 @@ bignum_subtract_unsigned(F_BIGNUM * x, F_BIGNUM * y) return (BIGNUM_ZERO ()); case bignum_comparison_less: { - F_BIGNUM * z = x; + bignum * z = x; x = y; y = z; } @@ -598,7 +598,7 @@ bignum_subtract_unsigned(F_BIGNUM * x, F_BIGNUM * y) { bignum_length_type x_length = (BIGNUM_LENGTH (x)); - F_BIGNUM * r = (allot_bignum (x_length, negative_p)); + bignum * r = (allot_bignum (x_length, negative_p)); bignum_digit_type difference; bignum_digit_type borrow = 0; @@ -652,14 +652,14 @@ bignum_subtract_unsigned(F_BIGNUM * x, F_BIGNUM * y) where R == BIGNUM_RADIX_ROOT */ /* allocates memory */ -F_BIGNUM * -bignum_multiply_unsigned(F_BIGNUM * x, F_BIGNUM * y, int negative_p) +bignum * +bignum_multiply_unsigned(bignum * x, bignum * y, int negative_p) { GC_BIGNUM(x); GC_BIGNUM(y); if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x))) { - F_BIGNUM * z = x; + bignum * z = x; x = y; y = z; } @@ -675,7 +675,7 @@ bignum_multiply_unsigned(F_BIGNUM * x, F_BIGNUM * y, int negative_p) bignum_length_type x_length = (BIGNUM_LENGTH (x)); bignum_length_type y_length = (BIGNUM_LENGTH (y)); - F_BIGNUM * r = + bignum * r = (allot_bignum_zeroed ((x_length + y_length), negative_p)); bignum_digit_type * scan_x = (BIGNUM_START_PTR (x)); @@ -724,15 +724,15 @@ bignum_multiply_unsigned(F_BIGNUM * x, F_BIGNUM * y, int negative_p) } /* allocates memory */ -F_BIGNUM * -bignum_multiply_unsigned_small_factor(F_BIGNUM * x, bignum_digit_type y, +bignum * +bignum_multiply_unsigned_small_factor(bignum * x, bignum_digit_type y, int negative_p) { GC_BIGNUM(x); bignum_length_type length_x = (BIGNUM_LENGTH (x)); - F_BIGNUM * p = (allot_bignum ((length_x + 1), negative_p)); + bignum * p = (allot_bignum ((length_x + 1), negative_p)); bignum_destructive_copy (x, p); (BIGNUM_REF (p, length_x)) = 0; @@ -741,7 +741,7 @@ bignum_multiply_unsigned_small_factor(F_BIGNUM * x, bignum_digit_type y, } void -bignum_destructive_add(F_BIGNUM * bignum, bignum_digit_type n) +bignum_destructive_add(bignum * bignum, bignum_digit_type n) { bignum_digit_type * scan = (BIGNUM_START_PTR (bignum)); bignum_digit_type digit; @@ -765,7 +765,7 @@ bignum_destructive_add(F_BIGNUM * bignum, bignum_digit_type n) } void -bignum_destructive_scale_up(F_BIGNUM * bignum, bignum_digit_type factor) +bignum_destructive_scale_up(bignum * bignum, bignum_digit_type factor) { bignum_digit_type carry = 0; bignum_digit_type * scan = (BIGNUM_START_PTR (bignum)); @@ -803,10 +803,10 @@ bignum_destructive_scale_up(F_BIGNUM * bignum, bignum_digit_type factor) /* allocates memory */ void -bignum_divide_unsigned_large_denominator(F_BIGNUM * numerator, - F_BIGNUM * denominator, - F_BIGNUM * * quotient, - F_BIGNUM * * remainder, +bignum_divide_unsigned_large_denominator(bignum * numerator, + bignum * denominator, + bignum * * quotient, + bignum * * remainder, int q_negative_p, int r_negative_p) { @@ -815,13 +815,13 @@ bignum_divide_unsigned_large_denominator(F_BIGNUM * numerator, bignum_length_type length_n = ((BIGNUM_LENGTH (numerator)) + 1); bignum_length_type length_d = (BIGNUM_LENGTH (denominator)); - F_BIGNUM * q = - ((quotient != ((F_BIGNUM * *) 0)) + bignum * q = + ((quotient != ((bignum * *) 0)) ? (allot_bignum ((length_n - length_d), q_negative_p)) : BIGNUM_OUT_OF_BAND); GC_BIGNUM(q); - F_BIGNUM * u = (allot_bignum (length_n, r_negative_p)); + bignum * u = (allot_bignum (length_n, r_negative_p)); GC_BIGNUM(u); int shift = 0; @@ -842,12 +842,12 @@ bignum_divide_unsigned_large_denominator(F_BIGNUM * numerator, } else { - F_BIGNUM * v = (allot_bignum (length_d, 0)); + bignum * v = (allot_bignum (length_d, 0)); bignum_destructive_normalization (numerator, u, shift); bignum_destructive_normalization (denominator, v, shift); bignum_divide_unsigned_normalized (u, v, q); - if (remainder != ((F_BIGNUM * *) 0)) + if (remainder != ((bignum * *) 0)) bignum_destructive_unnormalization (u, shift); } @@ -856,17 +856,17 @@ bignum_divide_unsigned_large_denominator(F_BIGNUM * numerator, u = bignum_trim (u); - if (quotient != ((F_BIGNUM * *) 0)) + if (quotient != ((bignum * *) 0)) (*quotient) = q; - if (remainder != ((F_BIGNUM * *) 0)) + if (remainder != ((bignum * *) 0)) (*remainder) = u; return; } void -bignum_divide_unsigned_normalized(F_BIGNUM * u, F_BIGNUM * v, F_BIGNUM * q) +bignum_divide_unsigned_normalized(bignum * u, bignum * v, bignum * q) { bignum_length_type u_length = (BIGNUM_LENGTH (u)); bignum_length_type v_length = (BIGNUM_LENGTH (v)); @@ -1021,10 +1021,10 @@ bignum_divide_subtract(bignum_digit_type * v_start, /* allocates memory */ void -bignum_divide_unsigned_medium_denominator(F_BIGNUM * numerator, +bignum_divide_unsigned_medium_denominator(bignum * numerator, bignum_digit_type denominator, - F_BIGNUM * * quotient, - F_BIGNUM * * remainder, + bignum * * quotient, + bignum * * remainder, int q_negative_p, int r_negative_p) { @@ -1032,7 +1032,7 @@ bignum_divide_unsigned_medium_denominator(F_BIGNUM * numerator, bignum_length_type length_n = (BIGNUM_LENGTH (numerator)); bignum_length_type length_q; - F_BIGNUM * q = NULL; + bignum * q = NULL; GC_BIGNUM(q); int shift = 0; @@ -1070,7 +1070,7 @@ bignum_divide_unsigned_medium_denominator(F_BIGNUM * numerator, q = bignum_trim (q); - if (remainder != ((F_BIGNUM * *) 0)) + if (remainder != ((bignum * *) 0)) { if (shift != 0) r >>= shift; @@ -1078,14 +1078,14 @@ bignum_divide_unsigned_medium_denominator(F_BIGNUM * numerator, (*remainder) = (bignum_digit_to_bignum (r, r_negative_p)); } - if (quotient != ((F_BIGNUM * *) 0)) + if (quotient != ((bignum * *) 0)) (*quotient) = q; } return; } void -bignum_destructive_normalization(F_BIGNUM * source, F_BIGNUM * target, +bignum_destructive_normalization(bignum * source, bignum * target, int shift_left) { bignum_digit_type digit; @@ -1095,7 +1095,7 @@ bignum_destructive_normalization(F_BIGNUM * source, F_BIGNUM * target, bignum_digit_type * end_source = (scan_source + (BIGNUM_LENGTH (source))); bignum_digit_type * end_target = (scan_target + (BIGNUM_LENGTH (target))); int shift_right = (BIGNUM_DIGIT_LENGTH - shift_left); - bignum_digit_type mask = (((CELL)1 << shift_right) - 1); + bignum_digit_type mask = (((cell)1 << shift_right) - 1); while (scan_source < end_source) { digit = (*scan_source++); @@ -1110,14 +1110,14 @@ bignum_destructive_normalization(F_BIGNUM * source, F_BIGNUM * target, } void -bignum_destructive_unnormalization(F_BIGNUM * bignum, int shift_right) +bignum_destructive_unnormalization(bignum * bignum, int shift_right) { bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); bignum_digit_type digit; bignum_digit_type carry = 0; int shift_left = (BIGNUM_DIGIT_LENGTH - shift_right); - bignum_digit_type mask = (((F_FIXNUM)1 << shift_right) - 1); + bignum_digit_type mask = (((fixnum)1 << shift_right) - 1); while (start < scan) { digit = (*--scan); @@ -1265,23 +1265,23 @@ bignum_digit_divide_subtract(bignum_digit_type v1, bignum_digit_type v2, /* allocates memory */ void -bignum_divide_unsigned_small_denominator(F_BIGNUM * numerator, +bignum_divide_unsigned_small_denominator(bignum * numerator, bignum_digit_type denominator, - F_BIGNUM * * quotient, - F_BIGNUM * * remainder, + bignum * * quotient, + bignum * * remainder, int q_negative_p, int r_negative_p) { GC_BIGNUM(numerator); - F_BIGNUM * q = (bignum_new_sign (numerator, q_negative_p)); + bignum * q = (bignum_new_sign (numerator, q_negative_p)); GC_BIGNUM(q); bignum_digit_type r = (bignum_destructive_scale_down (q, denominator)); q = (bignum_trim (q)); - if (remainder != ((F_BIGNUM * *) 0)) + if (remainder != ((bignum * *) 0)) (*remainder) = (bignum_digit_to_bignum (r, r_negative_p)); (*quotient) = q; @@ -1294,7 +1294,7 @@ bignum_divide_unsigned_small_denominator(F_BIGNUM * numerator, that all digits are < BIGNUM_RADIX. */ bignum_digit_type -bignum_destructive_scale_down(F_BIGNUM * bignum, bignum_digit_type denominator) +bignum_destructive_scale_down(bignum * bignum, bignum_digit_type denominator) { bignum_digit_type numerator; bignum_digit_type remainder = 0; @@ -1317,9 +1317,9 @@ bignum_destructive_scale_down(F_BIGNUM * bignum, bignum_digit_type denominator) } /* allocates memory */ -F_BIGNUM * +bignum * bignum_remainder_unsigned_small_denominator( - F_BIGNUM * n, bignum_digit_type d, int negative_p) + bignum * n, bignum_digit_type d, int negative_p) { bignum_digit_type two_digits; bignum_digit_type * start = (BIGNUM_START_PTR (n)); @@ -1338,34 +1338,34 @@ bignum_remainder_unsigned_small_denominator( } /* allocates memory */ -F_BIGNUM * +bignum * bignum_digit_to_bignum(bignum_digit_type digit, int negative_p) { if (digit == 0) return (BIGNUM_ZERO ()); else { - F_BIGNUM * result = (allot_bignum (1, negative_p)); + bignum * result = (allot_bignum (1, negative_p)); (BIGNUM_REF (result, 0)) = digit; return (result); } } /* allocates memory */ -F_BIGNUM * +bignum * allot_bignum(bignum_length_type length, int negative_p) { BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX)); - F_BIGNUM * result = allot_array_internal(length + 1); + bignum * result = allot_array_internal(length + 1); BIGNUM_SET_NEGATIVE_P (result, negative_p); return (result); } /* allocates memory */ -F_BIGNUM * +bignum * allot_bignum_zeroed(bignum_length_type length, int negative_p) { - F_BIGNUM * result = allot_bignum(length,negative_p); + bignum * result = allot_bignum(length,negative_p); bignum_digit_type * scan = (BIGNUM_START_PTR (result)); bignum_digit_type * end = (scan + length); while (scan < end) @@ -1377,8 +1377,8 @@ allot_bignum_zeroed(bignum_length_type length, int negative_p) source = reallot_array(source,length + 1) /* allocates memory */ -F_BIGNUM * -bignum_shorten_length(F_BIGNUM * bignum, bignum_length_type length) +bignum * +bignum_shorten_length(bignum * bignum, bignum_length_type length) { bignum_length_type current_length = (BIGNUM_LENGTH (bignum)); BIGNUM_ASSERT ((length >= 0) || (length <= current_length)); @@ -1391,8 +1391,8 @@ bignum_shorten_length(F_BIGNUM * bignum, bignum_length_type length) } /* allocates memory */ -F_BIGNUM * -bignum_trim(F_BIGNUM * bignum) +bignum * +bignum_trim(bignum * bignum) { bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); bignum_digit_type * end = (start + (BIGNUM_LENGTH (bignum))); @@ -1412,33 +1412,33 @@ bignum_trim(F_BIGNUM * bignum) /* Copying */ /* allocates memory */ -F_BIGNUM * -bignum_new_sign(F_BIGNUM * bignum, int negative_p) +bignum * +bignum_new_sign(bignum * x, int negative_p) { - GC_BIGNUM(bignum); - F_BIGNUM * result = (allot_bignum ((BIGNUM_LENGTH (bignum)), negative_p)); + GC_BIGNUM(x); + bignum * result = (allot_bignum ((BIGNUM_LENGTH (x)), negative_p)); - bignum_destructive_copy (bignum, result); + bignum_destructive_copy (x, result); return (result); } /* allocates memory */ -F_BIGNUM * -bignum_maybe_new_sign(F_BIGNUM * bignum, int negative_p) +bignum * +bignum_maybe_new_sign(bignum * x, int negative_p) { - if ((BIGNUM_NEGATIVE_P (bignum)) ? negative_p : (! negative_p)) - return (bignum); + if ((BIGNUM_NEGATIVE_P (x)) ? negative_p : (! negative_p)) + return (x); else { - F_BIGNUM * result = - (allot_bignum ((BIGNUM_LENGTH (bignum)), negative_p)); - bignum_destructive_copy (bignum, result); + bignum * result = + (allot_bignum ((BIGNUM_LENGTH (x)), negative_p)); + bignum_destructive_copy (x, result); return (result); } } void -bignum_destructive_copy(F_BIGNUM * source, F_BIGNUM * target) +bignum_destructive_copy(bignum * source, bignum * target) { bignum_digit_type * scan_source = (BIGNUM_START_PTR (source)); bignum_digit_type * end_source = @@ -1454,15 +1454,15 @@ bignum_destructive_copy(F_BIGNUM * source, F_BIGNUM * target) */ /* allocates memory */ -F_BIGNUM * -bignum_bitwise_not(F_BIGNUM * x) +bignum * +bignum_bitwise_not(bignum * x) { return bignum_subtract(BIGNUM_ONE(1), x); } /* allocates memory */ -F_BIGNUM * -bignum_arithmetic_shift(F_BIGNUM * arg1, F_FIXNUM n) +bignum * +bignum_arithmetic_shift(bignum * arg1, fixnum n) { if (BIGNUM_NEGATIVE_P(arg1) && n < 0) return bignum_bitwise_not(bignum_magnitude_ash(bignum_bitwise_not(arg1), n)); @@ -1475,8 +1475,8 @@ bignum_arithmetic_shift(F_BIGNUM * arg1, F_FIXNUM n) #define XOR_OP 2 /* allocates memory */ -F_BIGNUM * -bignum_bitwise_and(F_BIGNUM * arg1, F_BIGNUM * arg2) +bignum * +bignum_bitwise_and(bignum * arg1, bignum * arg2) { return( (BIGNUM_NEGATIVE_P (arg1)) @@ -1490,8 +1490,8 @@ bignum_bitwise_and(F_BIGNUM * arg1, F_BIGNUM * arg2) } /* allocates memory */ -F_BIGNUM * -bignum_bitwise_ior(F_BIGNUM * arg1, F_BIGNUM * arg2) +bignum * +bignum_bitwise_ior(bignum * arg1, bignum * arg2) { return( (BIGNUM_NEGATIVE_P (arg1)) @@ -1505,8 +1505,8 @@ bignum_bitwise_ior(F_BIGNUM * arg1, F_BIGNUM * arg2) } /* allocates memory */ -F_BIGNUM * -bignum_bitwise_xor(F_BIGNUM * arg1, F_BIGNUM * arg2) +bignum * +bignum_bitwise_xor(bignum * arg1, bignum * arg2) { return( (BIGNUM_NEGATIVE_P (arg1)) @@ -1522,17 +1522,17 @@ bignum_bitwise_xor(F_BIGNUM * arg1, F_BIGNUM * arg2) /* allocates memory */ /* ash for the magnitude */ /* assume arg1 is a big number, n is a long */ -F_BIGNUM * -bignum_magnitude_ash(F_BIGNUM * arg1, F_FIXNUM n) +bignum * +bignum_magnitude_ash(bignum * arg1, fixnum n) { GC_BIGNUM(arg1); - F_BIGNUM * result = NULL; + bignum * result = NULL; bignum_digit_type *scan1; bignum_digit_type *scanr; bignum_digit_type *end; - F_FIXNUM digit_offset,bit_offset; + fixnum digit_offset,bit_offset; if (BIGNUM_ZERO_P (arg1)) return (arg1); @@ -1584,12 +1584,12 @@ bignum_magnitude_ash(F_BIGNUM * arg1, F_FIXNUM n) } /* allocates memory */ -F_BIGNUM * -bignum_pospos_bitwise_op(int op, F_BIGNUM * arg1, F_BIGNUM * arg2) +bignum * +bignum_pospos_bitwise_op(int op, bignum * arg1, bignum * arg2) { GC_BIGNUM(arg1); GC_BIGNUM(arg2); - F_BIGNUM * result; + bignum * result; bignum_length_type max_length; bignum_digit_type *scan1, *end1, digit1; @@ -1619,12 +1619,12 @@ bignum_pospos_bitwise_op(int op, F_BIGNUM * arg1, F_BIGNUM * arg2) } /* allocates memory */ -F_BIGNUM * -bignum_posneg_bitwise_op(int op, F_BIGNUM * arg1, F_BIGNUM * arg2) +bignum * +bignum_posneg_bitwise_op(int op, bignum * arg1, bignum * arg2) { GC_BIGNUM(arg1); GC_BIGNUM(arg2); - F_BIGNUM * result; + bignum * result; bignum_length_type max_length; bignum_digit_type *scan1, *end1, digit1; @@ -1672,12 +1672,12 @@ bignum_posneg_bitwise_op(int op, F_BIGNUM * arg1, F_BIGNUM * arg2) } /* allocates memory */ -F_BIGNUM * -bignum_negneg_bitwise_op(int op, F_BIGNUM * arg1, F_BIGNUM * arg2) +bignum * +bignum_negneg_bitwise_op(int op, bignum * arg1, bignum * arg2) { GC_BIGNUM(arg1); GC_BIGNUM(arg2); - F_BIGNUM * result; + bignum * result; bignum_length_type max_length; bignum_digit_type *scan1, *end1, digit1, carry1; @@ -1733,7 +1733,7 @@ bignum_negneg_bitwise_op(int op, F_BIGNUM * arg1, F_BIGNUM * arg2) } void -bignum_negate_magnitude(F_BIGNUM * arg) +bignum_negate_magnitude(bignum * arg) { bignum_digit_type *scan; bignum_digit_type *end; @@ -1761,15 +1761,15 @@ bignum_negate_magnitude(F_BIGNUM * arg) } /* Allocates memory */ -F_BIGNUM * -bignum_integer_length(F_BIGNUM * bignum) +bignum * +bignum_integer_length(bignum * x) { - GC_BIGNUM(bignum); + GC_BIGNUM(x); - bignum_length_type index = ((BIGNUM_LENGTH (bignum)) - 1); - bignum_digit_type digit = (BIGNUM_REF (bignum, index)); + bignum_length_type index = ((BIGNUM_LENGTH (x)) - 1); + bignum_digit_type digit = (BIGNUM_REF (x, index)); - F_BIGNUM * result = (allot_bignum (2, 0)); + bignum * result = (allot_bignum (2, 0)); (BIGNUM_REF (result, 0)) = index; (BIGNUM_REF (result, 1)) = 0; @@ -1784,7 +1784,7 @@ bignum_integer_length(F_BIGNUM * bignum) /* Allocates memory */ int -bignum_logbitp(int shift, F_BIGNUM * arg) +bignum_logbitp(int shift, bignum * arg) { return((BIGNUM_NEGATIVE_P (arg)) ? !bignum_unsigned_logbitp (shift, bignum_bitwise_not (arg)) @@ -1792,7 +1792,7 @@ bignum_logbitp(int shift, F_BIGNUM * arg) } int -bignum_unsigned_logbitp(int shift, F_BIGNUM * bignum) +bignum_unsigned_logbitp(int shift, bignum * bignum) { bignum_length_type len = (BIGNUM_LENGTH (bignum)); int index = shift / BIGNUM_DIGIT_LENGTH; @@ -1800,12 +1800,12 @@ bignum_unsigned_logbitp(int shift, F_BIGNUM * bignum) return 0; bignum_digit_type digit = (BIGNUM_REF (bignum, index)); int p = shift % BIGNUM_DIGIT_LENGTH; - bignum_digit_type mask = ((F_FIXNUM)1) << p; + bignum_digit_type mask = ((fixnum)1) << p; return (digit & mask) ? 1 : 0; } /* Allocates memory */ -F_BIGNUM * +bignum * digit_stream_to_bignum(unsigned int n_digits, unsigned int (*producer)(unsigned int), unsigned int radix, @@ -1816,7 +1816,7 @@ digit_stream_to_bignum(unsigned int n_digits, return (BIGNUM_ZERO ()); if (n_digits == 1) { - F_FIXNUM digit = ((F_FIXNUM) ((*producer) (0))); + fixnum digit = ((fixnum) ((*producer) (0))); return (fixnum_to_bignum (negative_p ? (- digit) : digit)); } { @@ -1833,7 +1833,7 @@ digit_stream_to_bignum(unsigned int n_digits, length = (BIGNUM_BITS_TO_DIGITS (n_digits * log_radix)); } { - F_BIGNUM * result = (allot_bignum_zeroed (length, negative_p)); + bignum * result = (allot_bignum_zeroed (length, negative_p)); while ((n_digits--) > 0) { bignum_destructive_scale_up (result, ((bignum_digit_type) radix)); diff --git a/vm/bignum.hpp b/vm/bignum.hpp index f8058c9497..296f0dce4c 100644 --- a/vm/bignum.hpp +++ b/vm/bignum.hpp @@ -35,7 +35,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -#define BIGNUM_OUT_OF_BAND ((F_BIGNUM *) 0) +#define BIGNUM_OUT_OF_BAND ((bignum *) 0) enum bignum_comparison { @@ -44,86 +44,86 @@ enum bignum_comparison bignum_comparison_greater = 1 }; -int bignum_equal_p(F_BIGNUM *, F_BIGNUM *); -enum bignum_comparison bignum_compare(F_BIGNUM *, F_BIGNUM *); -F_BIGNUM * bignum_add(F_BIGNUM *, F_BIGNUM *); -F_BIGNUM * bignum_subtract(F_BIGNUM *, F_BIGNUM *); -F_BIGNUM * bignum_negate(F_BIGNUM *); -F_BIGNUM * bignum_multiply(F_BIGNUM *, F_BIGNUM *); +int bignum_equal_p(bignum *, bignum *); +enum bignum_comparison bignum_compare(bignum *, bignum *); +bignum * bignum_add(bignum *, bignum *); +bignum * bignum_subtract(bignum *, bignum *); +bignum * bignum_negate(bignum *); +bignum * bignum_multiply(bignum *, bignum *); void -bignum_divide(F_BIGNUM * numerator, F_BIGNUM * denominator, - F_BIGNUM * * quotient, F_BIGNUM * * remainder); -F_BIGNUM * bignum_quotient(F_BIGNUM *, F_BIGNUM *); -F_BIGNUM * bignum_remainder(F_BIGNUM *, F_BIGNUM *); -F_BIGNUM * fixnum_to_bignum(F_FIXNUM); -F_BIGNUM * cell_to_bignum(CELL); -F_BIGNUM * long_long_to_bignum(s64 n); -F_BIGNUM * ulong_long_to_bignum(u64 n); -F_FIXNUM bignum_to_fixnum(F_BIGNUM *); -CELL bignum_to_cell(F_BIGNUM *); -s64 bignum_to_long_long(F_BIGNUM *); -u64 bignum_to_ulong_long(F_BIGNUM *); -F_BIGNUM * double_to_bignum(double); -double bignum_to_double(F_BIGNUM *); +bignum_divide(bignum * numerator, bignum * denominator, + bignum * * quotient, bignum * * remainder); +bignum * bignum_quotient(bignum *, bignum *); +bignum * bignum_remainder(bignum *, bignum *); +bignum * fixnum_to_bignum(fixnum); +bignum * cell_to_bignum(cell); +bignum * long_long_to_bignum(s64 n); +bignum * ulong_long_to_bignum(u64 n); +fixnum bignum_to_fixnum(bignum *); +cell bignum_to_cell(bignum *); +s64 bignum_to_long_long(bignum *); +u64 bignum_to_ulong_long(bignum *); +bignum * double_to_bignum(double); +double bignum_to_double(bignum *); /* Added bitwise operators. */ -F_BIGNUM * bignum_bitwise_not(F_BIGNUM *); -F_BIGNUM * bignum_arithmetic_shift(F_BIGNUM *, F_FIXNUM); -F_BIGNUM * bignum_bitwise_and(F_BIGNUM *, F_BIGNUM *); -F_BIGNUM * bignum_bitwise_ior(F_BIGNUM *, F_BIGNUM *); -F_BIGNUM * bignum_bitwise_xor(F_BIGNUM *, F_BIGNUM *); +bignum * bignum_bitwise_not(bignum *); +bignum * bignum_arithmetic_shift(bignum *, fixnum); +bignum * bignum_bitwise_and(bignum *, bignum *); +bignum * bignum_bitwise_ior(bignum *, bignum *); +bignum * bignum_bitwise_xor(bignum *, bignum *); /* Forward references */ -int bignum_equal_p_unsigned(F_BIGNUM *, F_BIGNUM *); -enum bignum_comparison bignum_compare_unsigned(F_BIGNUM *, F_BIGNUM *); -F_BIGNUM * bignum_add_unsigned(F_BIGNUM *, F_BIGNUM *, int); -F_BIGNUM * bignum_subtract_unsigned(F_BIGNUM *, F_BIGNUM *); -F_BIGNUM * bignum_multiply_unsigned(F_BIGNUM *, F_BIGNUM *, int); -F_BIGNUM * bignum_multiply_unsigned_small_factor - (F_BIGNUM *, bignum_digit_type, int); -void bignum_destructive_scale_up(F_BIGNUM *, bignum_digit_type); -void bignum_destructive_add(F_BIGNUM *, bignum_digit_type); +int bignum_equal_p_unsigned(bignum *, bignum *); +enum bignum_comparison bignum_compare_unsigned(bignum *, bignum *); +bignum * bignum_add_unsigned(bignum *, bignum *, int); +bignum * bignum_subtract_unsigned(bignum *, bignum *); +bignum * bignum_multiply_unsigned(bignum *, bignum *, int); +bignum * bignum_multiply_unsigned_small_factor + (bignum *, bignum_digit_type, int); +void bignum_destructive_scale_up(bignum *, bignum_digit_type); +void bignum_destructive_add(bignum *, bignum_digit_type); void bignum_divide_unsigned_large_denominator - (F_BIGNUM *, F_BIGNUM *, F_BIGNUM * *, F_BIGNUM * *, int, int); -void bignum_destructive_normalization(F_BIGNUM *, F_BIGNUM *, int); -void bignum_destructive_unnormalization(F_BIGNUM *, int); -void bignum_divide_unsigned_normalized(F_BIGNUM *, F_BIGNUM *, F_BIGNUM *); + (bignum *, bignum *, bignum * *, bignum * *, int, int); +void bignum_destructive_normalization(bignum *, bignum *, int); +void bignum_destructive_unnormalization(bignum *, int); +void bignum_divide_unsigned_normalized(bignum *, bignum *, bignum *); bignum_digit_type bignum_divide_subtract (bignum_digit_type *, bignum_digit_type *, bignum_digit_type, bignum_digit_type *); void bignum_divide_unsigned_medium_denominator - (F_BIGNUM *, bignum_digit_type, F_BIGNUM * *, F_BIGNUM * *, int, int); + (bignum *, bignum_digit_type, bignum * *, bignum * *, 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 - (F_BIGNUM *, bignum_digit_type, F_BIGNUM * *, F_BIGNUM * *, int, int); + (bignum *, bignum_digit_type, bignum * *, bignum * *, int, int); bignum_digit_type bignum_destructive_scale_down - (F_BIGNUM *, bignum_digit_type); -F_BIGNUM * bignum_remainder_unsigned_small_denominator - (F_BIGNUM *, bignum_digit_type, int); -F_BIGNUM * bignum_digit_to_bignum(bignum_digit_type, int); -F_BIGNUM * allot_bignum(bignum_length_type, int); -F_BIGNUM * allot_bignum_zeroed(bignum_length_type, int); -F_BIGNUM * bignum_shorten_length(F_BIGNUM *, bignum_length_type); -F_BIGNUM * bignum_trim(F_BIGNUM *); -F_BIGNUM * bignum_new_sign(F_BIGNUM *, int); -F_BIGNUM * bignum_maybe_new_sign(F_BIGNUM *, int); -void bignum_destructive_copy(F_BIGNUM *, F_BIGNUM *); + (bignum *, bignum_digit_type); +bignum * bignum_remainder_unsigned_small_denominator + (bignum *, bignum_digit_type, int); +bignum * bignum_digit_to_bignum(bignum_digit_type, int); +bignum * allot_bignum(bignum_length_type, int); +bignum * allot_bignum_zeroed(bignum_length_type, int); +bignum * bignum_shorten_length(bignum *, bignum_length_type); +bignum * bignum_trim(bignum *); +bignum * bignum_new_sign(bignum *, int); +bignum * bignum_maybe_new_sign(bignum *, int); +void bignum_destructive_copy(bignum *, bignum *); /* Added for bitwise operations. */ -F_BIGNUM * bignum_magnitude_ash(F_BIGNUM * arg1, F_FIXNUM n); -F_BIGNUM * bignum_pospos_bitwise_op(int op, F_BIGNUM *, F_BIGNUM *); -F_BIGNUM * bignum_posneg_bitwise_op(int op, F_BIGNUM *, F_BIGNUM *); -F_BIGNUM * bignum_negneg_bitwise_op(int op, F_BIGNUM *, F_BIGNUM *); -void bignum_negate_magnitude(F_BIGNUM *); +bignum * bignum_magnitude_ash(bignum * arg1, fixnum n); +bignum * bignum_pospos_bitwise_op(int op, bignum *, bignum *); +bignum * bignum_posneg_bitwise_op(int op, bignum *, bignum *); +bignum * bignum_negneg_bitwise_op(int op, bignum *, bignum *); +void bignum_negate_magnitude(bignum *); -F_BIGNUM * bignum_integer_length(F_BIGNUM * arg1); -int bignum_unsigned_logbitp(int shift, F_BIGNUM * bignum); -int bignum_logbitp(int shift, F_BIGNUM * arg); -F_BIGNUM * digit_stream_to_bignum(unsigned int n_digits, +bignum * bignum_integer_length(bignum * arg1); +int bignum_unsigned_logbitp(int shift, bignum * bignum); +int bignum_logbitp(int shift, bignum * arg); +bignum * digit_stream_to_bignum(unsigned int n_digits, unsigned int (*producer)(unsigned int), unsigned int radix, int negative_p); diff --git a/vm/bignumint.hpp b/vm/bignumint.hpp index deed0bd910..0b743b35a4 100644 --- a/vm/bignumint.hpp +++ b/vm/bignumint.hpp @@ -45,8 +45,8 @@ namespace factor definition is `CHAR_BIT', which is defined in the Ansi C header file "limits.h". */ -typedef F_FIXNUM bignum_digit_type; -typedef F_FIXNUM bignum_length_type; +typedef fixnum bignum_digit_type; +typedef fixnum bignum_length_type; /* BIGNUM_TO_POINTER casts a bignum object to a digit array pointer. */ #define BIGNUM_TO_POINTER(bignum) ((bignum_digit_type *)(bignum + 1)) @@ -57,7 +57,7 @@ typedef F_FIXNUM bignum_length_type; #define BIGNUM_DIGIT_LENGTH (((sizeof (bignum_digit_type)) * CHAR_BIT) - 2) #define BIGNUM_HALF_DIGIT_LENGTH (BIGNUM_DIGIT_LENGTH / 2) -#define BIGNUM_RADIX (bignum_digit_type)(((CELL) 1) << BIGNUM_DIGIT_LENGTH) +#define BIGNUM_RADIX (bignum_digit_type)(((cell) 1) << BIGNUM_DIGIT_LENGTH) #define BIGNUM_RADIX_ROOT (((bignum_digit_type) 1) << BIGNUM_HALF_DIGIT_LENGTH) #define BIGNUM_DIGIT_MASK (BIGNUM_RADIX - 1) #define BIGNUM_HALF_DIGIT_MASK (BIGNUM_RADIX_ROOT - 1) @@ -78,9 +78,9 @@ typedef F_FIXNUM bignum_length_type; /* These definitions are here to facilitate caching of the constants 0, 1, and -1. */ -#define BIGNUM_ZERO() untag(bignum_zero) +#define BIGNUM_ZERO() untag(bignum_zero) #define BIGNUM_ONE(neg_p) \ - untag(neg_p ? bignum_neg_one : bignum_pos_one) + untag(neg_p ? bignum_neg_one : bignum_pos_one) #define HD_LOW(digit) ((digit) & BIGNUM_HALF_DIGIT_MASK) #define HD_HIGH(digit) ((digit) >> BIGNUM_HALF_DIGIT_LENGTH) diff --git a/vm/booleans.cpp b/vm/booleans.cpp index 9ff848058f..8407e10099 100644 --- a/vm/booleans.cpp +++ b/vm/booleans.cpp @@ -8,7 +8,7 @@ VM_C_API void box_boolean(bool value) dpush(value ? T : F); } -VM_C_API bool to_boolean(CELL value) +VM_C_API bool to_boolean(cell value) { return value != F; } diff --git a/vm/booleans.hpp b/vm/booleans.hpp index f5310de498..ea16e0536b 100644 --- a/vm/booleans.hpp +++ b/vm/booleans.hpp @@ -1,12 +1,12 @@ namespace factor { -inline static CELL tag_boolean(CELL untagged) +inline static cell tag_boolean(cell untagged) { return (untagged ? T : F); } VM_C_API void box_boolean(bool value); -VM_C_API bool to_boolean(CELL value); +VM_C_API bool to_boolean(cell value); } diff --git a/vm/byte_arrays.cpp b/vm/byte_arrays.cpp index 18ec087d93..2eda3f33c4 100644 --- a/vm/byte_arrays.cpp +++ b/vm/byte_arrays.cpp @@ -3,62 +3,62 @@ namespace factor { -F_BYTE_ARRAY *allot_byte_array(CELL size) +byte_array *allot_byte_array(cell size) { - F_BYTE_ARRAY *array = allot_array_internal(size); + byte_array *array = allot_array_internal(size); memset(array + 1,0,size); return array; } PRIMITIVE(byte_array) { - CELL size = unbox_array_size(); - dpush(tag(allot_byte_array(size))); + cell size = unbox_array_size(); + dpush(tag(allot_byte_array(size))); } PRIMITIVE(uninitialized_byte_array) { - CELL size = unbox_array_size(); - dpush(tag(allot_array_internal(size))); + cell size = unbox_array_size(); + dpush(tag(allot_array_internal(size))); } PRIMITIVE(resize_byte_array) { - F_BYTE_ARRAY *array = untag_check(dpop()); - CELL capacity = unbox_array_size(); - dpush(tag(reallot_array(array,capacity))); + byte_array *array = untag_check(dpop()); + cell capacity = unbox_array_size(); + dpush(tag(reallot_array(array,capacity))); } -void growable_byte_array::append_bytes(void *elts, CELL len) +void growable_byte_array::append_bytes(void *elts, cell len) { - CELL new_size = count + len; + cell new_size = count + len; - if(new_size >= array_capacity(array.untagged())) - array = reallot_array(array.untagged(),new_size * 2); + if(new_size >= array_capacity(elements.untagged())) + elements = reallot_array(elements.untagged(),new_size * 2); - memcpy(&array->data()[count],elts,len); + memcpy(&elements->data()[count],elts,len); count += len; } -void growable_byte_array::append_byte_array(CELL byte_array_) +void growable_byte_array::append_byte_array(cell byte_array_) { - gc_root byte_array(byte_array_); + gc_root byte_array(byte_array_); - CELL len = array_capacity(byte_array.untagged()); - CELL new_size = count + len; + cell len = array_capacity(byte_array.untagged()); + cell new_size = count + len; - if(new_size >= array_capacity(array.untagged())) - array = reallot_array(array.untagged(),new_size * 2); + if(new_size >= array_capacity(elements.untagged())) + elements = reallot_array(elements.untagged(),new_size * 2); - memcpy(&array->data()[count],byte_array->data(),len); + memcpy(&elements->data()[count],byte_array->data(),len); count += len; } void growable_byte_array::trim() { - array = reallot_array(array.untagged(),count); + elements = reallot_array(elements.untagged(),count); } } diff --git a/vm/byte_arrays.hpp b/vm/byte_arrays.hpp index 3dd4138aef..ebdc6bead6 100644 --- a/vm/byte_arrays.hpp +++ b/vm/byte_arrays.hpp @@ -1,7 +1,7 @@ namespace factor { -F_BYTE_ARRAY *allot_byte_array(CELL size); +byte_array *allot_byte_array(cell size); PRIMITIVE(byte_array); PRIMITIVE(uninitialized_byte_array); @@ -9,13 +9,13 @@ PRIMITIVE(resize_byte_array); /* Macros to simulate a byte vector in C */ struct growable_byte_array { - CELL count; - gc_root array; + cell count; + gc_root elements; - growable_byte_array() : count(0), array(allot_byte_array(2)) { } + growable_byte_array() : count(0), elements(allot_byte_array(2)) { } - void append_bytes(void *elts, CELL len); - void append_byte_array(CELL elts); + void append_bytes(void *elts, cell len); + void append_byte_array(cell elts); void trim(); }; diff --git a/vm/callstack.cpp b/vm/callstack.cpp index dc0d5a1af1..56056426dd 100755 --- a/vm/callstack.cpp +++ b/vm/callstack.cpp @@ -3,43 +3,43 @@ namespace factor { -static void check_frame(F_STACK_FRAME *frame) +static void check_frame(stack_frame *frame) { #ifdef FACTOR_DEBUG - check_code_pointer((CELL)frame->xt); + check_code_pointer((cell)frame->xt); assert(frame->size != 0); #endif } -void iterate_callstack(CELL top, CELL bottom, CALLSTACK_ITER iterator) +void iterate_callstack(cell top, cell bottom, CALLSTACK_ITER iterator) { - F_STACK_FRAME *frame = (F_STACK_FRAME *)bottom - 1; + stack_frame *frame = (stack_frame *)bottom - 1; - while((CELL)frame >= top) + while((cell)frame >= top) { iterator(frame); frame = frame_successor(frame); } } -void iterate_callstack_object(F_CALLSTACK *stack, CALLSTACK_ITER iterator) +void iterate_callstack_object(callstack *stack, CALLSTACK_ITER iterator) { - CELL top = (CELL)FIRST_STACK_FRAME(stack); - CELL bottom = top + untag_fixnum(stack->length); + cell top = (cell)FIRST_STACK_FRAME(stack); + cell bottom = top + untag_fixnum(stack->length); iterate_callstack(top,bottom,iterator); } -F_CALLSTACK *allot_callstack(CELL size) +callstack *allot_callstack(cell size) { - F_CALLSTACK *callstack = allot(callstack_size(size)); - callstack->length = tag_fixnum(size); - return callstack; + callstack *stack = allot(callstack_size(size)); + stack->length = tag_fixnum(size); + return stack; } -F_STACK_FRAME *fix_callstack_top(F_STACK_FRAME *top, F_STACK_FRAME *bottom) +stack_frame *fix_callstack_top(stack_frame *top, stack_frame *bottom) { - F_STACK_FRAME *frame = bottom - 1; + stack_frame *frame = bottom - 1; while(frame >= top) frame = frame_successor(frame); @@ -54,9 +54,9 @@ This means that if 'callstack' is called in tail position, we will have popped a necessary frame... however this word is only called by continuation implementation, and user code shouldn't be calling it at all, so we leave it as it is for now. */ -F_STACK_FRAME *capture_start(void) +stack_frame *capture_start(void) { - F_STACK_FRAME *frame = stack_chain->callstack_bottom - 1; + stack_frame *frame = stack_chain->callstack_bottom - 1; while(frame >= stack_chain->callstack_top && frame_successor(frame) >= stack_chain->callstack_top) { @@ -67,21 +67,21 @@ F_STACK_FRAME *capture_start(void) PRIMITIVE(callstack) { - F_STACK_FRAME *top = capture_start(); - F_STACK_FRAME *bottom = stack_chain->callstack_bottom; + stack_frame *top = capture_start(); + stack_frame *bottom = stack_chain->callstack_bottom; - F_FIXNUM size = (CELL)bottom - (CELL)top; + fixnum size = (cell)bottom - (cell)top; if(size < 0) size = 0; - F_CALLSTACK *callstack = allot_callstack(size); - memcpy(FIRST_STACK_FRAME(callstack),top,size); - dpush(tag(callstack)); + callstack *stack = allot_callstack(size); + memcpy(FIRST_STACK_FRAME(stack),top,size); + dpush(tag(stack)); } PRIMITIVE(set_callstack) { - F_CALLSTACK *stack = untag_check(dpop()); + callstack *stack = untag_check(dpop()); set_callstack(stack_chain->callstack_bottom, FIRST_STACK_FRAME(stack), @@ -92,40 +92,40 @@ PRIMITIVE(set_callstack) critical_error("Bug in set_callstack()",0); } -F_CODE_BLOCK *frame_code(F_STACK_FRAME *frame) +code_block *frame_code(stack_frame *frame) { check_frame(frame); - return (F_CODE_BLOCK *)frame->xt - 1; + return (code_block *)frame->xt - 1; } -CELL frame_type(F_STACK_FRAME *frame) +cell frame_type(stack_frame *frame) { return frame_code(frame)->block.type; } -CELL frame_executing(F_STACK_FRAME *frame) +cell frame_executing(stack_frame *frame) { - F_CODE_BLOCK *compiled = frame_code(frame); + code_block *compiled = frame_code(frame); if(compiled->literals == F || !stack_traces_p()) return F; else { - F_ARRAY *array = untag(compiled->literals); - return array_nth(array,0); + array *literals = untag(compiled->literals); + return array_nth(literals,0); } } -F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame) +stack_frame *frame_successor(stack_frame *frame) { check_frame(frame); - return (F_STACK_FRAME *)((CELL)frame - frame->size); + return (stack_frame *)((cell)frame - frame->size); } -CELL frame_scan(F_STACK_FRAME *frame) +cell frame_scan(stack_frame *frame) { if(frame_type(frame) == QUOTATION_TYPE) { - CELL quot = frame_executing(frame); + cell quot = frame_executing(frame); if(quot == F) return F; else @@ -134,7 +134,7 @@ CELL frame_scan(F_STACK_FRAME *frame) char *quot_xt = (char *)(frame_code(frame) + 1); return tag_fixnum(quot_code_offset_to_scan( - quot,(CELL)(return_addr - quot_xt))); + quot,(cell)(return_addr - quot_xt))); } } else @@ -142,43 +142,43 @@ CELL frame_scan(F_STACK_FRAME *frame) } /* C doesn't have closures... */ -static CELL frame_count; +static cell frame_count; -void count_stack_frame(F_STACK_FRAME *frame) +void count_stack_frame(stack_frame *frame) { frame_count += 2; } -static CELL frame_index; -static F_ARRAY *array; +static cell frame_index; +static array *frames; -void stack_frame_to_array(F_STACK_FRAME *frame) +void stack_frame_to_array(stack_frame *frame) { - set_array_nth(array,frame_index++,frame_executing(frame)); - set_array_nth(array,frame_index++,frame_scan(frame)); + set_array_nth(frames,frame_index++,frame_executing(frame)); + set_array_nth(frames,frame_index++,frame_scan(frame)); } PRIMITIVE(callstack_to_array) { - gc_root callstack(dpop()); + gc_root callstack(dpop()); frame_count = 0; iterate_callstack_object(callstack.untagged(),count_stack_frame); - array = allot_array_internal(frame_count); + frames = allot_array_internal(frame_count); frame_index = 0; iterate_callstack_object(callstack.untagged(),stack_frame_to_array); - dpush(tag(array)); + dpush(tag(frames)); } -F_STACK_FRAME *innermost_stack_frame(F_CALLSTACK *callstack) +stack_frame *innermost_stack_frame(callstack *callstack) { - F_STACK_FRAME *top = FIRST_STACK_FRAME(callstack); - CELL bottom = (CELL)top + untag_fixnum(callstack->length); + stack_frame *top = FIRST_STACK_FRAME(callstack); + cell bottom = (cell)top + untag_fixnum(callstack->length); - F_STACK_FRAME *frame = (F_STACK_FRAME *)bottom - 1; + stack_frame *frame = (stack_frame *)bottom - 1; while(frame >= top && frame_successor(frame) >= top) frame = frame_successor(frame); @@ -186,10 +186,10 @@ F_STACK_FRAME *innermost_stack_frame(F_CALLSTACK *callstack) return frame; } -F_STACK_FRAME *innermost_stack_frame_quot(F_CALLSTACK *callstack) +stack_frame *innermost_stack_frame_quot(callstack *callstack) { - F_STACK_FRAME *inner = innermost_stack_frame(callstack); - tagged(frame_executing(inner)).untag_check(); + stack_frame *inner = innermost_stack_frame(callstack); + tagged(frame_executing(inner)).untag_check(); return inner; } @@ -197,32 +197,32 @@ F_STACK_FRAME *innermost_stack_frame_quot(F_CALLSTACK *callstack) Used by the single stepper. */ PRIMITIVE(innermost_stack_frame_quot) { - dpush(frame_executing(innermost_stack_frame_quot(untag_check(dpop())))); + dpush(frame_executing(innermost_stack_frame_quot(untag_check(dpop())))); } PRIMITIVE(innermost_stack_frame_scan) { - dpush(frame_scan(innermost_stack_frame_quot(untag_check(dpop())))); + dpush(frame_scan(innermost_stack_frame_quot(untag_check(dpop())))); } PRIMITIVE(set_innermost_stack_frame_quot) { - gc_root callstack(dpop()); - gc_root quot(dpop()); + gc_root callstack(dpop()); + gc_root quot(dpop()); callstack.untag_check(); quot.untag_check(); jit_compile(quot.value(),true); - F_STACK_FRAME *inner = innermost_stack_frame_quot(callstack.untagged()); - CELL offset = (char *)FRAME_RETURN_ADDRESS(inner) - (char *)inner->xt; + stack_frame *inner = innermost_stack_frame_quot(callstack.untagged()); + cell offset = (char *)FRAME_RETURN_ADDRESS(inner) - (char *)inner->xt; inner->xt = quot->xt; FRAME_RETURN_ADDRESS(inner) = (char *)quot->xt + offset; } /* called before entry into Factor code. */ -VM_ASM_API void save_callstack_bottom(F_STACK_FRAME *callstack_bottom) +VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom) { stack_chain->callstack_bottom = callstack_bottom; } diff --git a/vm/callstack.hpp b/vm/callstack.hpp index 922a52bf27..efdbc7ba05 100755 --- a/vm/callstack.hpp +++ b/vm/callstack.hpp @@ -1,23 +1,23 @@ namespace factor { -inline static CELL callstack_size(CELL size) +inline static cell callstack_size(cell size) { - return sizeof(F_CALLSTACK) + size; + return sizeof(callstack) + size; } -#define FIRST_STACK_FRAME(stack) (F_STACK_FRAME *)((stack) + 1) +#define FIRST_STACK_FRAME(stack) (stack_frame *)((stack) + 1) -typedef void (*CALLSTACK_ITER)(F_STACK_FRAME *frame); +typedef void (*CALLSTACK_ITER)(stack_frame *frame); -F_STACK_FRAME *fix_callstack_top(F_STACK_FRAME *top, F_STACK_FRAME *bottom); -void iterate_callstack(CELL top, CELL bottom, CALLSTACK_ITER iterator); -void iterate_callstack_object(F_CALLSTACK *stack, CALLSTACK_ITER iterator); -F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame); -F_CODE_BLOCK *frame_code(F_STACK_FRAME *frame); -CELL frame_executing(F_STACK_FRAME *frame); -CELL frame_scan(F_STACK_FRAME *frame); -CELL frame_type(F_STACK_FRAME *frame); +stack_frame *fix_callstack_top(stack_frame *top, stack_frame *bottom); +void iterate_callstack(cell top, cell bottom, CALLSTACK_ITER iterator); +void iterate_callstack_object(callstack *stack, CALLSTACK_ITER iterator); +stack_frame *frame_successor(stack_frame *frame); +code_block *frame_code(stack_frame *frame); +cell frame_executing(stack_frame *frame); +cell frame_scan(stack_frame *frame); +cell frame_type(stack_frame *frame); PRIMITIVE(callstack); PRIMITIVE(set_callstack); @@ -26,6 +26,6 @@ PRIMITIVE(innermost_stack_frame_quot); PRIMITIVE(innermost_stack_frame_scan); PRIMITIVE(set_innermost_stack_frame_quot); -VM_ASM_API void save_callstack_bottom(F_STACK_FRAME *callstack_bottom); +VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom); } diff --git a/vm/code_block.cpp b/vm/code_block.cpp index 4b49027ff6..38a421704b 100644 --- a/vm/code_block.cpp +++ b/vm/code_block.cpp @@ -3,27 +3,27 @@ namespace factor { -void flush_icache_for(F_CODE_BLOCK *block) +void flush_icache_for(code_block *block) { - flush_icache((CELL)block,block->block.size); + flush_icache((cell)block,block->block.size); } -void iterate_relocations(F_CODE_BLOCK *compiled, RELOCATION_ITERATOR iter) +void iterate_relocations(code_block *compiled, relocation_iterator iter) { if(compiled->relocation != F) { - F_BYTE_ARRAY *relocation = untag(compiled->relocation); + byte_array *relocation = untag(compiled->relocation); - CELL index = stack_traces_p() ? 1 : 0; + cell index = stack_traces_p() ? 1 : 0; - F_REL *rel = (F_REL *)(relocation + 1); - F_REL *rel_end = (F_REL *)((char *)rel + array_capacity(relocation)); - - while(rel < rel_end) + cell length = array_capacity(relocation) / sizeof(relocation_entry); + for(cell i = 0; i < length; i++) { - iter(*rel,index,compiled); + relocation_entry rel = relocation->data()[i]; - switch(REL_TYPE(*rel)) + iter(rel,index,compiled); + + switch(REL_TYPE(rel)) { case RT_PRIMITIVE: case RT_XT: @@ -40,27 +40,25 @@ void iterate_relocations(F_CODE_BLOCK *compiled, RELOCATION_ITERATOR iter) case RT_STACK_CHAIN: break; default: - critical_error("Bad rel type",*rel); + critical_error("Bad rel type",rel); return; /* Can't happen */ } - - rel++; } } } /* Store a 32-bit value into a PowerPC LIS/ORI sequence */ -static void store_address_2_2(CELL *cell, CELL value) +static void store_address_2_2(cell *cell, cell value) { cell[-1] = ((cell[-1] & ~0xffff) | ((value >> 16) & 0xffff)); cell[ 0] = ((cell[ 0] & ~0xffff) | (value & 0xffff)); } /* Store a value into a bitfield of a PowerPC instruction */ -static void store_address_masked(CELL *cell, F_FIXNUM value, CELL mask, F_FIXNUM shift) +static void store_address_masked(cell *cell, fixnum value, cell mask, fixnum shift) { /* This is unaccurate but good enough */ - F_FIXNUM test = (F_FIXNUM)mask >> 1; + fixnum test = (fixnum)mask >> 1; if(value <= -test || value >= test) critical_error("Value does not fit inside relocation",0); @@ -68,14 +66,14 @@ static void store_address_masked(CELL *cell, F_FIXNUM value, CELL mask, F_FIXNUM } /* Perform a fixup on a code block */ -void store_address_in_code_block(CELL klass, CELL offset, F_FIXNUM absolute_value) +void store_address_in_code_block(cell klass, cell offset, fixnum absolute_value) { - F_FIXNUM relative_value = absolute_value - offset; + fixnum relative_value = absolute_value - offset; switch(klass) { case RC_ABSOLUTE_CELL: - *(CELL *)offset = absolute_value; + *(cell *)offset = absolute_value; break; case RC_ABSOLUTE: *(u32*)offset = absolute_value; @@ -84,24 +82,24 @@ void store_address_in_code_block(CELL klass, CELL offset, F_FIXNUM absolute_valu *(u32*)offset = relative_value - sizeof(u32); break; case RC_ABSOLUTE_PPC_2_2: - store_address_2_2((CELL *)offset,absolute_value); + store_address_2_2((cell *)offset,absolute_value); break; case RC_RELATIVE_PPC_2: - store_address_masked((CELL *)offset,relative_value,REL_RELATIVE_PPC_2_MASK,0); + store_address_masked((cell *)offset,relative_value,REL_RELATIVE_PPC_2_MASK,0); break; case RC_RELATIVE_PPC_3: - store_address_masked((CELL *)offset,relative_value,REL_RELATIVE_PPC_3_MASK,0); + store_address_masked((cell *)offset,relative_value,REL_RELATIVE_PPC_3_MASK,0); break; case RC_RELATIVE_ARM_3: - store_address_masked((CELL *)offset,relative_value - CELLS * 2, + store_address_masked((cell *)offset,relative_value - sizeof(cell) * 2, REL_RELATIVE_ARM_3_MASK,2); break; case RC_INDIRECT_ARM: - store_address_masked((CELL *)offset,relative_value - CELLS, + store_address_masked((cell *)offset,relative_value - sizeof(cell), REL_INDIRECT_ARM_MASK,0); break; case RC_INDIRECT_ARM_PC: - store_address_masked((CELL *)offset,relative_value - CELLS * 2, + store_address_masked((cell *)offset,relative_value - sizeof(cell) * 2, REL_INDIRECT_ARM_MASK,0); break; default: @@ -110,27 +108,30 @@ void store_address_in_code_block(CELL klass, CELL offset, F_FIXNUM absolute_valu } } -void update_literal_references_step(F_REL rel, CELL index, F_CODE_BLOCK *compiled) +void update_literal_references_step(relocation_entry rel, cell index, code_block *compiled) { if(REL_TYPE(rel) == RT_IMMEDIATE) { - CELL offset = REL_OFFSET(rel) + (CELL)(compiled + 1); - F_ARRAY *literals = untag(compiled->literals); - F_FIXNUM absolute_value = array_nth(literals,index); + cell offset = REL_OFFSET(rel) + (cell)(compiled + 1); + array *literals = untag(compiled->literals); + fixnum absolute_value = array_nth(literals,index); store_address_in_code_block(REL_CLASS(rel),offset,absolute_value); } } /* Update pointers to literals from compiled code. */ -void update_literal_references(F_CODE_BLOCK *compiled) +void update_literal_references(code_block *compiled) { - iterate_relocations(compiled,update_literal_references_step); - flush_icache_for(compiled); + if(!compiled->block.needs_fixup) + { + iterate_relocations(compiled,update_literal_references_step); + flush_icache_for(compiled); + } } /* Copy all literals referenced from a code block to newspace. Only for aging and nursery collections */ -void copy_literal_references(F_CODE_BLOCK *compiled) +void copy_literal_references(code_block *compiled) { if(collecting_gen >= compiled->block.last_scan) { @@ -140,7 +141,7 @@ void copy_literal_references(F_CODE_BLOCK *compiled) compiled->block.last_scan = collecting_gen + 1; /* initialize chase pointer */ - CELL scan = newspace->here; + cell scan = newspace->here; copy_handle(&compiled->literals); copy_handle(&compiled->relocation); @@ -153,52 +154,51 @@ void copy_literal_references(F_CODE_BLOCK *compiled) } } -CELL object_xt(CELL obj) +void *object_xt(cell obj) { - if(TAG(obj) == QUOTATION_TYPE) + switch(tagged(obj).type()) { - F_QUOTATION *quot = untag(obj); - return (CELL)quot->xt; - } - else - { - F_WORD *word = untag(obj); - return (CELL)word->xt; + case WORD_TYPE: + return untag(obj)->xt; + case QUOTATION_TYPE: + return untag(obj)->xt; + default: + critical_error("Expected word or quotation",obj); + return NULL; } } -CELL word_direct_xt(CELL obj) +void *word_direct_xt(word *w) { - F_WORD *word = untag(obj); - CELL quot = word->direct_entry_def; - if(quot == F || max_pic_size == 0) - return (CELL)word->xt; + cell tagged_quot = w->direct_entry_def; + if(tagged_quot == F || max_pic_size == 0) + return w->xt; else { - F_QUOTATION *untagged = untag(quot); - if(untagged->compiledp == F) - return (CELL)word->xt; + quotation *quot = untag(tagged_quot); + if(quot->compiledp == F) + return w->xt; else - return (CELL)untagged->xt; + return quot->xt; } } -void update_word_references_step(F_REL rel, CELL index, F_CODE_BLOCK *compiled) +void update_word_references_step(relocation_entry rel, cell index, code_block *compiled) { - F_RELTYPE type = REL_TYPE(rel); + relocation_type type = REL_TYPE(rel); if(type == RT_XT || type == RT_XT_DIRECT) { - CELL offset = REL_OFFSET(rel) + (CELL)(compiled + 1); - F_ARRAY *literals = untag(compiled->literals); - CELL obj = array_nth(literals,index); + cell offset = REL_OFFSET(rel) + (cell)(compiled + 1); + array *literals = untag(compiled->literals); + cell obj = array_nth(literals,index); - CELL xt; + void *xt; if(type == RT_XT) xt = object_xt(obj); else - xt = word_direct_xt(obj); + xt = word_direct_xt(untag(obj)); - store_address_in_code_block(REL_CLASS(rel),offset,xt); + store_address_in_code_block(REL_CLASS(rel),offset,(cell)xt); } } @@ -206,7 +206,7 @@ void update_word_references_step(F_REL rel, CELL index, F_CODE_BLOCK *compiled) dlsyms, and words. For all other words in the code heap, we only need to update references to other words, without worrying about literals or dlsyms. */ -void update_word_references(F_CODE_BLOCK *compiled) +void update_word_references(code_block *compiled) { if(compiled->block.needs_fixup) relocate_code_block(compiled); @@ -220,7 +220,7 @@ void update_word_references(F_CODE_BLOCK *compiled) else if(compiled->block.type == PIC_TYPE) { fflush(stdout); - heap_free(&code_heap,&compiled->block); + heap_free(&code,&compiled->block); } else { @@ -229,16 +229,16 @@ void update_word_references(F_CODE_BLOCK *compiled) } } -void update_literal_and_word_references(F_CODE_BLOCK *compiled) +void update_literal_and_word_references(code_block *compiled) { update_literal_references(compiled); update_word_references(compiled); } -static void check_code_address(CELL address) +static void check_code_address(cell address) { #ifdef FACTOR_DEBUG - assert(address >= code_heap.segment->start && address < code_heap.segment->end); + assert(address >= code.seg->start && address < code.seg->end); #endif } @@ -247,9 +247,9 @@ is added to the heap. */ /* Mark all literals referenced from a word XT. Only for tenured collections */ -void mark_code_block(F_CODE_BLOCK *compiled) +void mark_code_block(code_block *compiled) { - check_code_address((CELL)compiled); + check_code_address((cell)compiled); mark_block(&compiled->block); @@ -257,41 +257,41 @@ void mark_code_block(F_CODE_BLOCK *compiled) copy_handle(&compiled->relocation); } -void mark_stack_frame_step(F_STACK_FRAME *frame) +void mark_stack_frame_step(stack_frame *frame) { mark_code_block(frame_code(frame)); } /* Mark code blocks executing in currently active stack frames. */ -void mark_active_blocks(F_CONTEXT *stacks) +void mark_active_blocks(context *stacks) { if(collecting_gen == TENURED) { - CELL top = (CELL)stacks->callstack_top; - CELL bottom = (CELL)stacks->callstack_bottom; + cell top = (cell)stacks->callstack_top; + cell bottom = (cell)stacks->callstack_bottom; iterate_callstack(top,bottom,mark_stack_frame_step); } } -void mark_object_code_block(F_OBJECT *object) +void mark_object_code_block(object *object) { - switch(object->header.hi_tag()) + switch(object->h.hi_tag()) { case WORD_TYPE: - F_WORD *word = (F_WORD *)object; - if(word->code) - mark_code_block(word->code); - if(word->profiling) - mark_code_block(word->profiling); + word *w = (word *)object; + if(w->code) + mark_code_block(w->code); + if(w->profiling) + mark_code_block(w->profiling); break; case QUOTATION_TYPE: - F_QUOTATION *quot = (F_QUOTATION *)object; - if(quot->compiledp != F) - mark_code_block(quot->code); + quotation *q = (quotation *)object; + if(q->compiledp != F) + mark_code_block(q->code); break; case CALLSTACK_TYPE: - F_CALLSTACK *stack = (F_CALLSTACK *)object; + callstack *stack = (callstack *)object; iterate_callstack_object(stack,mark_stack_frame_step); break; } @@ -305,21 +305,21 @@ void undefined_symbol(void) } /* Look up an external library symbol referenced by a compiled code block */ -void *get_rel_symbol(F_ARRAY *literals, CELL index) +void *get_rel_symbol(array *literals, cell index) { - CELL symbol = array_nth(literals,index); - CELL library = array_nth(literals,index + 1); + cell symbol = array_nth(literals,index); + cell library = array_nth(literals,index + 1); - F_DLL *dll = (library == F ? NULL : untag(library)); + dll *d = (library == F ? NULL : untag(library)); - if(dll != NULL && !dll->dll) + if(d != NULL && !d->dll) return (void *)undefined_symbol; - switch(tagged(symbol).type()) + switch(tagged(symbol).type()) { case BYTE_ARRAY_TYPE: - F_SYMBOL *name = alien_offset(symbol); - void *sym = ffi_dlsym(dll,name); + symbol_char *name = alien_offset(symbol); + void *sym = ffi_dlsym(d,name); if(sym) return sym; @@ -329,12 +329,12 @@ void *get_rel_symbol(F_ARRAY *literals, CELL index) return (void *)undefined_symbol; } case ARRAY_TYPE: - CELL i; - F_ARRAY *names = untag(symbol); + cell i; + array *names = untag(symbol); for(i = 0; i < array_capacity(names); i++) { - F_SYMBOL *name = alien_offset(array_nth(names,i)); - void *sym = ffi_dlsym(dll,name); + symbol_char *name = alien_offset(array_nth(names,i)); + void *sym = ffi_dlsym(d,name); if(sym) return sym; @@ -347,45 +347,45 @@ void *get_rel_symbol(F_ARRAY *literals, CELL index) } /* Compute an address to store at a relocation */ -void relocate_code_block_step(F_REL rel, CELL index, F_CODE_BLOCK *compiled) +void relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled) { #ifdef FACTOR_DEBUG - tagged(compiled->literals).untag_check(); - tagged(compiled->relocation).untag_check(); + tagged(compiled->literals).untag_check(); + tagged(compiled->relocation).untag_check(); #endif - CELL offset = REL_OFFSET(rel) + (CELL)(compiled + 1); - F_ARRAY *literals = untag(compiled->literals); - F_FIXNUM absolute_value; + cell offset = REL_OFFSET(rel) + (cell)(compiled + 1); + array *literals = untag(compiled->literals); + fixnum absolute_value; switch(REL_TYPE(rel)) { case RT_PRIMITIVE: - absolute_value = (CELL)primitives[to_fixnum(array_nth(literals,index))]; + absolute_value = (cell)primitives[untag_fixnum(array_nth(literals,index))]; break; case RT_DLSYM: - absolute_value = (CELL)get_rel_symbol(literals,index); + absolute_value = (cell)get_rel_symbol(literals,index); break; case RT_IMMEDIATE: absolute_value = array_nth(literals,index); break; case RT_XT: - absolute_value = object_xt(array_nth(literals,index)); + absolute_value = (cell)object_xt(array_nth(literals,index)); break; case RT_XT_DIRECT: - absolute_value = word_direct_xt(array_nth(literals,index)); + absolute_value = (cell)word_direct_xt(untag(array_nth(literals,index))); break; case RT_HERE: - absolute_value = offset + (short)to_fixnum(array_nth(literals,index)); + absolute_value = offset + (short)untag_fixnum(array_nth(literals,index)); break; case RT_THIS: - absolute_value = (CELL)(compiled + 1); + absolute_value = (cell)(compiled + 1); break; case RT_STACK_CHAIN: - absolute_value = (CELL)&stack_chain; + absolute_value = (cell)&stack_chain; break; case RT_UNTAGGED: - absolute_value = to_fixnum(array_nth(literals,index)); + absolute_value = untag_fixnum(array_nth(literals,index)); break; default: critical_error("Bad rel type",rel); @@ -396,7 +396,7 @@ void relocate_code_block_step(F_REL rel, CELL index, F_CODE_BLOCK *compiled) } /* Perform all fixups on a code block */ -void relocate_code_block(F_CODE_BLOCK *compiled) +void relocate_code_block(code_block *compiled) { compiled->block.last_scan = NURSERY; compiled->block.needs_fixup = false; @@ -405,39 +405,39 @@ void relocate_code_block(F_CODE_BLOCK *compiled) } /* Fixup labels. This is done at compile time, not image load time */ -void fixup_labels(F_ARRAY *labels, F_CODE_BLOCK *compiled) +void fixup_labels(array *labels, code_block *compiled) { - CELL i; - CELL size = array_capacity(labels); + cell i; + cell size = array_capacity(labels); for(i = 0; i < size; i += 3) { - CELL klass = to_fixnum(array_nth(labels,i)); - CELL offset = to_fixnum(array_nth(labels,i + 1)); - CELL target = to_fixnum(array_nth(labels,i + 2)); + cell klass = untag_fixnum(array_nth(labels,i)); + cell offset = untag_fixnum(array_nth(labels,i + 1)); + cell target = untag_fixnum(array_nth(labels,i + 2)); store_address_in_code_block(klass, - offset + (CELL)(compiled + 1), - target + (CELL)(compiled + 1)); + offset + (cell)(compiled + 1), + target + (cell)(compiled + 1)); } } /* Might GC */ -F_CODE_BLOCK *allot_code_block(CELL size) +code_block *allot_code_block(cell size) { - F_BLOCK *block = heap_allot(&code_heap,size + sizeof(F_CODE_BLOCK)); + heap_block *block = heap_allot(&code,size + sizeof(code_block)); /* If allocation failed, do a code GC */ if(block == NULL) { gc(); - block = heap_allot(&code_heap,size + sizeof(F_CODE_BLOCK)); + block = heap_allot(&code,size + sizeof(code_block)); /* Insufficient room even after code GC, give up */ if(block == NULL) { - CELL used, total_free, max_free; - heap_usage(&code_heap,&used,&total_free,&max_free); + cell used, total_free, max_free; + heap_usage(&code,&used,&total_free,&max_free); print_string("Code heap stats:\n"); print_string("Used: "); print_cell(used); nl(); @@ -447,24 +447,24 @@ F_CODE_BLOCK *allot_code_block(CELL size) } } - return (F_CODE_BLOCK *)block; + return (code_block *)block; } /* Might GC */ -F_CODE_BLOCK *add_code_block( - CELL type, - CELL code_, - CELL labels_, - CELL relocation_, - CELL literals_) +code_block *add_code_block( + cell type, + cell code_, + cell labels_, + cell relocation_, + cell literals_) { - gc_root code(code_); - gc_root labels(labels_); - gc_root relocation(relocation_); - gc_root literals(literals_); + gc_root code(code_); + gc_root labels(labels_); + gc_root relocation(relocation_); + gc_root literals(literals_); - CELL code_length = align8(array_capacity(code.untagged())); - F_CODE_BLOCK *compiled = allot_code_block(code_length); + cell code_length = align8(array_capacity(code.untagged())); + code_block *compiled = allot_code_block(code_length); /* compiled header */ compiled->block.type = type; @@ -483,7 +483,7 @@ F_CODE_BLOCK *add_code_block( /* fixup labels */ if(labels.value() != F) - fixup_labels(labels.as().untagged(),compiled); + fixup_labels(labels.as().untagged(),compiled); /* next time we do a minor GC, we have to scan the code heap for literals */ diff --git a/vm/code_block.hpp b/vm/code_block.hpp index 4e33022262..9689ea5419 100644 --- a/vm/code_block.hpp +++ b/vm/code_block.hpp @@ -1,7 +1,7 @@ namespace factor { -typedef enum { +enum relocation_type { /* arg is a primitive number */ RT_PRIMITIVE, /* arg is a literal table index, holding an array pair (symbol/dll) */ @@ -22,9 +22,9 @@ typedef enum { RT_STACK_CHAIN, /* untagged fixnum literal */ RT_UNTAGGED, -} F_RELTYPE; +}; -typedef enum { +enum relocation_class { /* absolute address in a 64-bit location */ RC_ABSOLUTE_CELL, /* absolute address in a 32-bit location */ @@ -43,7 +43,7 @@ typedef enum { RC_INDIRECT_ARM, /* pointer to address in an ARM LDR/STR instruction offset by 8 bytes */ RC_INDIRECT_ARM_PC -} F_RELCLASS; +}; #define REL_RELATIVE_PPC_2_MASK 0xfffc #define REL_RELATIVE_PPC_3_MASK 0x3fffffc @@ -51,42 +51,42 @@ typedef enum { #define REL_RELATIVE_ARM_3_MASK 0xffffff /* code relocation table consists of a table of entries for each fixup */ -typedef u32 F_REL; -#define REL_TYPE(r) (F_RELTYPE)(((r) & 0xf0000000) >> 28) -#define REL_CLASS(r) (F_RELCLASS)(((r) & 0x0f000000) >> 24) +typedef u32 relocation_entry; +#define REL_TYPE(r) (relocation_type)(((r) & 0xf0000000) >> 28) +#define REL_CLASS(r) (relocation_class)(((r) & 0x0f000000) >> 24) #define REL_OFFSET(r) ((r) & 0x00ffffff) -void flush_icache_for(F_CODE_BLOCK *compiled); +void flush_icache_for(code_block *compiled); -typedef void (*RELOCATION_ITERATOR)(F_REL rel, CELL index, F_CODE_BLOCK *compiled); +typedef void (*relocation_iterator)(relocation_entry rel, cell index, code_block *compiled); -void iterate_relocations(F_CODE_BLOCK *compiled, RELOCATION_ITERATOR iter); +void iterate_relocations(code_block *compiled, relocation_iterator iter); -void store_address_in_code_block(CELL klass, CELL offset, F_FIXNUM absolute_value); +void store_address_in_code_block(cell klass, cell offset, fixnum absolute_value); -void relocate_code_block(F_CODE_BLOCK *compiled); +void relocate_code_block(code_block *compiled); -void update_literal_references(F_CODE_BLOCK *compiled); +void update_literal_references(code_block *compiled); -void copy_literal_references(F_CODE_BLOCK *compiled); +void copy_literal_references(code_block *compiled); -void update_word_references(F_CODE_BLOCK *compiled); +void update_word_references(code_block *compiled); -void update_literal_and_word_references(F_CODE_BLOCK *compiled); +void update_literal_and_word_references(code_block *compiled); -void mark_code_block(F_CODE_BLOCK *compiled); +void mark_code_block(code_block *compiled); -void mark_active_blocks(F_CONTEXT *stacks); +void mark_active_blocks(context *stacks); -void mark_object_code_block(F_OBJECT *scan); +void mark_object_code_block(object *scan); -void relocate_code_block(F_CODE_BLOCK *relocating); +void relocate_code_block(code_block *relocating); inline static bool stack_traces_p(void) { return userenv[STACK_TRACES_ENV] != F; } -F_CODE_BLOCK *add_code_block(CELL type, CELL code, CELL labels, CELL relocation, CELL literals); +code_block *add_code_block(cell type, cell code, cell labels, cell relocation, cell literals); } diff --git a/vm/code_gc.cpp b/vm/code_gc.cpp index 94c1fe286d..b86d08cf52 100755 --- a/vm/code_gc.cpp +++ b/vm/code_gc.cpp @@ -3,24 +3,24 @@ namespace factor { -static void clear_free_list(F_HEAP *heap) +static void clear_free_list(heap *heap) { - memset(&heap->free,0,sizeof(F_HEAP_FREE_LIST)); + memset(&heap->free,0,sizeof(heap_free_list)); } /* This malloc-style heap code is reasonably generic. Maybe in the future, it will be used for the data heap too, if we ever get incremental mark/sweep/compact GC. */ -void new_heap(F_HEAP *heap, CELL size) +void new_heap(heap *heap, cell size) { - heap->segment = alloc_segment(align_page(size)); - if(!heap->segment) + heap->seg = alloc_segment(align_page(size)); + if(!heap->seg) fatal_error("Out of memory in new_heap",size); clear_free_list(heap); } -static void add_to_free_list(F_HEAP *heap, F_FREE_BLOCK *block) +static void add_to_free_list(heap *heap, free_heap_block *block) { if(block->block.size < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT) { @@ -39,29 +39,29 @@ static void add_to_free_list(F_HEAP *heap, F_FREE_BLOCK *block) In the former case, we must add a large free block from compiling.base + size to compiling.limit. */ -void build_free_list(F_HEAP *heap, CELL size) +void build_free_list(heap *heap, cell size) { - F_BLOCK *prev = NULL; + heap_block *prev = NULL; clear_free_list(heap); size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1); - F_BLOCK *scan = first_block(heap); - F_FREE_BLOCK *end = (F_FREE_BLOCK *)(heap->segment->start + size); + heap_block *scan = first_block(heap); + free_heap_block *end = (free_heap_block *)(heap->seg->start + size); /* Add all free blocks to the free list */ - while(scan && scan < (F_BLOCK *)end) + while(scan && scan < (heap_block *)end) { switch(scan->status) { case B_FREE: - add_to_free_list(heap,(F_FREE_BLOCK *)scan); + add_to_free_list(heap,(free_heap_block *)scan); break; case B_ALLOCATED: break; default: - critical_error("Invalid scan->status",(CELL)scan); + critical_error("Invalid scan->status",(cell)scan); break; } @@ -71,10 +71,10 @@ void build_free_list(F_HEAP *heap, CELL size) /* If there is room at the end of the heap, add a free block. This branch is only taken after loading a new image, not after code GC */ - if((CELL)(end + 1) <= heap->segment->end) + if((cell)(end + 1) <= heap->seg->end) { end->block.status = B_FREE; - end->block.size = heap->segment->end - (CELL)end; + end->block.size = heap->seg->end - (cell)end; /* add final free block */ add_to_free_list(heap,end); @@ -86,25 +86,25 @@ void build_free_list(F_HEAP *heap, CELL size) /* even if there's no room at the end of the heap for a new free block, we might have to jigger it up by a few bytes in case prev + prev->size */ - if(prev) prev->size = heap->segment->end - (CELL)prev; + if(prev) prev->size = heap->seg->end - (cell)prev; } } -static void assert_free_block(F_FREE_BLOCK *block) +static void assert_free_block(free_heap_block *block) { if(block->block.status != B_FREE) - critical_error("Invalid block in free list",(CELL)block); + critical_error("Invalid block in free list",(cell)block); } -static F_FREE_BLOCK *find_free_block(F_HEAP *heap, CELL size) +static free_heap_block *find_free_block(heap *heap, cell size) { - CELL attempt = size; + cell attempt = size; while(attempt < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT) { int index = attempt / BLOCK_SIZE_INCREMENT; - F_FREE_BLOCK *block = heap->free.small_blocks[index]; + free_heap_block *block = heap->free.small_blocks[index]; if(block) { assert_free_block(block); @@ -115,8 +115,8 @@ static F_FREE_BLOCK *find_free_block(F_HEAP *heap, CELL size) attempt *= 2; } - F_FREE_BLOCK *prev = NULL; - F_FREE_BLOCK *block = heap->free.large_blocks; + free_heap_block *prev = NULL; + free_heap_block *block = heap->free.large_blocks; while(block) { @@ -137,12 +137,12 @@ static F_FREE_BLOCK *find_free_block(F_HEAP *heap, CELL size) return NULL; } -static F_FREE_BLOCK *split_free_block(F_HEAP *heap, F_FREE_BLOCK *block, CELL size) +static free_heap_block *split_free_block(heap *heap, free_heap_block *block, cell size) { if(block->block.size != size ) { /* split the block in two */ - F_FREE_BLOCK *split = (F_FREE_BLOCK *)((CELL)block + size); + free_heap_block *split = (free_heap_block *)((cell)block + size); split->block.status = B_FREE; split->block.size = block->block.size - size; split->next_free = block->next_free; @@ -154,11 +154,11 @@ static F_FREE_BLOCK *split_free_block(F_HEAP *heap, F_FREE_BLOCK *block, CELL si } /* Allocate a block of memory from the mark and sweep GC heap */ -F_BLOCK *heap_allot(F_HEAP *heap, CELL size) +heap_block *heap_allot(heap *heap, cell size) { size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1); - F_FREE_BLOCK *block = find_free_block(heap,size); + free_heap_block *block = find_free_block(heap,size); if(block) { block = split_free_block(heap,block,size); @@ -171,13 +171,13 @@ F_BLOCK *heap_allot(F_HEAP *heap, CELL size) } /* Deallocates a block manually */ -void heap_free(F_HEAP *heap, F_BLOCK *block) +void heap_free(heap *heap, heap_block *block) { block->status = B_FREE; - add_to_free_list(heap,(F_FREE_BLOCK *)block); + add_to_free_list(heap,(free_heap_block *)block); } -void mark_block(F_BLOCK *block) +void mark_block(heap_block *block) { /* If already marked, do nothing */ switch(block->status) @@ -188,16 +188,16 @@ void mark_block(F_BLOCK *block) block->status = B_MARKED; break; default: - critical_error("Marking the wrong block",(CELL)block); + critical_error("Marking the wrong block",(cell)block); break; } } /* If in the middle of code GC, we have to grow the heap, data GC restarts from scratch, so we have to unmark any marked blocks. */ -void unmark_marked(F_HEAP *heap) +void unmark_marked(heap *heap) { - F_BLOCK *scan = first_block(heap); + heap_block *scan = first_block(heap); while(scan) { @@ -210,12 +210,12 @@ void unmark_marked(F_HEAP *heap) /* After code GC, all referenced code blocks have status set to B_MARKED, so any which are allocated and not marked can be reclaimed. */ -void free_unmarked(F_HEAP *heap, HEAP_ITERATOR iter) +void free_unmarked(heap *heap, heap_iterator iter) { clear_free_list(heap); - F_BLOCK *prev = NULL; - F_BLOCK *scan = first_block(heap); + heap_block *prev = NULL; + heap_block *scan = first_block(heap); while(scan) { @@ -223,7 +223,7 @@ void free_unmarked(F_HEAP *heap, HEAP_ITERATOR iter) { case B_ALLOCATED: if(secure_gc) - memset(scan + 1,0,scan->size - sizeof(F_BLOCK)); + memset(scan + 1,0,scan->size - sizeof(heap_block)); if(prev && prev->status == B_FREE) prev->size += scan->size; @@ -241,30 +241,30 @@ void free_unmarked(F_HEAP *heap, HEAP_ITERATOR iter) break; case B_MARKED: if(prev && prev->status == B_FREE) - add_to_free_list(heap,(F_FREE_BLOCK *)prev); + add_to_free_list(heap,(free_heap_block *)prev); scan->status = B_ALLOCATED; prev = scan; iter(scan); break; default: - critical_error("Invalid scan->status",(CELL)scan); + critical_error("Invalid scan->status",(cell)scan); } scan = next_block(heap,scan); } if(prev && prev->status == B_FREE) - add_to_free_list(heap,(F_FREE_BLOCK *)prev); + add_to_free_list(heap,(free_heap_block *)prev); } /* Compute total sum of sizes of free blocks, and size of largest free block */ -void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free) +void heap_usage(heap *heap, cell *used, cell *total_free, cell *max_free) { *used = 0; *total_free = 0; *max_free = 0; - F_BLOCK *scan = first_block(heap); + heap_block *scan = first_block(heap); while(scan) { @@ -279,7 +279,7 @@ void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free) *max_free = scan->size; break; default: - critical_error("Invalid scan->status",(CELL)scan); + critical_error("Invalid scan->status",(cell)scan); } scan = next_block(heap,scan); @@ -287,32 +287,32 @@ void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free) } /* The size of the heap, not including the last block if it's free */ -CELL heap_size(F_HEAP *heap) +cell heap_size(heap *heap) { - F_BLOCK *scan = first_block(heap); + heap_block *scan = first_block(heap); while(next_block(heap,scan) != NULL) scan = next_block(heap,scan); /* this is the last block in the heap, and it is free */ if(scan->status == B_FREE) - return (CELL)scan - heap->segment->start; + return (cell)scan - heap->seg->start; /* otherwise the last block is allocated */ else - return heap->segment->size; + return heap->seg->size; } /* Compute where each block is going to go, after compaction */ -CELL compute_heap_forwarding(F_HEAP *heap) +cell compute_heap_forwarding(heap *heap) { - F_BLOCK *scan = first_block(heap); - CELL address = (CELL)first_block(heap); + heap_block *scan = first_block(heap); + cell address = (cell)first_block(heap); while(scan) { if(scan->status == B_ALLOCATED) { - scan->forwarding = (F_BLOCK *)address; + scan->forwarding = (heap_block *)address; address += scan->size; } else if(scan->status == B_MARKED) @@ -321,16 +321,16 @@ CELL compute_heap_forwarding(F_HEAP *heap) scan = next_block(heap,scan); } - return address - heap->segment->start; + return address - heap->seg->start; } -void compact_heap(F_HEAP *heap) +void compact_heap(heap *heap) { - F_BLOCK *scan = first_block(heap); + heap_block *scan = first_block(heap); while(scan) { - F_BLOCK *next = next_block(heap,scan); + heap_block *next = next_block(heap,scan); if(scan->status == B_ALLOCATED && scan != scan->forwarding) memcpy(scan->forwarding,scan,scan->size); diff --git a/vm/code_gc.hpp b/vm/code_gc.hpp index c0531472de..3879d3c8e8 100755 --- a/vm/code_gc.hpp +++ b/vm/code_gc.hpp @@ -4,47 +4,47 @@ namespace factor #define FREE_LIST_COUNT 16 #define BLOCK_SIZE_INCREMENT 32 -struct F_HEAP_FREE_LIST { - F_FREE_BLOCK *small_blocks[FREE_LIST_COUNT]; - F_FREE_BLOCK *large_blocks; +struct heap_free_list { + free_heap_block *small_blocks[FREE_LIST_COUNT]; + free_heap_block *large_blocks; }; -struct F_HEAP { - F_SEGMENT *segment; - F_HEAP_FREE_LIST free; +struct heap { + segment *seg; + heap_free_list free; }; -typedef void (*HEAP_ITERATOR)(F_BLOCK *compiled); +typedef void (*heap_iterator)(heap_block *compiled); -void new_heap(F_HEAP *heap, CELL size); -void build_free_list(F_HEAP *heap, CELL size); -F_BLOCK *heap_allot(F_HEAP *heap, CELL size); -void heap_free(F_HEAP *heap, F_BLOCK *block); -void mark_block(F_BLOCK *block); -void unmark_marked(F_HEAP *heap); -void free_unmarked(F_HEAP *heap, HEAP_ITERATOR iter); -void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free); -CELL heap_size(F_HEAP *heap); -CELL compute_heap_forwarding(F_HEAP *heap); -void compact_heap(F_HEAP *heap); +void new_heap(heap *h, cell size); +void build_free_list(heap *h, cell size); +heap_block *heap_allot(heap *h, cell size); +void heap_free(heap *h, heap_block *block); +void mark_block(heap_block *block); +void unmark_marked(heap *heap); +void free_unmarked(heap *heap, heap_iterator iter); +void heap_usage(heap *h, cell *used, cell *total_free, cell *max_free); +cell heap_size(heap *h); +cell compute_heap_forwarding(heap *h); +void compact_heap(heap *h); -inline static F_BLOCK *next_block(F_HEAP *heap, F_BLOCK *block) +inline static heap_block *next_block(heap *h, heap_block *block) { - CELL next = ((CELL)block + block->size); - if(next == heap->segment->end) + cell next = ((cell)block + block->size); + if(next == h->seg->end) return NULL; else - return (F_BLOCK *)next; + return (heap_block *)next; } -inline static F_BLOCK *first_block(F_HEAP *heap) +inline static heap_block *first_block(heap *h) { - return (F_BLOCK *)heap->segment->start; + return (heap_block *)h->seg->start; } -inline static F_BLOCK *last_block(F_HEAP *heap) +inline static heap_block *last_block(heap *h) { - return (F_BLOCK *)heap->segment->end; + return (heap_block *)h->seg->end; } } diff --git a/vm/code_heap.cpp b/vm/code_heap.cpp index b4fea25f59..71105dabcf 100755 --- a/vm/code_heap.cpp +++ b/vm/code_heap.cpp @@ -3,25 +3,24 @@ namespace factor { -F_HEAP code_heap; +heap code; /* Allocate a code heap during startup */ -void init_code_heap(CELL size) +void init_code_heap(cell size) { - new_heap(&code_heap,size); + new_heap(&code,size); } -bool in_code_heap_p(CELL ptr) +bool in_code_heap_p(cell ptr) { - return (ptr >= code_heap.segment->start - && ptr <= code_heap.segment->end); + return (ptr >= code.seg->start && ptr <= code.seg->end); } /* Compile a word definition with the non-optimizing compiler. Allocates memory */ -void jit_compile_word(CELL word_, CELL def_, bool relocate) +void jit_compile_word(cell word_, cell def_, bool relocate) { - gc_root word(word_); - gc_root def(def_); + gc_root word(word_); + gc_root def(def_); jit_compile(def.value(),relocate); @@ -32,15 +31,15 @@ void jit_compile_word(CELL word_, CELL def_, bool relocate) } /* Apply a function to every code block */ -void iterate_code_heap(CODE_HEAP_ITERATOR iter) +void iterate_code_heap(code_heap_iterator iter) { - F_BLOCK *scan = first_block(&code_heap); + heap_block *scan = first_block(&code); while(scan) { if(scan->status != B_FREE) - iter((F_CODE_BLOCK *)scan); - scan = next_block(&code_heap,scan); + iter((code_block *)scan); + scan = next_block(&code,scan); } } @@ -60,20 +59,20 @@ void update_code_heap_words(void) PRIMITIVE(modify_code_heap) { - gc_root alist(dpop()); + gc_root alist(dpop()); - CELL count = array_capacity(alist.untagged()); + cell count = array_capacity(alist.untagged()); if(count == 0) return; - CELL i; + cell i; for(i = 0; i < count; i++) { - gc_root pair(array_nth(alist.untagged(),i)); + gc_root pair(array_nth(alist.untagged(),i)); - gc_root word(array_nth(pair.untagged(),0)); - gc_root data(array_nth(pair.untagged(),1)); + gc_root word(array_nth(pair.untagged(),0)); + gc_root data(array_nth(pair.untagged(),1)); switch(data.type()) { @@ -81,13 +80,13 @@ PRIMITIVE(modify_code_heap) jit_compile_word(word.value(),data.value(),false); break; case ARRAY_TYPE: - F_ARRAY *compiled_data = data.as().untagged(); - CELL literals = array_nth(compiled_data,0); - CELL relocation = array_nth(compiled_data,1); - CELL labels = array_nth(compiled_data,2); - CELL code = array_nth(compiled_data,3); + array *compiled_data = data.as().untagged(); + cell literals = array_nth(compiled_data,0); + cell relocation = array_nth(compiled_data,1); + cell labels = array_nth(compiled_data,2); + cell code = array_nth(compiled_data,3); - F_CODE_BLOCK *compiled = add_code_block( + code_block *compiled = add_code_block( WORD_TYPE, code, labels, @@ -110,54 +109,55 @@ PRIMITIVE(modify_code_heap) /* Push the free space and total size of the code heap */ PRIMITIVE(code_room) { - CELL used, total_free, max_free; - heap_usage(&code_heap,&used,&total_free,&max_free); - dpush(tag_fixnum((code_heap.segment->size) / 1024)); + cell used, total_free, max_free; + heap_usage(&code,&used,&total_free,&max_free); + dpush(tag_fixnum(code.seg->size / 1024)); dpush(tag_fixnum(used / 1024)); dpush(tag_fixnum(total_free / 1024)); dpush(tag_fixnum(max_free / 1024)); } -F_CODE_BLOCK *forward_xt(F_CODE_BLOCK *compiled) +code_block *forward_xt(code_block *compiled) { - return (F_CODE_BLOCK *)compiled->block.forwarding; + return (code_block *)compiled->block.forwarding; } -void forward_frame_xt(F_STACK_FRAME *frame) +void forward_frame_xt(stack_frame *frame) { - CELL offset = (CELL)FRAME_RETURN_ADDRESS(frame) - (CELL)frame_code(frame); - F_CODE_BLOCK *forwarded = forward_xt(frame_code(frame)); - frame->xt = (XT)(forwarded + 1); - FRAME_RETURN_ADDRESS(frame) = (XT)((CELL)forwarded + offset); + cell offset = (cell)FRAME_RETURN_ADDRESS(frame) - (cell)frame_code(frame); + code_block *forwarded = forward_xt(frame_code(frame)); + frame->xt = forwarded->xt(); + FRAME_RETURN_ADDRESS(frame) = (void *)((cell)forwarded + offset); } void forward_object_xts(void) { begin_scan(); - CELL obj; + cell obj; while((obj = next_object()) != F) { - switch(tagged(obj).type()) + switch(tagged(obj).type()) { case WORD_TYPE: - F_WORD *word = untag(obj); + word *w = untag(obj); - word->code = forward_xt(word->code); - if(word->profiling) - word->profiling = forward_xt(word->profiling); + if(w->code) + w->code = forward_xt(w->code); + if(w->profiling) + w->profiling = forward_xt(w->profiling); break; case QUOTATION_TYPE: - F_QUOTATION *quot = untag(obj); + quotation *quot = untag(obj); if(quot->compiledp != F) quot->code = forward_xt(quot->code); break; case CALLSTACK_TYPE: - F_CALLSTACK *stack = untag(obj); + callstack *stack = untag(obj); iterate_callstack_object(stack,forward_frame_xt); break; @@ -175,17 +175,17 @@ void fixup_object_xts(void) { begin_scan(); - CELL obj; + cell obj; while((obj = next_object()) != F) { - switch(tagged(obj).type()) + switch(tagged(obj).type()) { case WORD_TYPE: update_word_xt(obj); break; case QUOTATION_TYPE: - F_QUOTATION *quot = untag(obj); + quotation *quot = untag(obj); if(quot->compiledp != F) set_quot_xt(quot,quot->code); break; @@ -208,20 +208,20 @@ void compact_code_heap(void) gc(); /* Figure out where the code heap blocks are going to end up */ - CELL size = compute_heap_forwarding(&code_heap); + cell size = compute_heap_forwarding(&code); /* Update word and quotation code pointers */ forward_object_xts(); /* Actually perform the compaction */ - compact_heap(&code_heap); + compact_heap(&code); /* Update word and quotation XTs */ fixup_object_xts(); /* Now update the free list; there will be a single free block at the end */ - build_free_list(&code_heap,size); + build_free_list(&code,size); } } diff --git a/vm/code_heap.hpp b/vm/code_heap.hpp index 57200ba8df..056a6a88c6 100755 --- a/vm/code_heap.hpp +++ b/vm/code_heap.hpp @@ -2,17 +2,17 @@ namespace factor { /* compiled code */ -extern F_HEAP code_heap; +extern heap code; -void init_code_heap(CELL size); +void init_code_heap(cell size); -bool in_code_heap_p(CELL ptr); +bool in_code_heap_p(cell ptr); -void jit_compile_word(CELL word, CELL def, bool relocate); +void jit_compile_word(cell word, cell def, bool relocate); -typedef void (*CODE_HEAP_ITERATOR)(F_CODE_BLOCK *compiled); +typedef void (*code_heap_iterator)(code_block *compiled); -void iterate_code_heap(CODE_HEAP_ITERATOR iter); +void iterate_code_heap(code_heap_iterator iter); void copy_code_heap_roots(void); @@ -22,10 +22,10 @@ PRIMITIVE(code_room); void compact_code_heap(void); -inline static void check_code_pointer(CELL pointer) +inline static void check_code_pointer(cell ptr) { #ifdef FACTOR_DEBUG - assert(pointer >= code_heap.segment->start && pointer < code_heap.segment->end); + assert(in_code_heap_p(ptr)); #endif } diff --git a/vm/contexts.cpp b/vm/contexts.cpp index 3356e365e3..66570abc31 100644 --- a/vm/contexts.cpp +++ b/vm/contexts.cpp @@ -1,29 +1,29 @@ #include "master.hpp" -factor::F_CONTEXT *stack_chain; +factor::context *stack_chain; namespace factor { -CELL ds_size, rs_size; -F_CONTEXT *unused_contexts; +cell ds_size, rs_size; +context *unused_contexts; void reset_datastack(void) { - ds = ds_bot - CELLS; + ds = ds_bot - sizeof(cell); } void reset_retainstack(void) { - rs = rs_bot - CELLS; + rs = rs_bot - sizeof(cell); } -#define RESERVED (64 * CELLS) +#define RESERVED (64 * sizeof(cell)) void fix_stacks(void) { - if(ds + CELLS < ds_bot || ds + RESERVED >= ds_top) reset_datastack(); - if(rs + CELLS < rs_bot || rs + RESERVED >= rs_top) reset_retainstack(); + if(ds + sizeof(cell) < ds_bot || ds + RESERVED >= ds_top) reset_datastack(); + if(rs + sizeof(cell) < rs_bot || rs + RESERVED >= rs_top) reset_retainstack(); } /* called before entry into foreign C code. Note that ds and rs might @@ -37,38 +37,38 @@ void save_stacks(void) } } -F_CONTEXT *alloc_context(void) +context *alloc_context(void) { - F_CONTEXT *context; + context *new_context; if(unused_contexts) { - context = unused_contexts; + new_context = unused_contexts; unused_contexts = unused_contexts->next; } else { - context = (F_CONTEXT *)safe_malloc(sizeof(F_CONTEXT)); - context->datastack_region = alloc_segment(ds_size); - context->retainstack_region = alloc_segment(rs_size); + new_context = (context *)safe_malloc(sizeof(context)); + new_context->datastack_region = alloc_segment(ds_size); + new_context->retainstack_region = alloc_segment(rs_size); } - return context; + return new_context; } -void dealloc_context(F_CONTEXT *context) +void dealloc_context(context *old_context) { - context->next = unused_contexts; - unused_contexts = context; + old_context->next = unused_contexts; + unused_contexts = old_context; } /* called on entry into a compiled callback */ void nest_stacks(void) { - F_CONTEXT *new_stacks = alloc_context(); + context *new_context = alloc_context(); - new_stacks->callstack_bottom = (F_STACK_FRAME *)-1; - new_stacks->callstack_top = (F_STACK_FRAME *)-1; + new_context->callstack_bottom = (stack_frame *)-1; + new_context->callstack_top = (stack_frame *)-1; /* note that these register values are not necessarily valid stack pointers. they are merely saved non-volatile registers, and are @@ -80,15 +80,15 @@ void nest_stacks(void) - Factor callback returns - C function restores registers - C function returns to Factor code */ - new_stacks->datastack_save = ds; - new_stacks->retainstack_save = rs; + new_context->datastack_save = ds; + new_context->retainstack_save = rs; /* save per-callback userenv */ - new_stacks->current_callback_save = userenv[CURRENT_CALLBACK_ENV]; - new_stacks->catchstack_save = userenv[CATCHSTACK_ENV]; + new_context->current_callback_save = userenv[CURRENT_CALLBACK_ENV]; + new_context->catchstack_save = userenv[CATCHSTACK_ENV]; - new_stacks->next = stack_chain; - stack_chain = new_stacks; + new_context->next = stack_chain; + stack_chain = new_context; reset_datastack(); reset_retainstack(); @@ -104,13 +104,13 @@ void unnest_stacks(void) userenv[CURRENT_CALLBACK_ENV] = stack_chain->current_callback_save; userenv[CATCHSTACK_ENV] = stack_chain->catchstack_save; - F_CONTEXT *old_stacks = stack_chain; + context *old_stacks = stack_chain; stack_chain = old_stacks->next; dealloc_context(old_stacks); } /* called on startup */ -void init_stacks(CELL ds_size_, CELL rs_size_) +void init_stacks(cell ds_size_, cell rs_size_) { ds_size = ds_size_; rs_size = rs_size_; @@ -118,17 +118,17 @@ void init_stacks(CELL ds_size_, CELL rs_size_) unused_contexts = NULL; } -bool stack_to_array(CELL bottom, CELL top) +bool stack_to_array(cell bottom, cell top) { - F_FIXNUM depth = (F_FIXNUM)(top - bottom + CELLS); + fixnum depth = (fixnum)(top - bottom + sizeof(cell)); if(depth < 0) return false; else { - F_ARRAY *a = allot_array_internal(depth / CELLS); + array *a = allot_array_internal(depth / sizeof(cell)); memcpy(a + 1,(void*)bottom,depth); - dpush(tag(a)); + dpush(tag(a)); return true; } } @@ -146,40 +146,40 @@ PRIMITIVE(retainstack) } /* returns pointer to top of stack */ -CELL array_to_stack(F_ARRAY *array, CELL bottom) +cell array_to_stack(array *array, cell bottom) { - CELL depth = array_capacity(array) * CELLS; + cell depth = array_capacity(array) * sizeof(cell); memcpy((void*)bottom,array + 1,depth); - return bottom + depth - CELLS; + return bottom + depth - sizeof(cell); } PRIMITIVE(set_datastack) { - ds = array_to_stack(untag_check(dpop()),ds_bot); + ds = array_to_stack(untag_check(dpop()),ds_bot); } PRIMITIVE(set_retainstack) { - rs = array_to_stack(untag_check(dpop()),rs_bot); + rs = array_to_stack(untag_check(dpop()),rs_bot); } /* Used to implement call( */ PRIMITIVE(check_datastack) { - F_FIXNUM out = to_fixnum(dpop()); - F_FIXNUM in = to_fixnum(dpop()); - F_FIXNUM height = out - in; - F_ARRAY *array = untag_check(dpop()); - F_FIXNUM length = array_capacity(array); - F_FIXNUM depth = (ds - ds_bot + CELLS) / CELLS; - if(depth - height != length) + fixnum out = to_fixnum(dpop()); + fixnum in = to_fixnum(dpop()); + fixnum height = out - in; + array *saved_datastack = untag_check(dpop()); + fixnum saved_height = array_capacity(saved_datastack); + fixnum current_height = (ds - ds_bot + sizeof(cell)) / sizeof(cell); + if(current_height - height != saved_height) dpush(F); else { - F_FIXNUM i; - for(i = 0; i < length - in; i++) + fixnum i; + for(i = 0; i < saved_height - in; i++) { - if(((CELL *)ds_bot)[i] != array_nth(array,i)) + if(((cell *)ds_bot)[i] != array_nth(saved_datastack,i)) { dpush(F); return; diff --git a/vm/contexts.hpp b/vm/contexts.hpp index 3bf54e3171..13af17f2f0 100644 --- a/vm/contexts.hpp +++ b/vm/contexts.hpp @@ -6,37 +6,37 @@ namespace factor - callstack_bottom field is 1 - datastack field is 2 - retainstack field is 3 */ -struct F_CONTEXT { +struct context { /* C stack pointer on entry */ - F_STACK_FRAME *callstack_top; - F_STACK_FRAME *callstack_bottom; + stack_frame *callstack_top; + stack_frame *callstack_bottom; /* current datastack top pointer */ - CELL datastack; + cell datastack; /* current retain stack top pointer */ - CELL retainstack; + cell retainstack; /* saved contents of ds register on entry to callback */ - CELL datastack_save; + cell datastack_save; /* saved contents of rs register on entry to callback */ - CELL retainstack_save; + cell retainstack_save; /* memory region holding current datastack */ - F_SEGMENT *datastack_region; + segment *datastack_region; /* memory region holding current retain stack */ - F_SEGMENT *retainstack_region; + segment *retainstack_region; /* saved userenv slots on entry to callback */ - CELL catchstack_save; - CELL current_callback_save; + cell catchstack_save; + cell current_callback_save; - F_CONTEXT *next; + context *next; }; -extern CELL ds_size, rs_size; +extern cell ds_size, rs_size; #define ds_bot (stack_chain->datastack_region->start) #define ds_top (stack_chain->datastack_region->end) @@ -49,7 +49,7 @@ DEFPUSHPOP(r,rs) void reset_datastack(void); void reset_retainstack(void); void fix_stacks(void); -void init_stacks(CELL ds_size, CELL rs_size); +void init_stacks(cell ds_size, cell rs_size); PRIMITIVE(datastack); PRIMITIVE(retainstack); @@ -63,4 +63,4 @@ VM_C_API void unnest_stacks(void); } -VM_C_API factor::F_CONTEXT *stack_chain; +VM_C_API factor::context *stack_chain; diff --git a/vm/cpu-arm.hpp b/vm/cpu-arm.hpp index 1438199a02..235677b274 100755 --- a/vm/cpu-arm.hpp +++ b/vm/cpu-arm.hpp @@ -3,16 +3,14 @@ namespace factor #define FACTOR_CPU_STRING "arm" -register CELL ds asm("r5"); -register CELL rs asm("r6"); - -#define F_FASTCALL +register cell ds asm("r5"); +register cell rs asm("r6"); #define FRAME_RETURN_ADDRESS(frame) *(XT *)(frame_successor(frame) + 1) -void c_to_factor(CELL quot); -void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy); -void throw_impl(CELL quot, F_STACK_FRAME *rewind); -void lazy_jit_compile(CELL quot); +void c_to_factor(cell quot); +void set_callstack(stack_frame *to, stack_frame *from, cell length, void *memcpy); +void throw_impl(cell quot, stack_frame *rewind); +void lazy_jit_compile(cell quot); } diff --git a/vm/cpu-ppc.hpp b/vm/cpu-ppc.hpp index cebb104a81..7e8ae05fac 100755 --- a/vm/cpu-ppc.hpp +++ b/vm/cpu-ppc.hpp @@ -4,14 +4,14 @@ namespace factor #define FACTOR_CPU_STRING "ppc" #define VM_ASM_API -register CELL ds asm("r29"); -register CELL rs asm("r30"); +register cell ds asm("r29"); +register cell rs asm("r30"); -void c_to_factor(CELL quot); -void undefined(CELL word); -void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy); -void throw_impl(CELL quot, F_STACK_FRAME *rewind); -void lazy_jit_compile(CELL quot); -void flush_icache(CELL start, CELL len); +void c_to_factor(cell quot); +void undefined(cell word); +void set_callstack(stack_frame *to, stack_frame *from, cell length, void *memcpy); +void throw_impl(cell quot, stack_frame *rewind); +void lazy_jit_compile(cell quot); +void flush_icache(cell start, cell len); } diff --git a/vm/cpu-x86.32.hpp b/vm/cpu-x86.32.hpp index 0629571aed..6b6328aa4f 100755 --- a/vm/cpu-x86.32.hpp +++ b/vm/cpu-x86.32.hpp @@ -3,8 +3,8 @@ namespace factor #define FACTOR_CPU_STRING "x86.32" -register CELL ds asm("esi"); -register CELL rs asm("edi"); +register cell ds asm("esi"); +register cell rs asm("edi"); #define VM_ASM_API extern "C" __attribute__ ((regparm (2))) diff --git a/vm/cpu-x86.64.hpp b/vm/cpu-x86.64.hpp index fdc5158a73..be71a78aa8 100644 --- a/vm/cpu-x86.64.hpp +++ b/vm/cpu-x86.64.hpp @@ -3,8 +3,8 @@ namespace factor #define FACTOR_CPU_STRING "x86.64" -register CELL ds asm("r14"); -register CELL rs asm("r15"); +register cell ds asm("r14"); +register cell rs asm("r15"); #define VM_ASM_API extern "C" diff --git a/vm/cpu-x86.hpp b/vm/cpu-x86.hpp index f730d38c2f..c0b4651811 100755 --- a/vm/cpu-x86.hpp +++ b/vm/cpu-x86.hpp @@ -3,11 +3,11 @@ namespace factor { -#define FRAME_RETURN_ADDRESS(frame) *(XT *)(frame_successor(frame) + 1) +#define FRAME_RETURN_ADDRESS(frame) *(void **)(frame_successor(frame) + 1) -inline static void flush_icache(CELL start, CELL len) {} +inline static void flush_icache(cell start, cell len) {} -inline static void check_call_site(CELL return_address) +inline static void check_call_site(cell return_address) { /* An x86 CALL instruction looks like so: |e8|..|..|..|..| @@ -19,26 +19,26 @@ inline static void check_call_site(CELL return_address) #endif } -inline static CELL get_call_target(CELL return_address) +inline static void *get_call_target(cell return_address) { check_call_site(return_address); - return *(int *)(return_address - 4) + return_address; + return (void *)(*(int *)(return_address - 4) + return_address); } -inline static void set_call_target(CELL return_address, CELL target) +inline static void set_call_target(cell return_address, void *target) { check_call_site(return_address); - *(int *)(return_address - 4) = (target - return_address); + *(int *)(return_address - 4) = ((cell)target - return_address); } /* Defined in assembly */ -VM_ASM_API void c_to_factor(CELL quot); -VM_ASM_API void throw_impl(CELL quot, F_STACK_FRAME *rewind_to); -VM_ASM_API void lazy_jit_compile(CELL quot); +VM_ASM_API void c_to_factor(cell quot); +VM_ASM_API void throw_impl(cell quot, stack_frame *rewind_to); +VM_ASM_API void lazy_jit_compile(cell quot); -VM_C_API void set_callstack(F_STACK_FRAME *to, - F_STACK_FRAME *from, - CELL length, +VM_C_API void set_callstack(stack_frame *to, + stack_frame *from, + cell length, void *(*memcpy)(void*,const void*, size_t)); } diff --git a/vm/data_gc.cpp b/vm/data_gc.cpp index 302859ebfb..57934f92a6 100755 --- a/vm/data_gc.cpp +++ b/vm/data_gc.cpp @@ -4,10 +4,10 @@ namespace factor { /* used during garbage collection only */ -F_ZONE *newspace; +zone *newspace; bool performing_gc; bool performing_compaction; -CELL collecting_gen; +cell collecting_gen; /* if true, we collecting AGING space for the second time, so if it is still full, we go on to collect TENURED */ @@ -17,21 +17,21 @@ bool collecting_aging_again; up to try collecting the next generation. */ jmp_buf gc_jmp; -F_GC_STATS gc_stats[MAX_GEN_COUNT]; +gc_stats stats[MAX_GEN_COUNT]; u64 cards_scanned; u64 decks_scanned; u64 card_scan_time; -CELL code_heap_scans; +cell code_heap_scans; /* What generation was being collected when copy_code_heap_roots() was last called? Until the next call to add_code_block(), future collections of younger generations don't have to touch the code heap. */ -CELL last_code_heap_scan; +cell last_code_heap_scan; /* sometimes we grow the heap */ bool growing_data_heap; -F_DATA_HEAP *old_data_heap; +data_heap *old_data_heap; void init_data_gc(void) { @@ -41,13 +41,13 @@ void init_data_gc(void) } /* Given a pointer to oldspace, copy it to newspace */ -static F_OBJECT *copy_untagged_object_impl(F_OBJECT *pointer, CELL size) +static object *copy_untagged_object_impl(object *pointer, cell size) { if(newspace->here + size >= newspace->end) longjmp(gc_jmp,1); - F_OBJECT *newpointer = allot_zone(newspace,size); + object *newpointer = allot_zone(newspace,size); - F_GC_STATS *s = &gc_stats[collecting_gen]; + gc_stats *s = &stats[collecting_gen]; s->object_count++; s->bytes_copied += size; @@ -55,42 +55,42 @@ static F_OBJECT *copy_untagged_object_impl(F_OBJECT *pointer, CELL size) return newpointer; } -static F_OBJECT *copy_object_impl(F_OBJECT *untagged) +static object *copy_object_impl(object *untagged) { - F_OBJECT *newpointer = copy_untagged_object_impl(untagged,untagged_object_size(untagged)); - untagged->header.forward_to(newpointer); + object *newpointer = copy_untagged_object_impl(untagged,untagged_object_size(untagged)); + untagged->h.forward_to(newpointer); return newpointer; } -static bool should_copy_p(F_OBJECT *untagged) +static bool should_copy_p(object *untagged) { if(in_zone(newspace,untagged)) return false; if(collecting_gen == TENURED) return true; else if(HAVE_AGING_P && collecting_gen == AGING) - return !in_zone(&data_heap->generations[TENURED],untagged); + return !in_zone(&data->generations[TENURED],untagged); else if(collecting_gen == NURSERY) return in_zone(&nursery,untagged); else { - critical_error("Bug in should_copy_p",(CELL)untagged); + critical_error("Bug in should_copy_p",(cell)untagged); return false; } } /* Follow a chain of forwarding pointers */ -static F_OBJECT *resolve_forwarding(F_OBJECT *untagged) +static object *resolve_forwarding(object *untagged) { check_data_pointer(untagged); /* is there another forwarding pointer? */ - if(untagged->header.forwarding_pointer_p()) - return resolve_forwarding(untagged->header.forwarding_pointer()); + if(untagged->h.forwarding_pointer_p()) + return resolve_forwarding(untagged->h.forwarding_pointer()); /* we've found the destination */ else { - untagged->header.check_header(); + untagged->h.check_header(); if(should_copy_p(untagged)) return copy_object_impl(untagged); else @@ -102,40 +102,40 @@ template static T *copy_untagged_object(T *untagged) { check_data_pointer(untagged); - if(untagged->header.forwarding_pointer_p()) - untagged = (T *)resolve_forwarding(untagged->header.forwarding_pointer()); + if(untagged->h.forwarding_pointer_p()) + untagged = (T *)resolve_forwarding(untagged->h.forwarding_pointer()); else { - untagged->header.check_header(); + untagged->h.check_header(); untagged = (T *)copy_object_impl(untagged); } return untagged; } -static CELL copy_object(CELL pointer) +static cell copy_object(cell pointer) { - return RETAG(copy_untagged_object(untag(pointer)),TAG(pointer)); + return RETAG(copy_untagged_object(untag(pointer)),TAG(pointer)); } -void copy_handle(CELL *handle) +void copy_handle(cell *handle) { - CELL pointer = *handle; + cell pointer = *handle; if(!immediate_p(pointer)) { - F_OBJECT *object = untag(pointer); - check_data_pointer(object); - if(should_copy_p(object)) + object *obj = untag(pointer); + check_data_pointer(obj); + if(should_copy_p(obj)) *handle = copy_object(pointer); } } /* Scan all the objects in the card */ -static void copy_card(F_CARD *ptr, CELL gen, CELL here) +static void copy_card(card *ptr, cell gen, cell here) { - CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + CARD_OFFSET(ptr); - CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1); + cell card_scan = card_to_addr(ptr) + card_offset(ptr); + cell card_end = card_to_addr(ptr + 1); if(here < card_end) card_end = here; @@ -145,12 +145,12 @@ static void copy_card(F_CARD *ptr, CELL gen, CELL here) cards_scanned++; } -static void copy_card_deck(F_DECK *deck, CELL gen, F_CARD mask, F_CARD unmask) +static void copy_card_deck(card_deck *deck, cell gen, card mask, card unmask) { - F_CARD *first_card = DECK_TO_CARD(deck); - F_CARD *last_card = DECK_TO_CARD(deck + 1); + card *first_card = deck_to_card(deck); + card *last_card = deck_to_card(deck + 1); - CELL here = data_heap->generations[gen].here; + cell here = data->generations[gen].here; u32 *quad_ptr; u32 quad_mask = mask | (mask << 8) | (mask << 16) | (mask << 24); @@ -159,7 +159,7 @@ static void copy_card_deck(F_DECK *deck, CELL gen, F_CARD mask, F_CARD unmask) { if(*quad_ptr & quad_mask) { - F_CARD *ptr = (F_CARD *)quad_ptr; + card *ptr = (card *)quad_ptr; int card; for(card = 0; card < 4; card++) @@ -177,12 +177,12 @@ static void copy_card_deck(F_DECK *deck, CELL gen, F_CARD mask, F_CARD unmask) } /* Copy all newspace objects referenced from marked cards to the destination */ -static void copy_gen_cards(CELL gen) +static void copy_gen_cards(cell gen) { - F_DECK *first_deck = ADDR_TO_DECK(data_heap->generations[gen].start); - F_DECK *last_deck = ADDR_TO_DECK(data_heap->generations[gen].end); + card_deck *first_deck = addr_to_deck(data->generations[gen].start); + card_deck *last_deck = addr_to_deck(data->generations[gen].end); - F_CARD mask, unmask; + card mask, unmask; /* if we are collecting the nursery, we care about old->nursery pointers but not old->aging pointers */ @@ -230,7 +230,7 @@ static void copy_gen_cards(CELL gen) return; } - F_DECK *ptr; + card_deck *ptr; for(ptr = first_deck; ptr < last_deck; ptr++) { @@ -248,38 +248,38 @@ static void copy_cards(void) { u64 start = current_micros(); - CELL i; - for(i = collecting_gen + 1; i < data_heap->gen_count; i++) + cell i; + for(i = collecting_gen + 1; i < data->gen_count; i++) copy_gen_cards(i); card_scan_time += (current_micros() - start); } /* Copy all tagged pointers in a range of memory */ -static void copy_stack_elements(F_SEGMENT *region, CELL top) +static void copy_stack_elements(segment *region, cell top) { - CELL ptr = region->start; + cell ptr = region->start; - for(; ptr <= top; ptr += CELLS) - copy_handle((CELL*)ptr); + for(; ptr <= top; ptr += sizeof(cell)) + copy_handle((cell*)ptr); } static void copy_registered_locals(void) { - CELL scan = gc_locals_region->start; + cell scan = gc_locals_region->start; - for(; scan <= gc_locals; scan += CELLS) - copy_handle(*(CELL **)scan); + for(; scan <= gc_locals; scan += sizeof(cell)) + copy_handle(*(cell **)scan); } static void copy_registered_bignums(void) { - CELL scan = gc_bignums_region->start; + cell scan = gc_bignums_region->start; - for(; scan <= gc_bignums; scan += CELLS) + for(; scan <= gc_bignums; scan += sizeof(cell)) { - F_BIGNUM **handle = *(F_BIGNUM ***)scan; - F_BIGNUM *pointer = *handle; + bignum **handle = *(bignum ***)scan; + bignum *pointer = *handle; if(pointer) { @@ -287,7 +287,7 @@ static void copy_registered_bignums(void) if(should_copy_p(pointer)) *handle = copy_untagged_object(pointer); #ifdef FACTOR_DEBUG - assert((*handle)->header.hi_tag() == BIGNUM_TYPE); + assert((*handle)->h.hi_tag() == BIGNUM_TYPE); #endif } } @@ -308,7 +308,7 @@ static void copy_roots(void) if(!performing_compaction) { save_stacks(); - F_CONTEXT *stacks = stack_chain; + context *stacks = stack_chain; while(stacks) { @@ -329,56 +329,56 @@ static void copy_roots(void) copy_handle(&userenv[i]); } -static CELL copy_next_from_nursery(CELL scan) +static cell copy_next_from_nursery(cell scan) { - CELL *obj = (CELL *)scan; - CELL *end = (CELL *)(scan + binary_payload_start((F_OBJECT *)scan)); + cell *obj = (cell *)scan; + cell *end = (cell *)(scan + binary_payload_start((object *)scan)); if(obj != end) { obj++; - CELL nursery_start = nursery.start; - CELL nursery_end = nursery.end; + cell nursery_start = nursery.start; + cell nursery_end = nursery.end; for(; obj < end; obj++) { - CELL pointer = *obj; + cell pointer = *obj; if(!immediate_p(pointer)) { - check_data_pointer((F_OBJECT *)pointer); + check_data_pointer((object *)pointer); if(pointer >= nursery_start && pointer < nursery_end) *obj = copy_object(pointer); } } } - return scan + untagged_object_size((F_OBJECT *)scan); + return scan + untagged_object_size((object *)scan); } -static CELL copy_next_from_aging(CELL scan) +static cell copy_next_from_aging(cell scan) { - CELL *obj = (CELL *)scan; - CELL *end = (CELL *)(scan + binary_payload_start((F_OBJECT *)scan)); + cell *obj = (cell *)scan; + cell *end = (cell *)(scan + binary_payload_start((object *)scan)); if(obj != end) { obj++; - CELL tenured_start = data_heap->generations[TENURED].start; - CELL tenured_end = data_heap->generations[TENURED].end; + cell tenured_start = data->generations[TENURED].start; + cell tenured_end = data->generations[TENURED].end; - CELL newspace_start = newspace->start; - CELL newspace_end = newspace->end; + cell newspace_start = newspace->start; + cell newspace_end = newspace->end; for(; obj < end; obj++) { - CELL pointer = *obj; + cell pointer = *obj; if(!immediate_p(pointer)) { - check_data_pointer((F_OBJECT *)pointer); + check_data_pointer((object *)pointer); if(!(pointer >= newspace_start && pointer < newspace_end) && !(pointer >= tenured_start && pointer < tenured_end)) *obj = copy_object(pointer); @@ -386,40 +386,40 @@ static CELL copy_next_from_aging(CELL scan) } } - return scan + untagged_object_size((F_OBJECT *)scan); + return scan + untagged_object_size((object *)scan); } -static CELL copy_next_from_tenured(CELL scan) +static cell copy_next_from_tenured(cell scan) { - CELL *obj = (CELL *)scan; - CELL *end = (CELL *)(scan + binary_payload_start((F_OBJECT *)scan)); + cell *obj = (cell *)scan; + cell *end = (cell *)(scan + binary_payload_start((object *)scan)); if(obj != end) { obj++; - CELL newspace_start = newspace->start; - CELL newspace_end = newspace->end; + cell newspace_start = newspace->start; + cell newspace_end = newspace->end; for(; obj < end; obj++) { - CELL pointer = *obj; + cell pointer = *obj; if(!immediate_p(pointer)) { - check_data_pointer((F_OBJECT *)pointer); + check_data_pointer((object *)pointer); if(!(pointer >= newspace_start && pointer < newspace_end)) *obj = copy_object(pointer); } } } - mark_object_code_block((F_OBJECT *)scan); + mark_object_code_block((object *)scan); - return scan + untagged_object_size((F_OBJECT *)scan); + return scan + untagged_object_size((object *)scan); } -void copy_reachable_objects(CELL scan, CELL *end) +void copy_reachable_objects(cell scan, cell *end) { if(collecting_gen == NURSERY) { @@ -439,26 +439,26 @@ void copy_reachable_objects(CELL scan, CELL *end) } /* Prepare to start copying reachable objects into an unused zone */ -static void begin_gc(CELL requested_bytes) +static void begin_gc(cell requested_bytes) { if(growing_data_heap) { if(collecting_gen != TENURED) critical_error("Invalid parameters to begin_gc",0); - old_data_heap = data_heap; + old_data_heap = data; set_data_heap(grow_data_heap(old_data_heap,requested_bytes)); - newspace = &data_heap->generations[TENURED]; + newspace = &data->generations[TENURED]; } else if(collecting_accumulation_gen_p()) { /* when collecting one of these generations, rotate it with the semispace */ - F_ZONE z = data_heap->generations[collecting_gen]; - data_heap->generations[collecting_gen] = data_heap->semispaces[collecting_gen]; - data_heap->semispaces[collecting_gen] = z; + zone z = data->generations[collecting_gen]; + data->generations[collecting_gen] = data->semispaces[collecting_gen]; + data->semispaces[collecting_gen] = z; reset_generation(collecting_gen); - newspace = &data_heap->generations[collecting_gen]; + newspace = &data->generations[collecting_gen]; clear_cards(collecting_gen,collecting_gen); clear_decks(collecting_gen,collecting_gen); clear_allot_markers(collecting_gen,collecting_gen); @@ -468,13 +468,13 @@ static void begin_gc(CELL requested_bytes) /* when collecting a younger generation, we copy reachable objects to the next oldest generation, so we set the newspace so the next generation. */ - newspace = &data_heap->generations[collecting_gen + 1]; + newspace = &data->generations[collecting_gen + 1]; } } -static void end_gc(CELL gc_elapsed) +static void end_gc(cell gc_elapsed) { - F_GC_STATS *s = &gc_stats[collecting_gen]; + gc_stats *s = &stats[collecting_gen]; s->collections++; s->gc_time += gc_elapsed; @@ -513,9 +513,9 @@ static void end_gc(CELL gc_elapsed) /* Collect gen and all younger generations. If growing_data_heap_ is true, we must grow the data heap to such a size that an allocation of requested_bytes won't fail */ -void garbage_collection(CELL gen, +void garbage_collection(cell gen, bool growing_data_heap_, - CELL requested_bytes) + cell requested_bytes) { if(gc_off) { @@ -539,7 +539,7 @@ void garbage_collection(CELL gen, growing_data_heap = true; /* see the comment in unmark_marked() */ - unmark_marked(&code_heap); + unmark_marked(&code); } /* we try collecting AGING space twice before going on to collect TENURED */ @@ -559,7 +559,7 @@ void garbage_collection(CELL gen, begin_gc(requested_bytes); /* initialize chase pointer */ - CELL scan = newspace->here; + cell scan = newspace->here; /* collect objects referenced from stacks and environment */ copy_roots(); @@ -576,7 +576,7 @@ void garbage_collection(CELL gen, code_heap_scans++; if(collecting_gen == TENURED) - free_unmarked(&code_heap,(HEAP_ITERATOR)update_literal_and_word_references); + free_unmarked(&code,(heap_iterator)update_literal_and_word_references); else copy_code_heap_roots(); @@ -586,7 +586,7 @@ void garbage_collection(CELL gen, last_code_heap_scan = collecting_gen + 1; } - CELL gc_elapsed = (current_micros() - start); + cell gc_elapsed = (current_micros() - start); end_gc(gc_elapsed); @@ -605,39 +605,39 @@ PRIMITIVE(gc) PRIMITIVE(gc_stats) { - growable_array stats; + growable_array result; - CELL i; + cell i; u64 total_gc_time = 0; for(i = 0; i < MAX_GEN_COUNT; i++) { - F_GC_STATS *s = &gc_stats[i]; - stats.add(allot_cell(s->collections)); - stats.add(tag(long_long_to_bignum(s->gc_time))); - stats.add(tag(long_long_to_bignum(s->max_gc_time))); - stats.add(allot_cell(s->collections == 0 ? 0 : s->gc_time / s->collections)); - stats.add(allot_cell(s->object_count)); - stats.add(tag(long_long_to_bignum(s->bytes_copied))); + gc_stats *s = &stats[i]; + result.add(allot_cell(s->collections)); + result.add(tag(long_long_to_bignum(s->gc_time))); + result.add(tag(long_long_to_bignum(s->max_gc_time))); + result.add(allot_cell(s->collections == 0 ? 0 : s->gc_time / s->collections)); + result.add(allot_cell(s->object_count)); + result.add(tag(long_long_to_bignum(s->bytes_copied))); total_gc_time += s->gc_time; } - stats.add(tag(ulong_long_to_bignum(total_gc_time))); - stats.add(tag(ulong_long_to_bignum(cards_scanned))); - stats.add(tag(ulong_long_to_bignum(decks_scanned))); - stats.add(tag(ulong_long_to_bignum(card_scan_time))); - stats.add(allot_cell(code_heap_scans)); + result.add(tag(ulong_long_to_bignum(total_gc_time))); + result.add(tag(ulong_long_to_bignum(cards_scanned))); + result.add(tag(ulong_long_to_bignum(decks_scanned))); + result.add(tag(ulong_long_to_bignum(card_scan_time))); + result.add(allot_cell(code_heap_scans)); - stats.trim(); - dpush(stats.array.value()); + result.trim(); + dpush(result.elements.value()); } void clear_gc_stats(void) { int i; for(i = 0; i < MAX_GEN_COUNT; i++) - memset(&gc_stats[i],0,sizeof(F_GC_STATS)); + memset(&stats[i],0,sizeof(stats)); cards_scanned = 0; decks_scanned = 0; @@ -654,22 +654,22 @@ PRIMITIVE(clear_gc_stats) to coalesce equal but distinct quotations and wrappers. */ PRIMITIVE(become) { - F_ARRAY *new_objects = untag_check(dpop()); - F_ARRAY *old_objects = untag_check(dpop()); + array *new_objects = untag_check(dpop()); + array *old_objects = untag_check(dpop()); - CELL capacity = array_capacity(new_objects); + cell capacity = array_capacity(new_objects); if(capacity != array_capacity(old_objects)) critical_error("bad parameters to become",0); - CELL i; + cell i; for(i = 0; i < capacity; i++) { - tagged old_obj(array_nth(old_objects,i)); - tagged new_obj(array_nth(new_objects,i)); + tagged old_obj(array_nth(old_objects,i)); + tagged new_obj(array_nth(new_objects,i)); if(old_obj != new_obj) - old_obj->header.forward_to(new_obj.untagged()); + old_obj->h.forward_to(new_obj.untagged()); } gc(); diff --git a/vm/data_gc.hpp b/vm/data_gc.hpp index 1d911b1828..2869179394 100755 --- a/vm/data_gc.hpp +++ b/vm/data_gc.hpp @@ -2,21 +2,21 @@ namespace factor { /* statistics */ -struct F_GC_STATS { - CELL collections; +struct gc_stats { + cell collections; u64 gc_time; u64 max_gc_time; - CELL object_count; + cell object_count; u64 bytes_copied; }; -extern F_ZONE *newspace; +extern zone *newspace; extern bool performing_compaction; -extern CELL collecting_gen; +extern cell collecting_gen; extern bool collecting_aging_again; -extern CELL last_code_heap_scan; +extern cell last_code_heap_scan; void init_data_gc(void); @@ -30,29 +30,38 @@ inline static bool collecting_accumulation_gen_p(void) || collecting_gen == TENURED); } -void copy_handle(CELL *handle); +void copy_handle(cell *handle); -void garbage_collection(volatile CELL gen, +void garbage_collection(volatile cell gen, bool growing_data_heap_, - CELL requested_bytes); + cell requested_bytes); /* We leave this many bytes free at the top of the nursery so that inline allocation (which does not call GC because of possible roots in volatile registers) does not run out of memory */ #define ALLOT_BUFFER_ZONE 1024 +inline static object *allot_zone(zone *z, cell a) +{ + cell h = z->here; + z->here = h + align8(a); + object *obj = (object *)h; + allot_barrier(obj); + return obj; +} + /* * It is up to the caller to fill in the object's fields in a meaningful * fashion! */ -inline static F_OBJECT *allot_object(F_HEADER header, CELL size) +inline static object *allot_object(header header, cell size) { #ifdef GC_DEBUG if(!gc_off) gc(); #endif - F_OBJECT *object; + object *obj; if(nursery.size - ALLOT_BUFFER_ZONE > size) { @@ -60,48 +69,48 @@ inline static F_OBJECT *allot_object(F_HEADER header, CELL size) if(nursery.here + ALLOT_BUFFER_ZONE + size > nursery.end) garbage_collection(NURSERY,false,0); - CELL h = nursery.here; + cell h = nursery.here; nursery.here = h + align8(size); - object = (F_OBJECT *)h; + obj = (object *)h; } /* If the object is bigger than the nursery, allocate it in tenured space */ else { - F_ZONE *tenured = &data_heap->generations[TENURED]; + zone *tenured = &data->generations[TENURED]; /* If tenured space does not have enough room, collect */ if(tenured->here + size > tenured->end) { gc(); - tenured = &data_heap->generations[TENURED]; + tenured = &data->generations[TENURED]; } /* If it still won't fit, grow the heap */ if(tenured->here + size > tenured->end) { garbage_collection(TENURED,true,size); - tenured = &data_heap->generations[TENURED]; + tenured = &data->generations[TENURED]; } - object = allot_zone(tenured,size); + obj = allot_zone(tenured,size); /* Allows initialization code to store old->new pointers without hitting the write barrier in the common case of a nursery allocation */ - write_barrier(object); + write_barrier(obj); } - object->header = header; - return object; + obj->h = header; + return obj; } -template T *allot(CELL size) +template T *allot(cell size) { - return (T *)allot_object(F_HEADER(T::type_number),size); + return (T *)allot_object(header(T::type_number),size); } -void copy_reachable_objects(CELL scan, CELL *end); +void copy_reachable_objects(cell scan, cell *end); PRIMITIVE(gc); PRIMITIVE(gc_stats); @@ -111,30 +120,29 @@ PRIMITIVE(become); extern bool growing_data_heap; -inline static void check_data_pointer(F_OBJECT *pointer) +inline static void check_data_pointer(object *pointer) { #ifdef FACTOR_DEBUG if(!growing_data_heap) { - assert((CELL)pointer >= data_heap->segment->start - && (CELL)pointer < data_heap->segment->end); + assert((cell)pointer >= data->seg->start + && (cell)pointer < data->seg->end); } #endif } -inline static void check_tagged_pointer(CELL tagged) +inline static void check_tagged_pointer(cell tagged) { #ifdef FACTOR_DEBUG if(!immediate_p(tagged)) { - F_OBJECT *object = untag(tagged); - check_data_pointer(object); - object->header.hi_tag(); + object *obj = untag(tagged); + check_data_pointer(obj); + obj->h.hi_tag(); } #endif } VM_C_API void minor_gc(void); - } diff --git a/vm/data_heap.cpp b/vm/data_heap.cpp index fe8d887b89..d83773de9c 100644 --- a/vm/data_heap.cpp +++ b/vm/data_heap.cpp @@ -1,6 +1,6 @@ #include "master.hpp" -factor::F_ZONE nursery; +factor::zone nursery; namespace factor { @@ -9,14 +9,14 @@ namespace factor bool secure_gc; /* new objects are allocated here */ -VM_C_API F_ZONE nursery; +VM_C_API zone nursery; /* GC is off during heap walking */ bool gc_off; -F_DATA_HEAP *data_heap; +data_heap *data; -CELL init_zone(F_ZONE *z, CELL size, CELL start) +cell init_zone(zone *z, cell size, cell start) { z->size = size; z->start = z->here = start; @@ -26,127 +26,127 @@ CELL init_zone(F_ZONE *z, CELL size, CELL start) void init_card_decks(void) { - CELL start = align(data_heap->segment->start,DECK_SIZE); - allot_markers_offset = (CELL)data_heap->allot_markers - (start >> CARD_BITS); - cards_offset = (CELL)data_heap->cards - (start >> CARD_BITS); - decks_offset = (CELL)data_heap->decks - (start >> DECK_BITS); + cell start = align(data->seg->start,DECK_SIZE); + allot_markers_offset = (cell)data->allot_markers - (start >> CARD_BITS); + cards_offset = (cell)data->cards - (start >> CARD_BITS); + decks_offset = (cell)data->decks - (start >> DECK_BITS); } -F_DATA_HEAP *alloc_data_heap(CELL gens, - CELL young_size, - CELL aging_size, - CELL tenured_size) +data_heap *alloc_data_heap(cell gens, + cell young_size, + cell aging_size, + cell tenured_size) { young_size = align(young_size,DECK_SIZE); aging_size = align(aging_size,DECK_SIZE); tenured_size = align(tenured_size,DECK_SIZE); - F_DATA_HEAP *data_heap = (F_DATA_HEAP *)safe_malloc(sizeof(F_DATA_HEAP)); - data_heap->young_size = young_size; - data_heap->aging_size = aging_size; - data_heap->tenured_size = tenured_size; - data_heap->gen_count = gens; + data_heap *data = (data_heap *)safe_malloc(sizeof(data_heap)); + data->young_size = young_size; + data->aging_size = aging_size; + data->tenured_size = tenured_size; + data->gen_count = gens; - CELL total_size; - if(data_heap->gen_count == 2) + cell total_size; + if(data->gen_count == 2) total_size = young_size + 2 * tenured_size; - else if(data_heap->gen_count == 3) + else if(data->gen_count == 3) total_size = young_size + 2 * aging_size + 2 * tenured_size; else { - fatal_error("Invalid number of generations",data_heap->gen_count); + fatal_error("Invalid number of generations",data->gen_count); return NULL; /* can't happen */ } total_size += DECK_SIZE; - data_heap->segment = alloc_segment(total_size); + data->seg = alloc_segment(total_size); - data_heap->generations = (F_ZONE *)safe_malloc(sizeof(F_ZONE) * data_heap->gen_count); - data_heap->semispaces = (F_ZONE *)safe_malloc(sizeof(F_ZONE) * data_heap->gen_count); + data->generations = (zone *)safe_malloc(sizeof(zone) * data->gen_count); + data->semispaces = (zone *)safe_malloc(sizeof(zone) * data->gen_count); - CELL cards_size = total_size >> CARD_BITS; - data_heap->allot_markers = (CELL *)safe_malloc(cards_size); - data_heap->allot_markers_end = data_heap->allot_markers + cards_size; + cell cards_size = total_size >> CARD_BITS; + data->allot_markers = (cell *)safe_malloc(cards_size); + data->allot_markers_end = data->allot_markers + cards_size; - data_heap->cards = (CELL *)safe_malloc(cards_size); - data_heap->cards_end = data_heap->cards + cards_size; + data->cards = (cell *)safe_malloc(cards_size); + data->cards_end = data->cards + cards_size; - CELL decks_size = total_size >> DECK_BITS; - data_heap->decks = (CELL *)safe_malloc(decks_size); - data_heap->decks_end = data_heap->decks + decks_size; + cell decks_size = total_size >> DECK_BITS; + data->decks = (cell *)safe_malloc(decks_size); + data->decks_end = data->decks + decks_size; - CELL alloter = align(data_heap->segment->start,DECK_SIZE); + cell alloter = align(data->seg->start,DECK_SIZE); - alloter = init_zone(&data_heap->generations[TENURED],tenured_size,alloter); - alloter = init_zone(&data_heap->semispaces[TENURED],tenured_size,alloter); + alloter = init_zone(&data->generations[TENURED],tenured_size,alloter); + alloter = init_zone(&data->semispaces[TENURED],tenured_size,alloter); - if(data_heap->gen_count == 3) + if(data->gen_count == 3) { - alloter = init_zone(&data_heap->generations[AGING],aging_size,alloter); - alloter = init_zone(&data_heap->semispaces[AGING],aging_size,alloter); + alloter = init_zone(&data->generations[AGING],aging_size,alloter); + alloter = init_zone(&data->semispaces[AGING],aging_size,alloter); } - if(data_heap->gen_count >= 2) + if(data->gen_count >= 2) { - alloter = init_zone(&data_heap->generations[NURSERY],young_size,alloter); - alloter = init_zone(&data_heap->semispaces[NURSERY],0,alloter); + alloter = init_zone(&data->generations[NURSERY],young_size,alloter); + alloter = init_zone(&data->semispaces[NURSERY],0,alloter); } - if(data_heap->segment->end - alloter > DECK_SIZE) + if(data->seg->end - alloter > DECK_SIZE) critical_error("Bug in alloc_data_heap",alloter); - return data_heap; + return data; } -F_DATA_HEAP *grow_data_heap(F_DATA_HEAP *data_heap, CELL requested_bytes) +data_heap *grow_data_heap(data_heap *data, cell requested_bytes) { - CELL new_tenured_size = (data_heap->tenured_size * 2) + requested_bytes; + cell new_tenured_size = (data->tenured_size * 2) + requested_bytes; - return alloc_data_heap(data_heap->gen_count, - data_heap->young_size, - data_heap->aging_size, + return alloc_data_heap(data->gen_count, + data->young_size, + data->aging_size, new_tenured_size); } -void dealloc_data_heap(F_DATA_HEAP *data_heap) +void dealloc_data_heap(data_heap *data) { - dealloc_segment(data_heap->segment); - free(data_heap->generations); - free(data_heap->semispaces); - free(data_heap->allot_markers); - free(data_heap->cards); - free(data_heap->decks); - free(data_heap); + dealloc_segment(data->seg); + free(data->generations); + free(data->semispaces); + free(data->allot_markers); + free(data->cards); + free(data->decks); + free(data); } -void clear_cards(CELL from, CELL to) +void clear_cards(cell from, cell to) { /* NOTE: reverse order due to heap layout. */ - F_CARD *first_card = ADDR_TO_CARD(data_heap->generations[to].start); - F_CARD *last_card = ADDR_TO_CARD(data_heap->generations[from].end); + card *first_card = addr_to_card(data->generations[to].start); + card *last_card = addr_to_card(data->generations[from].end); memset(first_card,0,last_card - first_card); } -void clear_decks(CELL from, CELL to) +void clear_decks(cell from, cell to) { /* NOTE: reverse order due to heap layout. */ - F_DECK *first_deck = ADDR_TO_DECK(data_heap->generations[to].start); - F_DECK *last_deck = ADDR_TO_DECK(data_heap->generations[from].end); + card_deck *first_deck = addr_to_deck(data->generations[to].start); + card_deck *last_deck = addr_to_deck(data->generations[from].end); memset(first_deck,0,last_deck - first_deck); } -void clear_allot_markers(CELL from, CELL to) +void clear_allot_markers(cell from, cell to) { /* NOTE: reverse order due to heap layout. */ - F_CARD *first_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[to].start); - F_CARD *last_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[from].end); + card *first_card = addr_to_allot_marker((object *)data->generations[to].start); + card *last_card = addr_to_allot_marker((object *)data->generations[from].end); memset(first_card,INVALID_ALLOT_MARKER,last_card - first_card); } -void reset_generation(CELL i) +void reset_generation(cell i) { - F_ZONE *z = (i == NURSERY ? &nursery : &data_heap->generations[i]); + zone *z = (i == NURSERY ? &nursery : &data->generations[i]); z->here = z->start; if(secure_gc) @@ -155,9 +155,9 @@ void reset_generation(CELL i) /* After garbage collection, any generations which are now empty need to have their allocation pointers and cards reset. */ -void reset_generations(CELL from, CELL to) +void reset_generations(cell from, cell to) { - CELL i; + cell i; for(i = from; i <= to; i++) reset_generation(i); @@ -166,29 +166,29 @@ void reset_generations(CELL from, CELL to) clear_allot_markers(from,to); } -void set_data_heap(F_DATA_HEAP *data_heap_) +void set_data_heap(data_heap *data_) { - data_heap = data_heap_; - nursery = data_heap->generations[NURSERY]; + data = data_; + nursery = data->generations[NURSERY]; init_card_decks(); clear_cards(NURSERY,TENURED); clear_decks(NURSERY,TENURED); clear_allot_markers(NURSERY,TENURED); } -void init_data_heap(CELL gens, - CELL young_size, - CELL aging_size, - CELL tenured_size, +void init_data_heap(cell gens, + cell young_size, + cell aging_size, + cell tenured_size, bool secure_gc_) { set_data_heap(alloc_data_heap(gens,young_size,aging_size,tenured_size)); gc_locals_region = alloc_segment(getpagesize()); - gc_locals = gc_locals_region->start - CELLS; + gc_locals = gc_locals_region->start - sizeof(cell); gc_bignums_region = alloc_segment(getpagesize()); - gc_bignums = gc_bignums_region->start - CELLS; + gc_bignums = gc_bignums_region->start - sizeof(cell); secure_gc = secure_gc_; @@ -196,57 +196,51 @@ void init_data_heap(CELL gens, } /* Size of the object pointed to by a tagged pointer */ -CELL object_size(CELL tagged) +cell object_size(cell tagged) { if(immediate_p(tagged)) return 0; else - return untagged_object_size(untag(tagged)); + return untagged_object_size(untag(tagged)); } /* Size of the object pointed to by an untagged pointer */ -CELL untagged_object_size(F_OBJECT *pointer) +cell untagged_object_size(object *pointer) { return align8(unaligned_object_size(pointer)); } /* Size of the data area of an object pointed to by an untagged pointer */ -CELL unaligned_object_size(F_OBJECT *pointer) +cell unaligned_object_size(object *pointer) { - F_TUPLE *tuple; - F_TUPLE_LAYOUT *layout; - - switch(pointer->header.hi_tag()) + switch(pointer->h.hi_tag()) { case ARRAY_TYPE: - return array_size((F_ARRAY*)pointer); + return array_size((array*)pointer); case BIGNUM_TYPE: - return array_size((F_BIGNUM*)pointer); + return array_size((bignum*)pointer); case BYTE_ARRAY_TYPE: - return array_size((F_BYTE_ARRAY*)pointer); + return array_size((byte_array*)pointer); case STRING_TYPE: - return string_size(string_capacity((F_STRING*)pointer)); + return string_size(string_capacity((string*)pointer)); case TUPLE_TYPE: - tuple = (F_TUPLE *)pointer; - layout = untag(tuple->layout); - return tuple_size(layout); + return tuple_size(untag(((tuple *)pointer)->layout)); case QUOTATION_TYPE: - return sizeof(F_QUOTATION); + return sizeof(quotation); case WORD_TYPE: - return sizeof(F_WORD); + return sizeof(word); case FLOAT_TYPE: - return sizeof(F_FLOAT); + return sizeof(boxed_float); case DLL_TYPE: - return sizeof(F_DLL); + return sizeof(dll); case ALIEN_TYPE: - return sizeof(F_ALIEN); + return sizeof(alien); case WRAPPER_TYPE: - return sizeof(F_WRAPPER); + return sizeof(wrapper); case CALLSTACK_TYPE: - return callstack_size( - untag_fixnum(((F_CALLSTACK *)pointer)->length)); + return callstack_size(untag_fixnum(((callstack *)pointer)->length)); default: - critical_error("Invalid header",(CELL)pointer); + critical_error("Invalid header",(cell)pointer); return -1; /* can't happen */ } } @@ -259,12 +253,9 @@ PRIMITIVE(size) /* The number of cells from the start of the object which should be scanned by the GC. Some types have a binary payload at the end (string, word, DLL) which we ignore. */ -CELL binary_payload_start(F_OBJECT *pointer) +cell binary_payload_start(object *pointer) { - F_TUPLE *tuple; - F_TUPLE_LAYOUT *layout; - - switch(pointer->header.hi_tag()) + switch(pointer->h.hi_tag()) { /* these objects do not refer to other objects at all */ case FLOAT_TYPE: @@ -274,26 +265,24 @@ CELL binary_payload_start(F_OBJECT *pointer) return 0; /* these objects have some binary data at the end */ case WORD_TYPE: - return sizeof(F_WORD) - CELLS * 3; + return sizeof(word) - sizeof(cell) * 3; case ALIEN_TYPE: - return CELLS * 3; + return sizeof(cell) * 3; case DLL_TYPE: - return CELLS * 2; + return sizeof(cell) * 2; case QUOTATION_TYPE: - return sizeof(F_QUOTATION) - CELLS * 2; + return sizeof(quotation) - sizeof(cell) * 2; case STRING_TYPE: - return sizeof(F_STRING); + return sizeof(string); /* everything else consists entirely of pointers */ case ARRAY_TYPE: - return array_size(array_capacity((F_ARRAY*)pointer)); + return array_size(array_capacity((array*)pointer)); case TUPLE_TYPE: - tuple = (F_TUPLE *)pointer; - layout = untag(tuple->layout); - return tuple_size(layout); + return tuple_size(untag(((tuple *)pointer)->layout)); case WRAPPER_TYPE: - return sizeof(F_WRAPPER); + return sizeof(wrapper); default: - critical_error("Invalid header",(CELL)pointer); + critical_error("Invalid header",(cell)pointer); return -1; /* can't happen */ } } @@ -301,31 +290,31 @@ CELL binary_payload_start(F_OBJECT *pointer) /* Push memory usage statistics in data heap */ PRIMITIVE(data_room) { - dpush(tag_fixnum((data_heap->cards_end - data_heap->cards) >> 10)); - dpush(tag_fixnum((data_heap->decks_end - data_heap->decks) >> 10)); + dpush(tag_fixnum((data->cards_end - data->cards) >> 10)); + dpush(tag_fixnum((data->decks_end - data->decks) >> 10)); growable_array a; - CELL gen; - for(gen = 0; gen < data_heap->gen_count; gen++) + cell gen; + for(gen = 0; gen < data->gen_count; gen++) { - F_ZONE *z = (gen == NURSERY ? &nursery : &data_heap->generations[gen]); + zone *z = (gen == NURSERY ? &nursery : &data->generations[gen]); a.add(tag_fixnum((z->end - z->here) >> 10)); a.add(tag_fixnum((z->size) >> 10)); } a.trim(); - dpush(a.array.value()); + dpush(a.elements.value()); } /* A heap walk allows useful things to be done, like finding all references to an object for debugging purposes. */ -CELL heap_scan_ptr; +cell heap_scan_ptr; /* Disables GC and activates next-object ( -- obj ) primitive */ void begin_scan(void) { - heap_scan_ptr = data_heap->generations[TENURED].start; + heap_scan_ptr = data->generations[TENURED].start; gc_off = true; } @@ -334,17 +323,17 @@ PRIMITIVE(begin_scan) begin_scan(); } -CELL next_object(void) +cell next_object(void) { if(!gc_off) general_error(ERROR_HEAP_SCAN,F,F,NULL); - if(heap_scan_ptr >= data_heap->generations[TENURED].here) + if(heap_scan_ptr >= data->generations[TENURED].here) return F; - F_OBJECT *object = (F_OBJECT *)heap_scan_ptr; - heap_scan_ptr += untagged_object_size(object); - return tag_dynamic(object); + object *obj = (object *)heap_scan_ptr; + heap_scan_ptr += untagged_object_size(obj); + return tag_dynamic(obj); } /* Push object at heap scan cursor and advance; pushes f when done */ @@ -359,16 +348,16 @@ PRIMITIVE(end_scan) gc_off = false; } -CELL find_all_words(void) +cell find_all_words(void) { growable_array words; begin_scan(); - CELL obj; + cell obj; while((obj = next_object()) != F) { - if(tagged(obj).type_p(WORD_TYPE)) + if(tagged(obj).type_p(WORD_TYPE)) words.add(obj); } @@ -376,7 +365,7 @@ CELL find_all_words(void) gc_off = false; words.trim(); - return words.array.value(); + return words.elements.value(); } } diff --git a/vm/data_heap.hpp b/vm/data_heap.hpp index 5d48dfb009..bb8b35341e 100644 --- a/vm/data_heap.hpp +++ b/vm/data_heap.hpp @@ -5,89 +5,89 @@ namespace factor extern bool secure_gc; /* generational copying GC divides memory into zones */ -struct F_ZONE { +struct zone { /* allocation pointer is 'here'; its offset is hardcoded in the compiler backends */ - CELL start; - CELL here; - CELL size; - CELL end; + cell start; + cell here; + cell size; + cell end; }; -struct F_DATA_HEAP { - F_SEGMENT *segment; +struct data_heap { + segment *seg; - CELL young_size; - CELL aging_size; - CELL tenured_size; + cell young_size; + cell aging_size; + cell tenured_size; - CELL gen_count; + cell gen_count; - F_ZONE *generations; - F_ZONE* semispaces; + zone *generations; + zone *semispaces; - CELL *allot_markers; - CELL *allot_markers_end; + cell *allot_markers; + cell *allot_markers_end; - CELL *cards; - CELL *cards_end; + cell *cards; + cell *cards_end; - CELL *decks; - CELL *decks_end; + cell *decks; + cell *decks_end; }; -extern F_DATA_HEAP *data_heap; +extern data_heap *data; /* the 0th generation is where new objects are allocated. */ #define NURSERY 0 /* where objects hang around */ -#define AGING (data_heap->gen_count-2) -#define HAVE_AGING_P (data_heap->gen_count>2) +#define AGING (data->gen_count-2) +#define HAVE_AGING_P (data->gen_count>2) /* the oldest generation */ -#define TENURED (data_heap->gen_count-1) +#define TENURED (data->gen_count-1) #define MIN_GEN_COUNT 1 #define MAX_GEN_COUNT 3 -inline static bool in_zone(F_ZONE *z, F_OBJECT *pointer) +inline static bool in_zone(zone *z, object *pointer) { - return (CELL)pointer >= z->start && (CELL)pointer < z->end; + return (cell)pointer >= z->start && (cell)pointer < z->end; } -CELL init_zone(F_ZONE *z, CELL size, CELL base); +cell init_zone(zone *z, cell size, cell base); void init_card_decks(void); -F_DATA_HEAP *grow_data_heap(F_DATA_HEAP *data_heap, CELL requested_bytes); +data_heap *grow_data_heap(data_heap *data, cell requested_bytes); -void dealloc_data_heap(F_DATA_HEAP *data_heap); +void dealloc_data_heap(data_heap *data); -void clear_cards(CELL from, CELL to); -void clear_decks(CELL from, CELL to); -void clear_allot_markers(CELL from, CELL to); -void reset_generation(CELL i); -void reset_generations(CELL from, CELL to); +void clear_cards(cell from, cell to); +void clear_decks(cell from, cell to); +void clear_allot_markers(cell from, cell to); +void reset_generation(cell i); +void reset_generations(cell from, cell to); -void set_data_heap(F_DATA_HEAP *data_heap_); +void set_data_heap(data_heap *data_heap_); -void init_data_heap(CELL gens, - CELL young_size, - CELL aging_size, - CELL tenured_size, +void init_data_heap(cell gens, + cell young_size, + cell aging_size, + cell tenured_size, bool secure_gc_); /* set up guard pages to check for under/overflow. size must be a multiple of the page size */ -F_SEGMENT *alloc_segment(CELL size); -void dealloc_segment(F_SEGMENT *block); +segment *alloc_segment(cell size); +void dealloc_segment(segment *block); -CELL untagged_object_size(F_OBJECT *pointer); -CELL unaligned_object_size(F_OBJECT *pointer); -CELL binary_payload_start(F_OBJECT *pointer); -CELL object_size(CELL tagged); +cell untagged_object_size(object *pointer); +cell unaligned_object_size(object *pointer); +cell binary_payload_start(object *pointer); +cell object_size(cell tagged); void begin_scan(void); -CELL next_object(void); +cell next_object(void); PRIMITIVE(data_room); PRIMITIVE(size); @@ -99,36 +99,27 @@ PRIMITIVE(end_scan); /* GC is off during heap walking */ extern bool gc_off; -inline static F_OBJECT *allot_zone(F_ZONE *z, CELL a) -{ - CELL h = z->here; - z->here = h + align8(a); - F_OBJECT *object = (F_OBJECT *)h; - allot_barrier(object); - return object; -} - -CELL find_all_words(void); +cell find_all_words(void); /* Every object has a regular representation in the runtime, which makes GC much simpler. Every slot of the object until binary_payload_start is a pointer to some other object. */ -inline static void do_slots(CELL obj, void (* iter)(CELL *)) +inline static void do_slots(cell obj, void (* iter)(cell *)) { - CELL scan = obj; - CELL payload_start = binary_payload_start((F_OBJECT *)obj); - CELL end = obj + payload_start; + cell scan = obj; + cell payload_start = binary_payload_start((object *)obj); + cell end = obj + payload_start; - scan += CELLS; + scan += sizeof(cell); while(scan < end) { - iter((CELL *)scan); - scan += CELLS; + iter((cell *)scan); + scan += sizeof(cell); } } } /* new objects are allocated here */ -VM_C_API factor::F_ZONE nursery; +VM_C_API factor::zone nursery; diff --git a/vm/debug.cpp b/vm/debug.cpp index 513b6d550e..f405282098 100755 --- a/vm/debug.cpp +++ b/vm/debug.cpp @@ -6,23 +6,23 @@ namespace factor static bool fep_disabled; static bool full_output; -void print_chars(F_STRING* str) +void print_chars(string* str) { - CELL i; + cell i; for(i = 0; i < string_capacity(str); i++) putchar(string_nth(str,i)); } -void print_word(F_WORD* word, CELL nesting) +void print_word(word* word, cell nesting) { - if(tagged(word->vocabulary).type_p(STRING_TYPE)) + if(tagged(word->vocabulary).type_p(STRING_TYPE)) { - print_chars(untag(word->vocabulary)); + print_chars(untag(word->vocabulary)); print_string(":"); } - if(tagged(word->name).type_p(STRING_TYPE)) - print_chars(untag(word->name)); + if(tagged(word->name).type_p(STRING_TYPE)) + print_chars(untag(word->name)); else { print_string("# 10 && !full_output) @@ -62,15 +62,15 @@ void print_array(F_ARRAY* array, CELL nesting) print_string("..."); } -void print_tuple(F_TUPLE* tuple, CELL nesting) +void print_tuple(tuple *tuple, cell nesting) { - F_TUPLE_LAYOUT *layout = untag(tuple->layout); - CELL length = to_fixnum(layout->size); + tuple_layout *layout = untag(tuple->layout); + cell length = to_fixnum(layout->size); print_string(" "); print_nested_obj(layout->klass,nesting); - CELL i; + cell i; bool trimmed; if(length > 10 && !full_output) @@ -84,14 +84,14 @@ void print_tuple(F_TUPLE* tuple, CELL nesting) for(i = 0; i < length; i++) { print_string(" "); - print_nested_obj(tuple_nth(tuple,i),nesting); + print_nested_obj(tuple->data()[i],nesting); } if(trimmed) print_string("..."); } -void print_nested_obj(CELL obj, F_FIXNUM nesting) +void print_nested_obj(cell obj, fixnum nesting) { if(nesting <= 0 && !full_output) { @@ -99,41 +99,41 @@ void print_nested_obj(CELL obj, F_FIXNUM nesting) return; } - F_QUOTATION *quot; + quotation *quot; - switch(tagged(obj).type()) + switch(tagged(obj).type()) { case FIXNUM_TYPE: print_fixnum(untag_fixnum(obj)); break; case WORD_TYPE: - print_word(untag(obj),nesting - 1); + print_word(untag(obj),nesting - 1); break; case STRING_TYPE: - print_factor_string(untag(obj)); + print_factor_string(untag(obj)); break; case F_TYPE: print_string("f"); break; case TUPLE_TYPE: print_string("T{"); - print_tuple(untag(obj),nesting - 1); + print_tuple(untag(obj),nesting - 1); print_string(" }"); break; case ARRAY_TYPE: print_string("{"); - print_array(untag(obj),nesting - 1); + print_array(untag(obj),nesting - 1); print_string(" }"); break; case QUOTATION_TYPE: print_string("["); - quot = untag(obj); - print_array(untag(quot->array),nesting - 1); + quot = untag(obj); + print_array(untag(quot->array),nesting - 1); print_string(" ]"); break; default: print_string("#(obj).type()); + print_cell(tagged(obj).type()); print_string(" @ "); print_cell_hex(obj); print_string(">"); @@ -141,12 +141,12 @@ void print_nested_obj(CELL obj, F_FIXNUM nesting) } } -void print_obj(CELL obj) +void print_obj(cell obj) { print_nested_obj(obj,10); } -void print_objects(CELL *start, CELL *end) +void print_objects(cell *start, cell *end) { for(; start <= end; start++) { @@ -158,52 +158,52 @@ void print_objects(CELL *start, CELL *end) void print_datastack(void) { print_string("==== DATA STACK:\n"); - print_objects((CELL *)ds_bot,(CELL *)ds); + print_objects((cell *)ds_bot,(cell *)ds); } void print_retainstack(void) { print_string("==== RETAIN STACK:\n"); - print_objects((CELL *)rs_bot,(CELL *)rs); + print_objects((cell *)rs_bot,(cell *)rs); } -void print_stack_frame(F_STACK_FRAME *frame) +void print_stack_frame(stack_frame *frame) { print_obj(frame_executing(frame)); print_string("\n"); print_obj(frame_scan(frame)); print_string("\n"); - print_cell_hex((CELL)frame_executing(frame)); + print_cell_hex((cell)frame_executing(frame)); print_string(" "); - print_cell_hex((CELL)frame->xt); + print_cell_hex((cell)frame->xt); print_string("\n"); } void print_callstack(void) { print_string("==== CALL STACK:\n"); - CELL bottom = (CELL)stack_chain->callstack_bottom; - CELL top = (CELL)stack_chain->callstack_top; + cell bottom = (cell)stack_chain->callstack_bottom; + cell top = (cell)stack_chain->callstack_top; iterate_callstack(top,bottom,print_stack_frame); } -void dump_cell(CELL cell) +void dump_cell(cell x) { - print_cell_hex_pad(cell); print_string(": "); - cell = *(CELL *)cell; - print_cell_hex_pad(cell); print_string(" tag "); print_cell(TAG(cell)); + print_cell_hex_pad(x); print_string(": "); + x = *(cell *)x; + print_cell_hex_pad(x); print_string(" tag "); print_cell(TAG(x)); nl(); } -void dump_memory(CELL from, CELL to) +void dump_memory(cell from, cell to) { from = UNTAG(from); - for(; from <= to; from += CELLS) + for(; from <= to; from += sizeof(cell)) dump_cell(from); } -void dump_zone(F_ZONE *z) +void dump_zone(zone *z) { print_string("Start="); print_cell(z->start); print_string(", size="); print_cell(z->size); @@ -212,39 +212,39 @@ void dump_zone(F_ZONE *z) void dump_generations(void) { - CELL i; + cell i; print_string("Nursery: "); dump_zone(&nursery); - for(i = 1; i < data_heap->gen_count; i++) + for(i = 1; i < data->gen_count; i++) { print_string("Generation "); print_cell(i); print_string(": "); - dump_zone(&data_heap->generations[i]); + dump_zone(&data->generations[i]); } - for(i = 0; i < data_heap->gen_count; i++) + for(i = 0; i < data->gen_count; i++) { print_string("Semispace "); print_cell(i); print_string(": "); - dump_zone(&data_heap->semispaces[i]); + dump_zone(&data->semispaces[i]); } print_string("Cards: base="); - print_cell((CELL)data_heap->cards); + print_cell((cell)data->cards); print_string(", size="); - print_cell((CELL)(data_heap->cards_end - data_heap->cards)); + print_cell((cell)(data->cards_end - data->cards)); nl(); } -void dump_objects(CELL type) +void dump_objects(cell type) { gc(); begin_scan(); - CELL obj; + cell obj; while((obj = next_object()) != F) { - if(type == TYPE_COUNT || tagged(obj).type_p(type)) + if(type == TYPE_COUNT || tagged(obj).type_p(type)) { print_cell_hex_pad(obj); print_string(" "); @@ -257,10 +257,10 @@ void dump_objects(CELL type) gc_off = false; } -CELL look_for; -CELL obj; +cell look_for; +cell obj; -void find_data_references_step(CELL *scan) +void find_data_references_step(cell *scan) { if(look_for == *scan) { @@ -271,7 +271,7 @@ void find_data_references_step(CELL *scan) } } -void find_data_references(CELL look_for_) +void find_data_references(cell look_for_) { look_for = look_for_; @@ -287,9 +287,9 @@ void find_data_references(CELL look_for_) /* Dump all code blocks for debugging */ void dump_code_heap(void) { - CELL reloc_size = 0, literal_size = 0; + cell reloc_size = 0, literal_size = 0; - F_BLOCK *scan = first_block(&code_heap); + heap_block *scan = first_block(&code); while(scan) { @@ -300,13 +300,13 @@ void dump_code_heap(void) status = "free"; break; case B_ALLOCATED: - reloc_size += object_size(((F_CODE_BLOCK *)scan)->relocation); - literal_size += object_size(((F_CODE_BLOCK *)scan)->literals); + reloc_size += object_size(((code_block *)scan)->relocation); + literal_size += object_size(((code_block *)scan)->literals); status = "allocated"; break; case B_MARKED: - reloc_size += object_size(((F_CODE_BLOCK *)scan)->relocation); - literal_size += object_size(((F_CODE_BLOCK *)scan)->literals); + reloc_size += object_size(((code_block *)scan)->relocation); + literal_size += object_size(((code_block *)scan)->literals); status = "marked"; break; default: @@ -314,11 +314,11 @@ void dump_code_heap(void) break; } - print_cell_hex((CELL)scan); print_string(" "); + print_cell_hex((cell)scan); print_string(" "); print_cell_hex(scan->size); print_string(" "); print_string(status); print_string("\n"); - scan = next_block(&code_heap,scan); + scan = next_block(&code,scan); } print_cell(reloc_size); print_string(" bytes of relocation data\n"); @@ -389,20 +389,20 @@ void factorbug(void) if(strcmp(cmd,"d") == 0) { - CELL addr = read_cell_hex(); + cell addr = read_cell_hex(); if(scanf(" ") < 0) break; - CELL count = read_cell_hex(); + cell count = read_cell_hex(); dump_memory(addr,addr+count); } else if(strcmp(cmd,"u") == 0) { - CELL addr = read_cell_hex(); - CELL count = object_size(addr); + cell addr = read_cell_hex(); + cell count = object_size(addr); dump_memory(addr,addr+count); } else if(strcmp(cmd,".") == 0) { - CELL addr = read_cell_hex(); + cell addr = read_cell_hex(); print_obj(addr); print_string("\n"); } @@ -422,20 +422,20 @@ void factorbug(void) { int i; for(i = 0; i < USER_ENV; i++) - dump_cell((CELL)&userenv[i]); + dump_cell((cell)&userenv[i]); } else if(strcmp(cmd,"g") == 0) dump_generations(); else if(strcmp(cmd,"card") == 0) { - CELL addr = read_cell_hex(); - print_cell_hex((CELL)ADDR_TO_CARD(addr)); + cell addr = read_cell_hex(); + print_cell_hex((cell)addr_to_card(addr)); nl(); } else if(strcmp(cmd,"addr") == 0) { - CELL card = read_cell_hex(); - print_cell_hex((CELL)CARD_TO_ADDR(card)); + card *ptr = (card *)read_cell_hex(); + print_cell_hex(card_to_addr(ptr)); nl(); } else if(strcmp(cmd,"q") == 0) @@ -448,7 +448,7 @@ void factorbug(void) dump_objects(TYPE_COUNT); else if(strcmp(cmd,"refs") == 0) { - CELL addr = read_cell_hex(); + cell addr = read_cell_hex(); print_string("Data heap references:\n"); find_data_references(addr); nl(); @@ -459,7 +459,7 @@ void factorbug(void) dump_objects(TUPLE_TYPE); else if(strcmp(cmd,"push") == 0) { - CELL addr = read_cell_hex(); + cell addr = read_cell_hex(); dpush(addr); } else if(strcmp(cmd,"code") == 0) diff --git a/vm/debug.hpp b/vm/debug.hpp index 008776c6a6..81874bf2ac 100755 --- a/vm/debug.hpp +++ b/vm/debug.hpp @@ -1,11 +1,11 @@ namespace factor { -void print_obj(CELL obj); -void print_nested_obj(CELL obj, F_FIXNUM nesting); +void print_obj(cell obj); +void print_nested_obj(cell obj, fixnum nesting); void dump_generations(void); void factorbug(void); -void dump_zone(F_ZONE *z); +void dump_zone(zone *z); PRIMITIVE(die); diff --git a/vm/dispatch.cpp b/vm/dispatch.cpp index e178157446..bbcf20c57b 100644 --- a/vm/dispatch.cpp +++ b/vm/dispatch.cpp @@ -3,16 +3,16 @@ namespace factor { -CELL megamorphic_cache_hits; -CELL megamorphic_cache_misses; +cell megamorphic_cache_hits; +cell megamorphic_cache_misses; -static CELL search_lookup_alist(CELL table, CELL klass) +static cell search_lookup_alist(cell table, cell klass) { - F_ARRAY *pairs = untag(table); - F_FIXNUM index = array_capacity(pairs) - 1; + array *pairs = untag(table); + fixnum index = array_capacity(pairs) - 1; while(index >= 0) { - F_ARRAY *pair = untag(array_nth(pairs,index)); + array *pair = untag(array_nth(pairs,index)); if(array_nth(pair,0) == klass) return array_nth(pair,1); else @@ -22,50 +22,49 @@ static CELL search_lookup_alist(CELL table, CELL klass) return F; } -static CELL search_lookup_hash(CELL table, CELL klass, CELL hashcode) +static cell search_lookup_hash(cell table, cell klass, cell hashcode) { - F_ARRAY *buckets = untag(table); - CELL bucket = array_nth(buckets,hashcode & (array_capacity(buckets) - 1)); - if(tagged(bucket).type_p(WORD_TYPE) || bucket == F) + array *buckets = untag(table); + cell bucket = array_nth(buckets,hashcode & (array_capacity(buckets) - 1)); + if(tagged(bucket).type_p(WORD_TYPE) || bucket == F) return bucket; else return search_lookup_alist(bucket,klass); } -static CELL nth_superclass(F_TUPLE_LAYOUT *layout, F_FIXNUM echelon) +static cell nth_superclass(tuple_layout *layout, fixnum echelon) { - CELL *ptr = (CELL *)(layout + 1); + cell *ptr = (cell *)(layout + 1); return ptr[echelon * 2]; } -static CELL nth_hashcode(F_TUPLE_LAYOUT *layout, F_FIXNUM echelon) +static cell nth_hashcode(tuple_layout *layout, fixnum echelon) { - CELL *ptr = (CELL *)(layout + 1); + cell *ptr = (cell *)(layout + 1); return ptr[echelon * 2 + 1]; } -static CELL lookup_tuple_method(CELL object, CELL methods) +static cell lookup_tuple_method(cell obj, cell methods) { - F_TUPLE *tuple = untag(object); - F_TUPLE_LAYOUT *layout = untag(tuple->layout); + tuple_layout *layout = untag(untag(obj)->layout); - F_ARRAY *echelons = untag(methods); + array *echelons = untag(methods); - F_FIXNUM echelon = untag_fixnum(layout->echelon); - F_FIXNUM max_echelon = array_capacity(echelons) - 1; + fixnum echelon = untag_fixnum(layout->echelon); + fixnum max_echelon = array_capacity(echelons) - 1; if(echelon > max_echelon) echelon = max_echelon; while(echelon >= 0) { - CELL echelon_methods = array_nth(echelons,echelon); + cell echelon_methods = array_nth(echelons,echelon); - if(tagged(echelon_methods).type_p(WORD_TYPE)) + if(tagged(echelon_methods).type_p(WORD_TYPE)) return echelon_methods; else if(echelon_methods != F) { - CELL klass = nth_superclass(layout,echelon); - CELL hashcode = untag_fixnum(nth_hashcode(layout,echelon)); - CELL result = search_lookup_hash(echelon_methods,klass,hashcode); + cell klass = nth_superclass(layout,echelon); + cell hashcode = untag_fixnum(nth_hashcode(layout,echelon)); + cell result = search_lookup_hash(echelon_methods,klass,hashcode); if(result != F) return result; } @@ -77,30 +76,30 @@ static CELL lookup_tuple_method(CELL object, CELL methods) return F; } -static CELL lookup_hi_tag_method(CELL object, CELL methods) +static cell lookup_hi_tag_method(cell obj, cell methods) { - F_ARRAY *hi_tag_methods = untag(methods); - CELL tag = untag(object)->header.hi_tag() - HEADER_TYPE; + array *hi_tag_methods = untag(methods); + cell tag = untag(obj)->h.hi_tag() - HEADER_TYPE; #ifdef FACTOR_DEBUG assert(tag < TYPE_COUNT - HEADER_TYPE); #endif return array_nth(hi_tag_methods,tag); } -static CELL lookup_hairy_method(CELL object, CELL methods) +static cell lookup_hairy_method(cell obj, cell methods) { - CELL method = array_nth(untag(methods),TAG(object)); - if(tagged(method).type_p(WORD_TYPE)) + cell method = array_nth(untag(methods),TAG(obj)); + if(tagged(method).type_p(WORD_TYPE)) return method; else { - switch(TAG(object)) + switch(TAG(obj)) { case TUPLE_TYPE: - return lookup_tuple_method(object,method); + return lookup_tuple_method(obj,method); break; case OBJECT_TYPE: - return lookup_hi_tag_method(object,method); + return lookup_hi_tag_method(obj,method); break; default: critical_error("Bad methods array",methods); @@ -109,60 +108,60 @@ static CELL lookup_hairy_method(CELL object, CELL methods) } } -CELL lookup_method(CELL object, CELL methods) +cell lookup_method(cell obj, cell methods) { - CELL tag = TAG(object); + cell tag = TAG(obj); if(tag == TUPLE_TYPE || tag == OBJECT_TYPE) - return lookup_hairy_method(object,methods); + return lookup_hairy_method(obj,methods); else - return array_nth(untag(methods),TAG(object)); + return array_nth(untag(methods),TAG(obj)); } PRIMITIVE(lookup_method) { - CELL methods = dpop(); - CELL object = dpop(); - dpush(lookup_method(object,methods)); + cell methods = dpop(); + cell obj = dpop(); + dpush(lookup_method(obj,methods)); } -CELL object_class(CELL object) +cell object_class(cell obj) { - switch(TAG(object)) + switch(TAG(obj)) { case TUPLE_TYPE: - return untag(object)->layout; + return untag(obj)->layout; case OBJECT_TYPE: - return untag(object)->header.header; + return untag(obj)->h.value; default: - return tag_fixnum(TAG(object)); + return tag_fixnum(TAG(obj)); } } -static CELL method_cache_hashcode(CELL klass, F_ARRAY *array) +static cell method_cache_hashcode(cell klass, array *array) { - CELL capacity = (array_capacity(array) >> 1) - 1; + cell capacity = (array_capacity(array) >> 1) - 1; return ((klass >> TAG_BITS) & capacity) << 1; } -static void update_method_cache(CELL cache, CELL klass, CELL method) +static void update_method_cache(cell cache, cell klass, cell method) { - F_ARRAY *array = untag(cache); - CELL hashcode = method_cache_hashcode(klass,array); - set_array_nth(array,hashcode,klass); - set_array_nth(array,hashcode + 1,method); + array *cache_elements = untag(cache); + cell hashcode = method_cache_hashcode(klass,cache_elements); + set_array_nth(cache_elements,hashcode,klass); + set_array_nth(cache_elements,hashcode + 1,method); } PRIMITIVE(mega_cache_miss) { megamorphic_cache_misses++; - CELL cache = dpop(); - F_FIXNUM index = untag_fixnum(dpop()); - CELL methods = dpop(); + cell cache = dpop(); + fixnum index = untag_fixnum(dpop()); + cell methods = dpop(); - CELL object = ((CELL *)ds)[-index]; - CELL klass = object_class(object); - CELL method = lookup_method(object,methods); + cell object = ((cell *)ds)[-index]; + cell klass = object_class(object); + cell method = lookup_method(object,methods); update_method_cache(cache,klass,method); @@ -180,13 +179,13 @@ PRIMITIVE(dispatch_stats) stats.add(allot_cell(megamorphic_cache_hits)); stats.add(allot_cell(megamorphic_cache_misses)); stats.trim(); - dpush(stats.array.value()); + dpush(stats.elements.value()); } -void quotation_jit::emit_mega_cache_lookup(CELL methods_, F_FIXNUM index, CELL cache_) +void quotation_jit::emit_mega_cache_lookup(cell methods_, fixnum index, cell cache_) { - gc_root methods(methods_); - gc_root cache(cache_); + gc_root methods(methods_); + gc_root cache(cache_); /* Generate machine code to determine the object's class. */ emit_class_lookup(index,PIC_HI_TAG_TUPLE); diff --git a/vm/dispatch.hpp b/vm/dispatch.hpp index 6b86fabd7f..f5648c7ebe 100644 --- a/vm/dispatch.hpp +++ b/vm/dispatch.hpp @@ -1,18 +1,18 @@ namespace factor { -CELL lookup_method(CELL object, CELL methods); +cell lookup_method(cell object, cell methods); PRIMITIVE(lookup_method); -CELL object_class(CELL object); +cell object_class(cell object); PRIMITIVE(mega_cache_miss); PRIMITIVE(reset_dispatch_stats); PRIMITIVE(dispatch_stats); -void jit_emit_class_lookup(jit *jit, F_FIXNUM index, CELL type); +void jit_emit_class_lookup(jit *jit, fixnum index, cell type); -void jit_emit_mega_cache_lookup(jit *jit, CELL methods, F_FIXNUM index, CELL cache); +void jit_emit_mega_cache_lookup(jit *jit, cell methods, fixnum index, cell cache); } diff --git a/vm/errors.cpp b/vm/errors.cpp index 45954c5d9f..7da6980ece 100755 --- a/vm/errors.cpp +++ b/vm/errors.cpp @@ -5,9 +5,9 @@ namespace factor /* Global variables used to pass fault handler state from signal handler to user-space */ -CELL signal_number; -CELL signal_fault_addr; -F_STACK_FRAME *signal_callstack_top; +cell signal_number; +cell signal_fault_addr; +stack_frame *signal_callstack_top; void out_of_memory(void) { @@ -16,14 +16,14 @@ void out_of_memory(void) exit(1); } -void fatal_error(char* msg, CELL tagged) +void fatal_error(char* msg, cell tagged) { print_string("fatal_error: "); print_string(msg); print_string(": "); print_cell_hex(tagged); nl(); exit(1); } -void critical_error(char* msg, CELL tagged) +void critical_error(char* msg, cell tagged) { print_string("You have triggered a bug in Factor. Please report.\n"); print_string("critical_error: "); print_string(msg); @@ -31,7 +31,7 @@ void critical_error(char* msg, CELL tagged) factorbug(); } -void throw_error(CELL error, F_STACK_FRAME *callstack_top) +void throw_error(cell error, stack_frame *callstack_top) { /* If the error handler is set, we rewind any C stack frames and pass the error to user-space. */ @@ -41,8 +41,8 @@ void throw_error(CELL error, F_STACK_FRAME *callstack_top) gc_off = false; /* Reset local roots */ - gc_locals = gc_locals_region->start - CELLS; - gc_bignums = gc_bignums_region->start - CELLS; + gc_locals = gc_locals_region->start - sizeof(cell); + gc_bignums = gc_bignums_region->start - sizeof(cell); /* If we had an underflow or overflow, stack pointers might be out of bounds */ @@ -76,14 +76,14 @@ void throw_error(CELL error, F_STACK_FRAME *callstack_top) } } -void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2, - F_STACK_FRAME *callstack_top) +void general_error(vm_error_type error, cell arg1, cell arg2, + stack_frame *callstack_top) { throw_error(allot_array_4(userenv[ERROR_ENV], tag_fixnum(error),arg1,arg2),callstack_top); } -void type_error(CELL type, CELL tagged) +void type_error(cell type, cell tagged) { general_error(ERROR_TYPE,tag_fixnum(type),tagged,NULL); } @@ -95,7 +95,7 @@ void not_implemented_error(void) /* Test if 'fault' is in the guard page at the top or bottom (depending on offset being 0 or -1) of area+area_size */ -bool in_page(CELL fault, CELL area, CELL area_size, int offset) +bool in_page(cell fault, cell area, cell area_size, int offset) { int pagesize = getpagesize(); area += area_size; @@ -104,7 +104,7 @@ bool in_page(CELL fault, CELL area, CELL area_size, int offset) return fault >= area && fault <= area + pagesize; } -void memory_protection_error(CELL addr, F_STACK_FRAME *native_stack) +void memory_protection_error(cell addr, stack_frame *native_stack) { if(in_page(addr, ds_bot, 0, -1)) general_error(ERROR_DS_UNDERFLOW,F,F,native_stack); @@ -120,7 +120,7 @@ void memory_protection_error(CELL addr, F_STACK_FRAME *native_stack) general_error(ERROR_MEMORY,allot_cell(addr),F,native_stack); } -void signal_error(int signal, F_STACK_FRAME *native_stack) +void signal_error(int signal, stack_frame *native_stack) { general_error(ERROR_SIGNAL,tag_fixnum(signal),F,native_stack); } diff --git a/vm/errors.hpp b/vm/errors.hpp index fae3949a54..c884770a02 100755 --- a/vm/errors.hpp +++ b/vm/errors.hpp @@ -2,7 +2,7 @@ namespace factor { /* Runtime errors */ -typedef enum +enum vm_error_type { ERROR_EXPIRED = 0, ERROR_IO, @@ -20,20 +20,20 @@ typedef enum ERROR_RS_UNDERFLOW, ERROR_RS_OVERFLOW, ERROR_MEMORY, -} F_ERRORTYPE; +}; void out_of_memory(void); -void fatal_error(char* msg, CELL tagged); -void critical_error(char* msg, CELL tagged); +void fatal_error(char* msg, cell tagged); +void critical_error(char* msg, cell tagged); PRIMITIVE(die); -void throw_error(CELL error, F_STACK_FRAME *native_stack); -void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2, F_STACK_FRAME *native_stack); +void throw_error(cell error, stack_frame *native_stack); +void general_error(vm_error_type error, cell arg1, cell arg2, stack_frame *native_stack); void divide_by_zero_error(void); -void memory_protection_error(CELL addr, F_STACK_FRAME *native_stack); -void signal_error(int signal, F_STACK_FRAME *native_stack); -void type_error(CELL type, CELL tagged); +void memory_protection_error(cell addr, stack_frame *native_stack); +void signal_error(int signal, stack_frame *native_stack); +void type_error(cell type, cell tagged); void not_implemented_error(void); PRIMITIVE(call_clear); @@ -41,9 +41,9 @@ PRIMITIVE(unimplemented); /* Global variables used to pass fault handler state from signal handler to user-space */ -extern CELL signal_number; -extern CELL signal_fault_addr; -extern F_STACK_FRAME *signal_callstack_top; +extern cell signal_number; +extern cell signal_fault_addr; +extern stack_frame *signal_callstack_top; void memory_signal_handler_impl(void); void misc_signal_handler_impl(void); diff --git a/vm/factor.cpp b/vm/factor.cpp index 9c6af72264..28f0afacf6 100755 --- a/vm/factor.cpp +++ b/vm/factor.cpp @@ -3,15 +3,15 @@ namespace factor { -VM_C_API void default_parameters(F_PARAMETERS *p) +VM_C_API void default_parameters(vm_parameters *p) { p->image_path = NULL; /* We make a wild guess here that if we're running on ARM, we don't have a lot of memory. */ #ifdef FACTOR_ARM - p->ds_size = 8 * CELLS; - p->rs_size = 8 * CELLS; + p->ds_size = 8 * sizeof(cell); + p->rs_size = 8 * sizeof(cell); p->gen_count = 2; p->code_size = 4; @@ -19,14 +19,14 @@ VM_C_API void default_parameters(F_PARAMETERS *p) p->aging_size = 1; p->tenured_size = 6; #else - p->ds_size = 32 * CELLS; - p->rs_size = 32 * CELLS; + p->ds_size = 32 * sizeof(cell); + p->rs_size = 32 * sizeof(cell); p->gen_count = 3; - p->code_size = 8 * CELLS; - p->young_size = CELLS / 4; - p->aging_size = CELLS / 2; - p->tenured_size = 4 * CELLS; + p->code_size = 8 * sizeof(cell); + p->young_size = sizeof(cell) / 4; + p->aging_size = sizeof(cell) / 2; + p->tenured_size = 4 * sizeof(cell); #endif p->max_pic_size = 3; @@ -43,7 +43,7 @@ VM_C_API void default_parameters(F_PARAMETERS *p) p->stack_traces = true; } -static bool factor_arg(const F_CHAR* str, const F_CHAR* arg, CELL* value) +static bool factor_arg(const vm_char* str, const vm_char* arg, cell* value) { int val; if(SSCANF(str,arg,&val) > 0) @@ -55,7 +55,7 @@ static bool factor_arg(const F_CHAR* str, const F_CHAR* arg, CELL* value) return false; } -VM_C_API void init_parameters_from_args(F_PARAMETERS *p, int argc, F_CHAR **argv) +VM_C_API void init_parameters_from_args(vm_parameters *p, int argc, vm_char **argv) { default_parameters(p); p->executable_path = argv[0]; @@ -93,7 +93,7 @@ static void do_stage1_init(void) fflush(stdout); } -VM_C_API void init_factor(F_PARAMETERS *p) +VM_C_API void init_factor(vm_parameters *p) { /* Kilobytes */ p->ds_size = align_page(p->ds_size << 10); @@ -111,7 +111,7 @@ VM_C_API void init_factor(F_PARAMETERS *p) /* OS-specific initialization */ early_init(); - const F_CHAR *executable_path = vm_executable_path(); + const vm_char *executable_path = vm_executable_path(); if(executable_path) p->executable_path = executable_path; @@ -135,10 +135,10 @@ VM_C_API void init_factor(F_PARAMETERS *p) init_profiler(); - userenv[CPU_ENV] = allot_alien(F,(CELL)FACTOR_CPU_STRING); - userenv[OS_ENV] = allot_alien(F,(CELL)FACTOR_OS_STRING); - userenv[CELL_SIZE_ENV] = tag_fixnum(sizeof(CELL)); - userenv[EXECUTABLE_ENV] = allot_alien(F,(CELL)p->executable_path); + userenv[CPU_ENV] = allot_alien(F,(cell)FACTOR_CPU_STRING); + userenv[OS_ENV] = allot_alien(F,(cell)FACTOR_OS_STRING); + userenv[cell_SIZE_ENV] = tag_fixnum(sizeof(cell)); + userenv[EXECUTABLE_ENV] = allot_alien(F,(cell)p->executable_path); userenv[ARGS_ENV] = F; userenv[EMBEDDED_ENV] = F; @@ -153,19 +153,19 @@ VM_C_API void init_factor(F_PARAMETERS *p) } /* May allocate memory */ -VM_C_API void pass_args_to_factor(int argc, F_CHAR **argv) +VM_C_API void pass_args_to_factor(int argc, vm_char **argv) { growable_array args; int i; for(i = 1; i < argc; i++) - args.add(allot_alien(F,(CELL)argv[i])); + args.add(allot_alien(F,(cell)argv[i])); args.trim(); - userenv[ARGS_ENV] = args.array.value(); + userenv[ARGS_ENV] = args.elements.value(); } -static void start_factor(F_PARAMETERS *p) +static void start_factor(vm_parameters *p) { if(p->fep) factorbug(); @@ -174,15 +174,15 @@ static void start_factor(F_PARAMETERS *p) unnest_stacks(); } -VM_C_API void start_embedded_factor(F_PARAMETERS *p) +VM_C_API void start_embedded_factor(vm_parameters *p) { userenv[EMBEDDED_ENV] = T; start_factor(p); } -VM_C_API void start_standalone_factor(int argc, F_CHAR **argv) +VM_C_API void start_standalone_factor(int argc, vm_char **argv) { - F_PARAMETERS p; + vm_parameters p; default_parameters(&p); init_parameters_from_args(&p,argc,argv); init_factor(&p); diff --git a/vm/factor.hpp b/vm/factor.hpp index 0ae87736d1..e9ba920e9f 100644 --- a/vm/factor.hpp +++ b/vm/factor.hpp @@ -1,12 +1,12 @@ namespace factor { -VM_C_API void default_parameters(F_PARAMETERS *p); -VM_C_API void init_parameters_from_args(F_PARAMETERS *p, int argc, F_CHAR **argv); -VM_C_API void init_factor(F_PARAMETERS *p); -VM_C_API void pass_args_to_factor(int argc, F_CHAR **argv); -VM_C_API void start_embedded_factor(F_PARAMETERS *p); -VM_C_API void start_standalone_factor(int argc, F_CHAR **argv); +VM_C_API void default_parameters(vm_parameters *p); +VM_C_API void init_parameters_from_args(vm_parameters *p, int argc, vm_char **argv); +VM_C_API void init_factor(vm_parameters *p); +VM_C_API void pass_args_to_factor(int argc, vm_char **argv); +VM_C_API void start_embedded_factor(vm_parameters *p); +VM_C_API void start_standalone_factor(int argc, vm_char **argv); VM_C_API char *factor_eval_string(char *string); VM_C_API void factor_eval_free(char *result); diff --git a/vm/float_bits.hpp b/vm/float_bits.hpp index 829fe8d3ca..000bd49482 100644 --- a/vm/float_bits.hpp +++ b/vm/float_bits.hpp @@ -4,40 +4,40 @@ namespace factor /* Some functions for converting floating point numbers to binary representations and vice versa */ -typedef union { +union double_bits_pun { double x; u64 y; -} F_DOUBLE_BITS; +}; inline static u64 double_bits(double x) { - F_DOUBLE_BITS b; + double_bits_pun b; b.x = x; return b.y; } inline static double bits_double(u64 y) { - F_DOUBLE_BITS b; + double_bits_pun b; b.y = y; return b.x; } -typedef union { +union float_bits_pun { float x; u32 y; -} F_FLOAT_BITS; +}; inline static u32 float_bits(float x) { - F_FLOAT_BITS b; + float_bits_pun b; b.x = x; return b.y; } inline static float bits_float(u32 y) { - F_FLOAT_BITS b; + float_bits_pun b; b.y = y; return b.x; } diff --git a/vm/generic_arrays.hpp b/vm/generic_arrays.hpp index 6147c0eeed..26c8149a10 100644 --- a/vm/generic_arrays.hpp +++ b/vm/generic_arrays.hpp @@ -1,37 +1,37 @@ namespace factor { -template CELL array_capacity(T *array) +template cell array_capacity(T *array) { #ifdef FACTOR_DEBUG - assert(array->header.hi_tag() == T::type_number); + assert(array->h.hi_tag() == T::type_number); #endif return array->capacity >> TAG_BITS; } -template CELL array_size(CELL capacity) +template cell array_size(cell capacity) { return sizeof(T) + capacity * T::element_size; } -template CELL array_size(T *array) +template cell array_size(T *array) { return array_size(array_capacity(array)); } -template T *allot_array_internal(CELL capacity) +template T *allot_array_internal(cell capacity) { T *array = allot(array_size(capacity)); array->capacity = tag_fixnum(capacity); return array; } -template bool reallot_array_in_place_p(T *array, CELL capacity) +template bool reallot_array_in_place_p(T *array, cell capacity) { return in_zone(&nursery,array) && capacity <= array_capacity(array); } -template T *reallot_array(T *array_, CELL capacity) +template T *reallot_array(T *array_, cell capacity) { gc_root array(array_); @@ -42,7 +42,7 @@ template T *reallot_array(T *array_, CELL capacity) } else { - CELL to_copy = array_capacity(array.untagged()); + cell to_copy = array_capacity(array.untagged()); if(capacity < to_copy) to_copy = capacity; diff --git a/vm/image.cpp b/vm/image.cpp index 6e13c5fa36..2aa7727136 100755 --- a/vm/image.cpp +++ b/vm/image.cpp @@ -4,7 +4,7 @@ namespace factor { /* Certain special objects in the image are known to the runtime */ -static void init_objects(F_IMAGE_HEADER *h) +static void init_objects(image_header *h) { memcpy(userenv,h->userenv,sizeof(userenv)); @@ -14,11 +14,11 @@ static void init_objects(F_IMAGE_HEADER *h) bignum_neg_one = h->bignum_neg_one; } -CELL data_relocation_base; +cell data_relocation_base; -static void load_data_heap(FILE *file, F_IMAGE_HEADER *h, F_PARAMETERS *p) +static void load_data_heap(FILE *file, image_header *h, vm_parameters *p) { - CELL good_size = h->data_size + (1 << 20); + cell good_size = h->data_size + (1 << 20); if(good_size > p->tenured_size) p->tenured_size = good_size; @@ -31,11 +31,11 @@ static void load_data_heap(FILE *file, F_IMAGE_HEADER *h, F_PARAMETERS *p) clear_gc_stats(); - F_ZONE *tenured = &data_heap->generations[TENURED]; + zone *tenured = &data->generations[TENURED]; - F_FIXNUM bytes_read = fread((void*)tenured->start,1,h->data_size,file); + fixnum bytes_read = fread((void*)tenured->start,1,h->data_size,file); - if((CELL)bytes_read != h->data_size) + if((cell)bytes_read != h->data_size) { print_string("truncated image: "); print_fixnum(bytes_read); @@ -49,11 +49,11 @@ static void load_data_heap(FILE *file, F_IMAGE_HEADER *h, F_PARAMETERS *p) data_relocation_base = h->data_relocation_base; } -CELL code_relocation_base; +cell code_relocation_base; -static void load_code_heap(FILE *file, F_IMAGE_HEADER *h, F_PARAMETERS *p) +static void load_code_heap(FILE *file, image_header *h, vm_parameters *p) { - CELL good_size = h->code_size + (1 << 19); + cell good_size = h->code_size + (1 << 19); if(good_size > p->code_size) p->code_size = good_size; @@ -62,7 +62,7 @@ static void load_code_heap(FILE *file, F_IMAGE_HEADER *h, F_PARAMETERS *p) if(h->code_size != 0) { - size_t bytes_read = fread(first_block(&code_heap),1,h->code_size,file); + size_t bytes_read = fread(first_block(&code),1,h->code_size,file); if(bytes_read != h->code_size) { print_string("truncated image: "); @@ -75,14 +75,14 @@ static void load_code_heap(FILE *file, F_IMAGE_HEADER *h, F_PARAMETERS *p) } code_relocation_base = h->code_relocation_base; - build_free_list(&code_heap,h->code_size); + build_free_list(&code,h->code_size); } /* Save the current image to disk */ -bool save_image(const F_CHAR *filename) +bool save_image(const vm_char *filename) { FILE* file; - F_IMAGE_HEADER h; + image_header h; file = OPEN_WRITE(filename); if(file == NULL) @@ -92,21 +92,21 @@ bool save_image(const F_CHAR *filename) return false; } - F_ZONE *tenured = &data_heap->generations[TENURED]; + zone *tenured = &data->generations[TENURED]; h.magic = IMAGE_MAGIC; h.version = IMAGE_VERSION; h.data_relocation_base = tenured->start; h.data_size = tenured->here - tenured->start; - h.code_relocation_base = code_heap.segment->start; - h.code_size = heap_size(&code_heap); + h.code_relocation_base = code.seg->start; + h.code_size = heap_size(&code); h.t = T; h.bignum_zero = bignum_zero; h.bignum_pos_one = bignum_pos_one; h.bignum_neg_one = bignum_neg_one; - CELL i; + cell i; for(i = 0; i < USER_ENV; i++) { if(i < FIRST_SAVE_ENV) @@ -117,9 +117,9 @@ bool save_image(const F_CHAR *filename) bool ok = true; - if(fwrite(&h,sizeof(F_IMAGE_HEADER),1,file) != 1) ok = false; + if(fwrite(&h,sizeof(image_header),1,file) != 1) ok = false; if(fwrite((void*)tenured->start,h.data_size,1,file) != 1) ok = false; - if(fwrite(first_block(&code_heap),h.code_size,1,file) != 1) ok = false; + if(fwrite(first_block(&code),h.code_size,1,file) != 1) ok = false; if(fclose(file)) ok = false; if(!ok) @@ -135,9 +135,9 @@ PRIMITIVE(save_image) /* do a full GC to push everything into tenured space */ gc(); - gc_root path(dpop()); + gc_root path(dpop()); path.untag_check(); - save_image((F_CHAR *)(path.untagged() + 1)); + save_image((vm_char *)(path.untagged() + 1)); } PRIMITIVE(save_image_and_exit) @@ -145,11 +145,11 @@ PRIMITIVE(save_image_and_exit) /* We unbox this before doing anything else. This is the only point where we might throw an error, so we have to throw an error here since later steps destroy the current image. */ - gc_root path(dpop()); + gc_root path(dpop()); path.untag_check(); /* strip out userenv data which is set on startup anyway */ - CELL i; + cell i; for(i = 0; i < FIRST_SAVE_ENV; i++) userenv[i] = F; @@ -162,29 +162,29 @@ PRIMITIVE(save_image_and_exit) performing_compaction = false; /* Save the image */ - if(save_image((F_CHAR *)(path.untagged() + 1))) + if(save_image((vm_char *)(path.untagged() + 1))) exit(0); else exit(1); } -static void data_fixup(CELL *cell) +static void data_fixup(cell *cell) { if(immediate_p(*cell)) return; - F_ZONE *tenured = &data_heap->generations[TENURED]; + zone *tenured = &data->generations[TENURED]; *cell += (tenured->start - data_relocation_base); } -template void code_fixup(T **cell) +template void code_fixup(T **handle) { - T *ptr = *cell; - T *new_ptr = (T *)(((CELL)ptr) + (code_heap.segment->start - code_relocation_base)); - *cell = new_ptr; + T *ptr = *handle; + T *new_ptr = (T *)(((cell)ptr) + (code.seg->start - code_relocation_base)); + *handle = new_ptr; } -static void fixup_word(F_WORD *word) +static void fixup_word(word *word) { if(word->code) code_fixup(&word->code); @@ -193,7 +193,7 @@ static void fixup_word(F_WORD *word) code_fixup(&word->xt); } -static void fixup_quotation(F_QUOTATION *quot) +static void fixup_quotation(quotation *quot) { if(quot->compiledp == F) quot->xt = (void *)lazy_jit_compile; @@ -204,61 +204,61 @@ static void fixup_quotation(F_QUOTATION *quot) } } -static void fixup_alien(F_ALIEN *d) +static void fixup_alien(alien *d) { d->expired = T; } -static void fixup_stack_frame(F_STACK_FRAME *frame) +static void fixup_stack_frame(stack_frame *frame) { code_fixup(&frame->xt); code_fixup(&FRAME_RETURN_ADDRESS(frame)); } -static void fixup_callstack_object(F_CALLSTACK *stack) +static void fixup_callstack_object(callstack *stack) { iterate_callstack_object(stack,fixup_stack_frame); } /* Initialize an object in a newly-loaded image */ -static void relocate_object(F_OBJECT *object) +static void relocate_object(object *object) { - CELL hi_tag = object->header.hi_tag(); + cell hi_tag = object->h.hi_tag(); /* Tuple relocation is a bit trickier; we have to fix up the layout object before we can get the tuple size, so do_slots is out of the question */ if(hi_tag == TUPLE_TYPE) { - F_TUPLE *tuple = (F_TUPLE *)object; - data_fixup(&tuple->layout); + tuple *t = (tuple *)object; + data_fixup(&t->layout); - CELL *scan = (CELL *)(tuple + 1); - CELL *end = (CELL *)((CELL)object + untagged_object_size(object)); + cell *scan = t->data(); + cell *end = (cell *)((cell)object + untagged_object_size(object)); for(; scan < end; scan++) data_fixup(scan); } else { - do_slots((CELL)object,data_fixup); + do_slots((cell)object,data_fixup); switch(hi_tag) { case WORD_TYPE: - fixup_word((F_WORD *)object); + fixup_word((word *)object); break; case QUOTATION_TYPE: - fixup_quotation((F_QUOTATION *)object); + fixup_quotation((quotation *)object); break; case DLL_TYPE: - ffi_dlopen((F_DLL *)object); + ffi_dlopen((dll *)object); break; case ALIEN_TYPE: - fixup_alien((F_ALIEN *)object); + fixup_alien((alien *)object); break; case CALLSTACK_TYPE: - fixup_callstack_object((F_CALLSTACK *)object); + fixup_callstack_object((callstack *)object); break; } } @@ -268,9 +268,9 @@ static void relocate_object(F_OBJECT *object) where it is loaded, we need to fix up pointers in the image. */ void relocate_data() { - CELL relocating; + cell relocating; - CELL i; + cell i; for(i = 0; i < USER_ENV; i++) data_fixup(&userenv[i]); @@ -279,19 +279,19 @@ void relocate_data() data_fixup(&bignum_pos_one); data_fixup(&bignum_neg_one); - F_ZONE *tenured = &data_heap->generations[TENURED]; + zone *tenured = &data->generations[TENURED]; for(relocating = tenured->start; relocating < tenured->here; - relocating += untagged_object_size((F_OBJECT *)relocating)) + relocating += untagged_object_size((object *)relocating)) { - F_OBJECT *object = (F_OBJECT *)relocating; - allot_barrier(object); - relocate_object(object); + object *obj = (object *)relocating; + allot_barrier(obj); + relocate_object(obj); } } -static void fixup_code_block(F_CODE_BLOCK *compiled) +static void fixup_code_block(code_block *compiled) { /* relocate literal table data */ data_fixup(&compiled->relocation); @@ -307,7 +307,7 @@ void relocate_code() /* Read an image file from disk, only done once during startup */ /* This function also initializes the data and code heaps */ -void load_image(F_PARAMETERS *p) +void load_image(vm_parameters *p) { FILE *file = OPEN_READ(p->image_path); if(file == NULL) @@ -317,8 +317,8 @@ void load_image(F_PARAMETERS *p) exit(1); } - F_IMAGE_HEADER h; - if(fread(&h,sizeof(F_IMAGE_HEADER),1,file) != 1) + image_header h; + if(fread(&h,sizeof(image_header),1,file) != 1) fatal_error("Cannot read image header",0); if(h.magic != IMAGE_MAGIC) @@ -338,7 +338,7 @@ void load_image(F_PARAMETERS *p) relocate_code(); /* Store image path name */ - userenv[IMAGE_ENV] = allot_alien(F,(CELL)p->image_path); + userenv[IMAGE_ENV] = allot_alien(F,(cell)p->image_path); } } diff --git a/vm/image.hpp b/vm/image.hpp index 0f7001ad99..c306f322de 100755 --- a/vm/image.hpp +++ b/vm/image.hpp @@ -4,45 +4,45 @@ namespace factor #define IMAGE_MAGIC 0x0f0e0d0c #define IMAGE_VERSION 4 -struct F_IMAGE_HEADER { - CELL magic; - CELL version; +struct image_header { + cell magic; + cell version; /* all pointers in the image file are relocated from relocation_base to here when the image is loaded */ - CELL data_relocation_base; + cell data_relocation_base; /* size of heap */ - CELL data_size; + cell data_size; /* code relocation base */ - CELL code_relocation_base; + cell code_relocation_base; /* size of code heap */ - CELL code_size; + cell code_size; /* tagged pointer to t singleton */ - CELL t; + cell t; /* tagged pointer to bignum 0 */ - CELL bignum_zero; + cell bignum_zero; /* tagged pointer to bignum 1 */ - CELL bignum_pos_one; + cell bignum_pos_one; /* tagged pointer to bignum -1 */ - CELL bignum_neg_one; + cell bignum_neg_one; /* Initial user environment */ - CELL userenv[USER_ENV]; + cell userenv[USER_ENV]; }; -struct F_PARAMETERS { - const F_CHAR *image_path; - const F_CHAR *executable_path; - CELL ds_size, rs_size; - CELL gen_count, young_size, aging_size, tenured_size; - CELL code_size; +struct vm_parameters { + const vm_char *image_path; + const vm_char *executable_path; + cell ds_size, rs_size; + cell gen_count, young_size, aging_size, tenured_size; + cell code_size; bool secure_gc; bool fep; bool console; bool stack_traces; - CELL max_pic_size; + cell max_pic_size; }; -void load_image(F_PARAMETERS *p); -bool save_image(const F_CHAR *file); +void load_image(vm_parameters *p); +bool save_image(const vm_char *file); PRIMITIVE(save_image); PRIMITIVE(save_image_and_exit); diff --git a/vm/inline_cache.cpp b/vm/inline_cache.cpp index 15008fafa0..ea330e863a 100644 --- a/vm/inline_cache.cpp +++ b/vm/inline_cache.cpp @@ -3,26 +3,26 @@ namespace factor { -CELL max_pic_size; +cell max_pic_size; -CELL cold_call_to_ic_transitions; -CELL ic_to_pic_transitions; -CELL pic_to_mega_transitions; +cell cold_call_to_ic_transitions; +cell ic_to_pic_transitions; +cell pic_to_mega_transitions; /* PIC_TAG, PIC_HI_TAG, PIC_TUPLE, PIC_HI_TAG_TUPLE */ -CELL pic_counts[4]; +cell pic_counts[4]; void init_inline_caching(int max_size) { max_pic_size = max_size; } -void deallocate_inline_cache(CELL return_address) +void deallocate_inline_cache(cell return_address) { /* Find the call target. */ - XT old_xt = (XT)get_call_target(return_address); - F_CODE_BLOCK *old_block = (F_CODE_BLOCK *)old_xt - 1; - CELL old_type = old_block->block.type; + void *old_xt = get_call_target(return_address); + code_block *old_block = (code_block *)old_xt - 1; + cell old_type = old_block->block.type; #ifdef FACTOR_DEBUG /* The call target was either another PIC, @@ -31,25 +31,25 @@ void deallocate_inline_cache(CELL return_address) #endif if(old_type == PIC_TYPE) - heap_free(&code_heap,&old_block->block); + heap_free(&code,&old_block->block); } /* Figure out what kind of type check the PIC needs based on the methods it contains */ -static CELL determine_inline_cache_type(F_ARRAY *cache_entries) +static cell determine_inline_cache_type(array *cache_entries) { bool seen_hi_tag = false, seen_tuple = false; - CELL i; + cell i; for(i = 0; i < array_capacity(cache_entries); i += 2) { - CELL klass = array_nth(cache_entries,i); + cell klass = array_nth(cache_entries,i); /* Is it a tuple layout? */ switch(TAG(klass)) { case FIXNUM_TYPE: - F_FIXNUM type = untag_fixnum(klass); + fixnum type = untag_fixnum(klass); if(type >= HEADER_TYPE) seen_hi_tag = true; break; @@ -71,23 +71,23 @@ static CELL determine_inline_cache_type(F_ARRAY *cache_entries) return -1; } -static void update_pic_count(CELL type) +static void update_pic_count(cell type) { pic_counts[type - PIC_TAG]++; } struct inline_cache_jit : public jit { - F_FIXNUM index; + fixnum index; - inline_cache_jit(CELL generic_word_) : jit(PIC_TYPE,generic_word_) {}; + inline_cache_jit(cell generic_word_) : jit(PIC_TYPE,generic_word_) {}; - void emit_check(CELL klass); - void compile_inline_cache(F_FIXNUM index, CELL generic_word_, CELL methods_, CELL cache_entries_); + void emit_check(cell klass); + void compile_inline_cache(fixnum index, cell generic_word_, cell methods_, cell cache_entries_); }; -void inline_cache_jit::emit_check(CELL klass) +void inline_cache_jit::emit_check(cell klass) { - CELL code_template; + cell code_template; if(TAG(klass) == FIXNUM_TYPE && untag_fixnum(klass) < HEADER_TYPE) code_template = userenv[PIC_CHECK_TAG]; else @@ -98,28 +98,28 @@ void inline_cache_jit::emit_check(CELL klass) /* index: 0 = top of stack, 1 = item underneath, etc cache_entries: array of class/method pairs */ -void inline_cache_jit::compile_inline_cache(F_FIXNUM index, CELL generic_word_, CELL methods_, CELL cache_entries_) +void inline_cache_jit::compile_inline_cache(fixnum index, cell generic_word_, cell methods_, cell cache_entries_) { - gc_root generic_word(generic_word_); - gc_root methods(methods_); - gc_root cache_entries(cache_entries_); + gc_root generic_word(generic_word_); + gc_root methods(methods_); + gc_root cache_entries(cache_entries_); - CELL inline_cache_type = determine_inline_cache_type(cache_entries.untagged()); + cell inline_cache_type = determine_inline_cache_type(cache_entries.untagged()); update_pic_count(inline_cache_type); /* Generate machine code to determine the object's class. */ emit_class_lookup(index,inline_cache_type); /* Generate machine code to check, in turn, if the class is one of the cached entries. */ - CELL i; + cell i; for(i = 0; i < array_capacity(cache_entries.untagged()); i += 2) { /* Class equal? */ - CELL klass = array_nth(cache_entries.untagged(),i); + cell klass = array_nth(cache_entries.untagged(),i); emit_check(klass); /* Yes? Jump to method */ - CELL method = array_nth(cache_entries.untagged(),i + 1); + cell method = array_nth(cache_entries.untagged(),i + 1); emit_with(userenv[PIC_HIT],method); } @@ -135,48 +135,48 @@ void inline_cache_jit::compile_inline_cache(F_FIXNUM index, CELL generic_word_, word_jump(userenv[PIC_MISS_WORD]); } -static F_CODE_BLOCK *compile_inline_cache(F_FIXNUM index, - CELL generic_word_, - CELL methods_, - CELL cache_entries_) +static code_block *compile_inline_cache(fixnum index, + cell generic_word_, + cell methods_, + cell cache_entries_) { - gc_root generic_word(generic_word_); - gc_root methods(methods_); - gc_root cache_entries(cache_entries_); + gc_root generic_word(generic_word_); + gc_root methods(methods_); + gc_root cache_entries(cache_entries_); inline_cache_jit jit(generic_word.value()); jit.compile_inline_cache(index,generic_word.value(),methods.value(),cache_entries.value()); - F_CODE_BLOCK *code = jit.code_block(); + code_block *code = jit.to_code_block(); relocate_code_block(code); return code; } /* A generic word's definition performs general method lookup. Allocates memory */ -static XT megamorphic_call_stub(CELL generic_word) +static void *megamorphic_call_stub(cell generic_word) { - return untag(generic_word)->xt; + return untag(generic_word)->xt; } -static CELL inline_cache_size(CELL cache_entries) +static cell inline_cache_size(cell cache_entries) { - return array_capacity(untag_check(cache_entries)) / 2; + return array_capacity(untag_check(cache_entries)) / 2; } /* Allocates memory */ -static CELL add_inline_cache_entry(CELL cache_entries_, CELL klass_, CELL method_) +static cell add_inline_cache_entry(cell cache_entries_, cell klass_, cell method_) { - gc_root cache_entries(cache_entries_); - gc_root klass(klass_); - gc_root method(method_); + gc_root cache_entries(cache_entries_); + gc_root klass(klass_); + gc_root method(method_); - CELL pic_size = array_capacity(cache_entries.untagged()); - gc_root new_cache_entries(reallot_array(cache_entries.untagged(),pic_size + 2)); + cell pic_size = array_capacity(cache_entries.untagged()); + gc_root new_cache_entries(reallot_array(cache_entries.untagged(),pic_size + 2)); set_array_nth(new_cache_entries.untagged(),pic_size,klass.value()); set_array_nth(new_cache_entries.untagged(),pic_size + 1,method.value()); return new_cache_entries.value(); } -static void update_pic_transitions(CELL pic_size) +static void update_pic_transitions(cell pic_size) { if(pic_size == max_pic_size) pic_to_mega_transitions++; @@ -188,7 +188,7 @@ static void update_pic_transitions(CELL pic_size) /* The cache_entries parameter is either f (on cold call site) or an array (on cache miss). Called from assembly with the actual return address */ -XT inline_cache_miss(CELL return_address) +void *inline_cache_miss(cell return_address) { check_code_pointer(return_address); @@ -197,15 +197,15 @@ XT inline_cache_miss(CELL return_address) instead of leaving dead PICs around until the next GC. */ deallocate_inline_cache(return_address); - gc_root cache_entries(dpop()); - F_FIXNUM index = untag_fixnum(dpop()); - gc_root methods(dpop()); - gc_root generic_word(dpop()); - gc_root object(((CELL *)ds)[-index]); + gc_root cache_entries(dpop()); + fixnum index = untag_fixnum(dpop()); + gc_root methods(dpop()); + gc_root generic_word(dpop()); + gc_root object(((cell *)ds)[-index]); - XT xt; + void *xt; - CELL pic_size = inline_cache_size(cache_entries.value()); + cell pic_size = inline_cache_size(cache_entries.value()); update_pic_transitions(pic_size); @@ -213,10 +213,10 @@ XT inline_cache_miss(CELL return_address) xt = megamorphic_call_stub(generic_word.value()); else { - CELL klass = object_class(object.value()); - CELL method = lookup_method(object.value(),methods.value()); + cell klass = object_class(object.value()); + cell method = lookup_method(object.value(),methods.value()); - gc_root new_cache_entries(add_inline_cache_entry( + gc_root new_cache_entries(add_inline_cache_entry( cache_entries.value(), klass, method)); @@ -227,10 +227,10 @@ XT inline_cache_miss(CELL return_address) } /* Install the new stub. */ - set_call_target(return_address,(CELL)xt); + set_call_target(return_address,xt); #ifdef PIC_DEBUG - printf("Updated call site 0x%lx with 0x%lx\n",return_address,(CELL)xt); + printf("Updated call site 0x%lx with 0x%lx\n",return_address,(cell)xt); #endif return xt; @@ -239,7 +239,7 @@ XT inline_cache_miss(CELL return_address) PRIMITIVE(reset_inline_cache_stats) { cold_call_to_ic_transitions = ic_to_pic_transitions = pic_to_mega_transitions = 0; - CELL i; + cell i; for(i = 0; i < 4; i++) pic_counts[i] = 0; } @@ -249,11 +249,11 @@ PRIMITIVE(inline_cache_stats) stats.add(allot_cell(cold_call_to_ic_transitions)); stats.add(allot_cell(ic_to_pic_transitions)); stats.add(allot_cell(pic_to_mega_transitions)); - CELL i; + cell i; for(i = 0; i < 4; i++) stats.add(allot_cell(pic_counts[i])); stats.trim(); - dpush(stats.array.value()); + dpush(stats.elements.value()); } } diff --git a/vm/inline_cache.hpp b/vm/inline_cache.hpp index d1d4226b15..84334efc78 100644 --- a/vm/inline_cache.hpp +++ b/vm/inline_cache.hpp @@ -1,7 +1,7 @@ namespace factor { -extern CELL max_pic_size; +extern cell max_pic_size; void init_inline_caching(int max_size); @@ -9,6 +9,6 @@ PRIMITIVE(reset_inline_cache_stats); PRIMITIVE(inline_cache_stats); PRIMITIVE(inline_cache_miss); -extern "C" XT inline_cache_miss(CELL return_address); +extern "C" void *inline_cache_miss(cell return_address); } diff --git a/vm/io.cpp b/vm/io.cpp index e73735fb85..2d6c94faf0 100755 --- a/vm/io.cpp +++ b/vm/io.cpp @@ -16,9 +16,9 @@ normal operation. */ void init_c_io(void) { - userenv[STDIN_ENV] = allot_alien(F,(CELL)stdin); - userenv[STDOUT_ENV] = allot_alien(F,(CELL)stdout); - userenv[STDERR_ENV] = allot_alien(F,(CELL)stderr); + userenv[STDIN_ENV] = allot_alien(F,(cell)stdin); + userenv[STDOUT_ENV] = allot_alien(F,(cell)stdout); + userenv[STDERR_ENV] = allot_alien(F,(cell)stderr); } void io_error(void) @@ -33,8 +33,8 @@ void io_error(void) PRIMITIVE(fopen) { - gc_root mode(dpop()); - gc_root path(dpop()); + gc_root mode(dpop()); + gc_root path(dpop()); mode.untag_check(); path.untag_check(); @@ -80,15 +80,15 @@ PRIMITIVE(fgetc) PRIMITIVE(fread) { FILE *file = (FILE *)unbox_alien(); - F_FIXNUM size = unbox_array_size(); + fixnum size = unbox_array_size(); if(size == 0) { - dpush(tag(allot_string(0,0))); + dpush(tag(allot_string(0,0))); return; } - gc_root buf(allot_array_internal(size)); + gc_root buf(allot_array_internal(size)); for(;;) { @@ -107,7 +107,7 @@ PRIMITIVE(fread) { if(c != size) { - F_BYTE_ARRAY *new_buf = allot_byte_array(c); + byte_array *new_buf = allot_byte_array(c); memcpy(new_buf + 1, buf.untagged() + 1,c); buf = new_buf; } @@ -120,7 +120,7 @@ PRIMITIVE(fread) PRIMITIVE(fputc) { FILE *file = (FILE *)unbox_alien(); - F_FIXNUM ch = to_fixnum(dpop()); + fixnum ch = to_fixnum(dpop()); for(;;) { @@ -138,8 +138,8 @@ PRIMITIVE(fputc) PRIMITIVE(fwrite) { FILE *file = (FILE *)unbox_alien(); - F_BYTE_ARRAY *text = untag_check(dpop()); - CELL length = array_capacity(text); + byte_array *text = untag_check(dpop()); + cell length = array_capacity(text); char *string = (char *)(text + 1); if(length == 0) diff --git a/vm/jit.cpp b/vm/jit.cpp index 0174faa351..bb86506058 100644 --- a/vm/jit.cpp +++ b/vm/jit.cpp @@ -10,7 +10,7 @@ namespace factor - polymorphic inline caches (inline_cache.cpp) */ /* Allocates memory */ -jit::jit(CELL type_, CELL owner_) +jit::jit(cell type_, cell owner_) : type(type_), owner(owner_), code(), @@ -23,12 +23,12 @@ jit::jit(CELL type_, CELL owner_) if(stack_traces_p()) literal(owner.value()); } -F_REL jit::rel_to_emit(CELL code_template, bool *rel_p) +relocation_entry jit::rel_to_emit(cell code_template, bool *rel_p) { - F_ARRAY *quadruple = untag(code_template); - CELL rel_class = array_nth(quadruple,1); - CELL rel_type = array_nth(quadruple,2); - CELL offset = array_nth(quadruple,3); + array *quadruple = untag(code_template); + cell rel_class = array_nth(quadruple,1); + cell rel_type = array_nth(quadruple,2); + cell offset = array_nth(quadruple,3); if(rel_class == F) { @@ -45,19 +45,19 @@ F_REL jit::rel_to_emit(CELL code_template, bool *rel_p) } /* Allocates memory */ -void jit::emit(CELL code_template_) +void jit::emit(cell code_template_) { - gc_root code_template(code_template_); + gc_root code_template(code_template_); bool rel_p; - F_REL rel = rel_to_emit(code_template.value(),&rel_p); - if(rel_p) relocation.append_bytes(&rel,sizeof(F_REL)); + relocation_entry rel = rel_to_emit(code_template.value(),&rel_p); + if(rel_p) relocation.append_bytes(&rel,sizeof(relocation_entry)); - gc_root insns(array_nth(code_template.untagged(),0)); + gc_root insns(array_nth(code_template.untagged(),0)); if(computing_offset_p) { - CELL size = array_capacity(insns.untagged()); + cell size = array_capacity(insns.untagged()); if(offset == 0) { @@ -76,23 +76,23 @@ void jit::emit(CELL code_template_) code.append_byte_array(insns.value()); } -void jit::emit_with(CELL code_template_, CELL argument_) { - gc_root code_template(code_template_); - gc_root argument(argument_); +void jit::emit_with(cell code_template_, cell argument_) { + gc_root code_template(code_template_); + gc_root argument(argument_); literal(argument.value()); emit(code_template.value()); } -void jit::emit_class_lookup(F_FIXNUM index, CELL type) +void jit::emit_class_lookup(fixnum index, cell type) { - emit_with(userenv[PIC_LOAD],tag_fixnum(-index * CELLS)); + emit_with(userenv[PIC_LOAD],tag_fixnum(-index * sizeof(cell))); emit(userenv[type]); } /* Facility to convert compiled code offsets to quotation offsets. Call jit_compute_offset() with the compiled code offset, then emit code, and at the end jit->position is the quotation position. */ -void jit::compute_position(CELL offset_) +void jit::compute_position(cell offset_) { computing_offset_p = true; position = 0; @@ -100,7 +100,7 @@ void jit::compute_position(CELL offset_) } /* Allocates memory */ -F_CODE_BLOCK *jit::code_block() +code_block *jit::to_code_block() { code.trim(); relocation.trim(); @@ -108,12 +108,10 @@ F_CODE_BLOCK *jit::code_block() return add_code_block( type, - code.array.value(), + code.elements.value(), F, /* no labels */ - relocation.array.value(), - literals.array.value()); + relocation.elements.value(), + literals.elements.value()); } - - } diff --git a/vm/jit.hpp b/vm/jit.hpp index ae6c133141..30b5163b4a 100644 --- a/vm/jit.hpp +++ b/vm/jit.hpp @@ -2,46 +2,46 @@ namespace factor { struct jit { - CELL type; - gc_root owner; + cell type; + gc_root owner; growable_byte_array code; growable_byte_array relocation; growable_array literals; bool computing_offset_p; - F_FIXNUM position; - CELL offset; + fixnum position; + cell offset; - jit(CELL jit_type, CELL owner); - void compute_position(CELL offset); + jit(cell jit_type, cell owner); + void compute_position(cell offset); - F_REL rel_to_emit(CELL code_template, bool *rel_p); - void emit(CELL code_template); + relocation_entry rel_to_emit(cell code_template, bool *rel_p); + void emit(cell code_template); - void literal(CELL literal) { literals.add(literal); } - void emit_with(CELL code_template_, CELL literal_); + void literal(cell literal) { literals.add(literal); } + void emit_with(cell code_template_, cell literal_); - void push(CELL literal) { + void push(cell literal) { emit_with(userenv[JIT_PUSH_IMMEDIATE],literal); } - void word_jump(CELL word) { + void word_jump(cell word) { emit_with(userenv[JIT_WORD_JUMP],word); } - void word_call(CELL word) { + void word_call(cell word) { emit_with(userenv[JIT_WORD_CALL],word); } - void emit_subprimitive(CELL word_) { - gc_root word(word_); - gc_root code_template(word->subprimitive); + void emit_subprimitive(cell word_) { + gc_root word(word_); + gc_root code_template(word->subprimitive); if(array_nth(code_template.untagged(),1) != F) literal(T); emit(code_template.value()); } - void emit_class_lookup(F_FIXNUM index, CELL type); + void emit_class_lookup(fixnum index, cell type); - F_FIXNUM get_position() { + fixnum get_position() { if(computing_offset_p) { /* If this is still on, emit() didn't clear it, @@ -52,13 +52,13 @@ struct jit { return position; } - void set_position(F_FIXNUM position_) { + void set_position(fixnum position_) { if(computing_offset_p) position = position_; } - F_CODE_BLOCK *code_block(); + code_block *to_code_block(); }; } diff --git a/vm/layouts.hpp b/vm/layouts.hpp index abdd99be21..4928fda632 100755 --- a/vm/layouts.hpp +++ b/vm/layouts.hpp @@ -11,16 +11,14 @@ typedef signed int s32; typedef signed long long s64; #ifdef _WIN64 - typedef long long F_FIXNUM; - typedef unsigned long long CELL; + typedef long long fixnum; + typedef unsigned long long cell; #else - typedef long F_FIXNUM; - typedef unsigned long CELL; + typedef long fixnum; + typedef unsigned long cell; #endif -#define CELLS ((signed)sizeof(CELL)) - -inline static CELL align(CELL a, CELL b) +inline static cell align(cell a, cell b) { return (a + (b-1)) & ~(b-1); } @@ -28,15 +26,13 @@ inline static CELL align(CELL a, CELL b) #define align8(a) align(a,8) #define align_page(a) align(a,getpagesize()) -#define WORD_SIZE (CELLS*8) -#define HALF_WORD_SIZE (CELLS*4) -#define HALF_WORD_MASK (((unsigned long)1<> TAG_BITS; + return ((fixnum)tagged) >> TAG_BITS; } -inline static CELL tag_fixnum(F_FIXNUM untagged) +inline static cell tag_fixnum(fixnum untagged) { return RETAG(untagged << TAG_BITS,FIXNUM_TYPE); } -inline static CELL tag_for(CELL type) +inline static cell tag_for(cell type) { return type < HEADER_TYPE ? type : OBJECT_TYPE; } -typedef void *XT; +class object; -class F_OBJECT; +struct header { + cell value; -struct F_HEADER { - CELL header; - - F_HEADER(CELL header_) : header(header_ << TAG_BITS) {} + header(cell value_) : value(value_ << TAG_BITS) {} void check_header() { #ifdef FACTOR_DEBUG - assert(TAG(header) == FIXNUM_TYPE && untag_fixnum(header) < TYPE_COUNT); + assert(TAG(value) == FIXNUM_TYPE && untag_fixnum(value) < TYPE_COUNT); #endif } - CELL hi_tag() { + cell hi_tag() { check_header(); - return header >> TAG_BITS; - } - - void set(CELL header_) { - header = header_ << TAG_BITS; + return value >> TAG_BITS; } bool forwarding_pointer_p() { - return TAG(header) == GC_COLLECTED; + return TAG(value) == GC_COLLECTED; } - F_OBJECT *forwarding_pointer() { - return (F_OBJECT *)UNTAG(header); + object *forwarding_pointer() { + return (object *)UNTAG(value); } - void forward_to(F_OBJECT *pointer) { - header = RETAG(pointer,GC_COLLECTED); + void forward_to(object *pointer) { + value = RETAG(pointer,GC_COLLECTED); } }; -#define NO_TYPE_CHECK static const CELL type_number = TYPE_COUNT +#define NO_TYPE_CHECK static const cell type_number = TYPE_COUNT -struct F_OBJECT { +struct object { NO_TYPE_CHECK; - F_HEADER header; - CELL *slots() { return (CELL *)this; } + header h; + cell *slots() { return (cell *)this; } }; /* Assembly code makes assumptions about the layout of this struct */ -struct F_ARRAY : public F_OBJECT { - static const CELL type_number = ARRAY_TYPE; - static const CELL element_size = CELLS; +struct array : public object { + static const cell type_number = ARRAY_TYPE; + static const cell element_size = sizeof(cell); /* tagged */ - CELL capacity; + cell capacity; - CELL *data() { return (CELL *)(this + 1); } + cell *data() { return (cell *)(this + 1); } }; /* These are really just arrays, but certain elements have special significance */ -struct F_TUPLE_LAYOUT : public F_ARRAY { +struct tuple_layout : public array { NO_TYPE_CHECK; /* tagged */ - CELL klass; + cell klass; /* tagged fixnum */ - CELL size; + cell size; /* tagged fixnum */ - CELL echelon; + cell echelon; }; -struct F_BIGNUM : public F_OBJECT { - static const CELL type_number = BIGNUM_TYPE; - static const CELL element_size = CELLS; +struct bignum : public object { + static const cell type_number = BIGNUM_TYPE; + static const cell element_size = sizeof(cell); /* tagged */ - CELL capacity; + cell capacity; - CELL *data() { return (CELL *)(this + 1); } + cell *data() { return (cell *)(this + 1); } }; -struct F_BYTE_ARRAY : public F_OBJECT { - static const CELL type_number = BYTE_ARRAY_TYPE; - static const CELL element_size = 1; +struct byte_array : public object { + static const cell type_number = BYTE_ARRAY_TYPE; + static const cell element_size = 1; /* tagged */ - CELL capacity; + cell capacity; template T *data() { return (T *)(this + 1); } }; /* Assembly code makes assumptions about the layout of this struct */ -struct F_STRING : public F_OBJECT { - static const CELL type_number = STRING_TYPE; +struct string : public object { + static const cell type_number = STRING_TYPE; /* tagged num of chars */ - CELL length; + cell length; /* tagged */ - CELL aux; + cell aux; /* tagged */ - CELL hashcode; + cell hashcode; u8 *data() { return (u8 *)(this + 1); } }; /* The compiled code heap is structured into blocks. */ -typedef enum +enum block_status { B_FREE, B_ALLOCATED, B_MARKED -} F_BLOCK_STATUS; +}; -struct F_BLOCK +struct heap_block { unsigned char status; /* free or allocated? */ unsigned char type; /* this is WORD_TYPE or QUOTATION_TYPE */ @@ -206,126 +196,128 @@ struct F_BLOCK char needs_fixup; /* is this a new block that needs full fixup? */ /* In bytes, includes this header */ - CELL size; + cell size; /* Used during compaction */ - F_BLOCK *forwarding; + heap_block *forwarding; }; -struct F_FREE_BLOCK +struct free_heap_block { - F_BLOCK block; + heap_block block; /* Filled in on image load */ - F_FREE_BLOCK *next_free; + free_heap_block *next_free; }; -struct F_CODE_BLOCK +struct code_block { - F_BLOCK block; - CELL literals; /* # bytes */ - CELL relocation; /* tagged pointer to byte-array or f */ + heap_block block; + cell literals; /* # bytes */ + cell relocation; /* tagged pointer to byte-array or f */ + + void *xt() { return (void *)(this + 1); } }; /* Assembly code makes assumptions about the layout of this struct */ -struct F_WORD : public F_OBJECT { - static const CELL type_number = WORD_TYPE; +struct word : public object { + static const cell type_number = WORD_TYPE; /* TAGGED hashcode */ - CELL hashcode; + cell hashcode; /* TAGGED word name */ - CELL name; + cell name; /* TAGGED word vocabulary */ - CELL vocabulary; + cell vocabulary; /* TAGGED definition */ - CELL def; + cell def; /* TAGGED property assoc for library code */ - CELL props; + cell props; /* TAGGED alternative entry point for direct non-tail calls. Used for inline caching */ - CELL direct_entry_def; + cell direct_entry_def; /* TAGGED call count for profiling */ - CELL counter; + cell counter; /* TAGGED machine code for sub-primitive */ - CELL subprimitive; + cell subprimitive; /* UNTAGGED execution token: jump here to execute word */ - XT xt; + void *xt; /* UNTAGGED compiled code block */ - F_CODE_BLOCK *code; + code_block *code; /* UNTAGGED profiler stub */ - F_CODE_BLOCK *profiling; + code_block *profiling; }; /* Assembly code makes assumptions about the layout of this struct */ -struct F_WRAPPER : public F_OBJECT { - static const CELL type_number = WRAPPER_TYPE; - CELL object; +struct wrapper : public object { + static const cell type_number = WRAPPER_TYPE; + cell object; }; /* Assembly code makes assumptions about the layout of this struct */ -struct F_FLOAT : F_OBJECT { - static const CELL type_number = FLOAT_TYPE; +struct boxed_float : object { + static const cell type_number = FLOAT_TYPE; #ifndef FACTOR_64 - CELL padding; + cell padding; #endif double n; }; /* Assembly code makes assumptions about the layout of this struct */ -struct F_QUOTATION : public F_OBJECT { - static const CELL type_number = QUOTATION_TYPE; +struct quotation : public object { + static const cell type_number = QUOTATION_TYPE; /* tagged */ - CELL array; + cell array; /* tagged */ - CELL compiledp; + cell compiledp; /* tagged */ - CELL cached_effect; + cell cached_effect; /* tagged */ - CELL cache_counter; + cell cache_counter; /* UNTAGGED */ - XT xt; + void *xt; /* UNTAGGED compiled code block */ - F_CODE_BLOCK *code; + code_block *code; }; /* Assembly code makes assumptions about the layout of this struct */ -struct F_ALIEN : public F_OBJECT { - static const CELL type_number = ALIEN_TYPE; +struct alien : public object { + static const cell type_number = ALIEN_TYPE; /* tagged */ - CELL alien; + cell alien; /* tagged */ - CELL expired; + cell expired; /* untagged */ - CELL displacement; + cell displacement; }; -struct F_DLL : public F_OBJECT { - static const CELL type_number = DLL_TYPE; +struct dll : public object { + static const cell type_number = DLL_TYPE; /* tagged byte array holding a C string */ - CELL path; + cell path; /* OS-specific handle */ void *dll; }; -struct F_CALLSTACK : public F_OBJECT { - static const CELL type_number = CALLSTACK_TYPE; +struct callstack : public object { + static const cell type_number = CALLSTACK_TYPE; /* tagged */ - CELL length; + cell length; }; -struct F_STACK_FRAME +struct stack_frame { - XT xt; + void *xt; /* Frame size in bytes */ - CELL size; + cell size; }; -struct F_TUPLE : public F_OBJECT { - static const CELL type_number = TUPLE_TYPE; +struct tuple : public object { + static const cell type_number = TUPLE_TYPE; /* tagged layout */ - CELL layout; + cell layout; - CELL *data() { return (CELL *)(this + 1); } + cell *data() { return (cell *)(this + 1); } }; } diff --git a/vm/local_roots.cpp b/vm/local_roots.cpp index 41bb8191ea..717beb32c7 100644 --- a/vm/local_roots.cpp +++ b/vm/local_roots.cpp @@ -3,10 +3,10 @@ namespace factor { -F_SEGMENT *gc_locals_region; -CELL gc_locals; +segment *gc_locals_region; +cell gc_locals; -F_SEGMENT *gc_bignums_region; -CELL gc_bignums; +segment *gc_bignums_region; +cell gc_bignums; } diff --git a/vm/local_roots.hpp b/vm/local_roots.hpp index bd4eed7f67..9506a421f5 100644 --- a/vm/local_roots.hpp +++ b/vm/local_roots.hpp @@ -4,42 +4,42 @@ namespace factor /* If a runtime function needs to call another function which potentially allocates memory, it must wrap any local variable references to Factor objects in gc_root instances */ -extern F_SEGMENT *gc_locals_region; -extern CELL gc_locals; +extern segment *gc_locals_region; +extern cell gc_locals; DEFPUSHPOP(gc_local_,gc_locals) template struct gc_root : public tagged { - void push() { gc_local_push((CELL)this); } + void push() { gc_local_push((cell)this); } - explicit gc_root(CELL value_) : tagged(value_) { push(); } + explicit gc_root(cell value_) : tagged(value_) { push(); } explicit gc_root(T *value_) : tagged(value_) { push(); } const gc_root& operator=(const T *x) { tagged::operator=(x); return *this; } - const gc_root& operator=(const CELL &x) { tagged::operator=(x); return *this; } + const gc_root& operator=(const cell &x) { tagged::operator=(x); return *this; } - ~gc_root() { CELL old = gc_local_pop(); assert(old == (CELL)this); } + ~gc_root() { cell old = gc_local_pop(); assert(old == (cell)this); } }; /* A similar hack for the bignum implementation */ -extern F_SEGMENT *gc_bignums_region; -extern CELL gc_bignums; +extern segment *gc_bignums_region; +extern cell gc_bignums; DEFPUSHPOP(gc_bignum_,gc_bignums) struct gc_bignum { - F_BIGNUM **addr; + bignum **addr; - gc_bignum(F_BIGNUM **addr_) : addr(addr_) { + gc_bignum(bignum **addr_) : addr(addr_) { if(*addr_) check_data_pointer(*addr_); - gc_bignum_push((CELL)addr); + gc_bignum_push((cell)addr); } - ~gc_bignum() { assert((CELL)addr == gc_bignum_pop()); } + ~gc_bignum() { assert((cell)addr == gc_bignum_pop()); } }; #define GC_BIGNUM(x) gc_bignum x##__gc_root(&x) diff --git a/vm/mach_signal.cpp b/vm/mach_signal.cpp index 901f3de971..f752c3cb8f 100644 --- a/vm/mach_signal.cpp +++ b/vm/mach_signal.cpp @@ -39,7 +39,7 @@ static void call_fault_handler(exception_type_t exception, /* Are we in compiled Factor code? Then use the current stack pointer */ if(in_code_heap_p(MACH_PROGRAM_COUNTER(thread_state))) - signal_callstack_top = (F_STACK_FRAME *)MACH_STACK_POINTER(thread_state); + signal_callstack_top = (stack_frame *)MACH_STACK_POINTER(thread_state); /* Are we in C? Then use the saved callstack top */ else signal_callstack_top = NULL; @@ -50,7 +50,7 @@ static void call_fault_handler(exception_type_t exception, if(exception == EXC_BAD_ACCESS) { signal_fault_addr = MACH_EXC_STATE_FAULT(exc_state); - MACH_PROGRAM_COUNTER(thread_state) = (CELL)memory_signal_handler_impl; + MACH_PROGRAM_COUNTER(thread_state) = (cell)memory_signal_handler_impl; } else { @@ -58,7 +58,7 @@ static void call_fault_handler(exception_type_t exception, signal_number = SIGFPE; else signal_number = SIGABRT; - MACH_PROGRAM_COUNTER(thread_state) = (CELL)misc_signal_handler_impl; + MACH_PROGRAM_COUNTER(thread_state) = (cell)misc_signal_handler_impl; } } diff --git a/vm/master.hpp b/vm/master.hpp index 039ef9c1f9..fa7d7fa1a4 100644 --- a/vm/master.hpp +++ b/vm/master.hpp @@ -32,8 +32,8 @@ #include "errors.hpp" #include "bignumint.hpp" #include "bignum.hpp" -#include "write_barrier.hpp" #include "data_heap.hpp" +#include "write_barrier.hpp" #include "data_gc.hpp" #include "local_roots.hpp" #include "generic_arrays.hpp" diff --git a/vm/math.cpp b/vm/math.cpp index 7a01b1adb4..57d5e4a517 100644 --- a/vm/math.cpp +++ b/vm/math.cpp @@ -3,13 +3,13 @@ namespace factor { -CELL bignum_zero; -CELL bignum_pos_one; -CELL bignum_neg_one; +cell bignum_zero; +cell bignum_pos_one; +cell bignum_neg_one; PRIMITIVE(bignum_to_fixnum) { - drepl(tag_fixnum(bignum_to_fixnum(untag(dpeek())))); + drepl(tag_fixnum(bignum_to_fixnum(untag(dpeek())))); } PRIMITIVE(float_to_fixnum) @@ -21,9 +21,9 @@ PRIMITIVE(float_to_fixnum) by -1. */ PRIMITIVE(fixnum_divint) { - F_FIXNUM y = untag_fixnum(dpop()); \ - F_FIXNUM x = untag_fixnum(dpeek()); - F_FIXNUM result = x / y; + fixnum y = untag_fixnum(dpop()); \ + fixnum x = untag_fixnum(dpeek()); + fixnum result = x / y; if(result == -FIXNUM_MIN) drepl(allot_integer(-FIXNUM_MIN)); else @@ -32,17 +32,17 @@ PRIMITIVE(fixnum_divint) PRIMITIVE(fixnum_divmod) { - CELL y = ((CELL *)ds)[0]; - CELL x = ((CELL *)ds)[-1]; + cell y = ((cell *)ds)[0]; + cell x = ((cell *)ds)[-1]; if(y == tag_fixnum(-1) && x == tag_fixnum(FIXNUM_MIN)) { - ((CELL *)ds)[-1] = allot_integer(-FIXNUM_MIN); - ((CELL *)ds)[0] = tag_fixnum(0); + ((cell *)ds)[-1] = allot_integer(-FIXNUM_MIN); + ((cell *)ds)[0] = tag_fixnum(0); } else { - ((CELL *)ds)[-1] = tag_fixnum(untag_fixnum(x) / untag_fixnum(y)); - ((CELL *)ds)[0] = (F_FIXNUM)x % (F_FIXNUM)y; + ((cell *)ds)[-1] = tag_fixnum(untag_fixnum(x) / untag_fixnum(y)); + ((cell *)ds)[0] = (fixnum)x % (fixnum)y; } } @@ -56,8 +56,8 @@ PRIMITIVE(fixnum_divmod) PRIMITIVE(fixnum_shift) { - F_FIXNUM y = untag_fixnum(dpop()); \ - F_FIXNUM x = untag_fixnum(dpeek()); + fixnum y = untag_fixnum(dpop()); \ + fixnum x = untag_fixnum(dpeek()); if(x == 0) return; @@ -69,7 +69,7 @@ PRIMITIVE(fixnum_shift) } else if(y < WORD_SIZE - TAG_BITS) { - F_FIXNUM mask = -((F_FIXNUM)1 << (WORD_SIZE - 1 - TAG_BITS - y)); + fixnum mask = -((fixnum)1 << (WORD_SIZE - 1 - TAG_BITS - y)); if(!(BRANCHLESS_ABS(x) & mask)) { drepl(tag_fixnum(x << y)); @@ -77,23 +77,23 @@ PRIMITIVE(fixnum_shift) } } - drepl(tag(bignum_arithmetic_shift( + drepl(tag(bignum_arithmetic_shift( fixnum_to_bignum(x),y))); } PRIMITIVE(fixnum_to_bignum) { - drepl(tag(fixnum_to_bignum(untag_fixnum(dpeek())))); + drepl(tag(fixnum_to_bignum(untag_fixnum(dpeek())))); } PRIMITIVE(float_to_bignum) { - drepl(tag(float_to_bignum(dpeek()))); + drepl(tag(float_to_bignum(dpeek()))); } #define POP_BIGNUMS(x,y) \ - F_BIGNUM * y = untag(dpop()); \ - F_BIGNUM * x = untag(dpop()); + bignum * y = untag(dpop()); \ + bignum * x = untag(dpop()); PRIMITIVE(bignum_eq) { @@ -104,65 +104,65 @@ PRIMITIVE(bignum_eq) PRIMITIVE(bignum_add) { POP_BIGNUMS(x,y); - dpush(tag(bignum_add(x,y))); + dpush(tag(bignum_add(x,y))); } PRIMITIVE(bignum_subtract) { POP_BIGNUMS(x,y); - dpush(tag(bignum_subtract(x,y))); + dpush(tag(bignum_subtract(x,y))); } PRIMITIVE(bignum_multiply) { POP_BIGNUMS(x,y); - dpush(tag(bignum_multiply(x,y))); + dpush(tag(bignum_multiply(x,y))); } PRIMITIVE(bignum_divint) { POP_BIGNUMS(x,y); - dpush(tag(bignum_quotient(x,y))); + dpush(tag(bignum_quotient(x,y))); } PRIMITIVE(bignum_divmod) { - F_BIGNUM *q, *r; + bignum *q, *r; POP_BIGNUMS(x,y); bignum_divide(x,y,&q,&r); - dpush(tag(q)); - dpush(tag(r)); + dpush(tag(q)); + dpush(tag(r)); } PRIMITIVE(bignum_mod) { POP_BIGNUMS(x,y); - dpush(tag(bignum_remainder(x,y))); + dpush(tag(bignum_remainder(x,y))); } PRIMITIVE(bignum_and) { POP_BIGNUMS(x,y); - dpush(tag(bignum_bitwise_and(x,y))); + dpush(tag(bignum_bitwise_and(x,y))); } PRIMITIVE(bignum_or) { POP_BIGNUMS(x,y); - dpush(tag(bignum_bitwise_ior(x,y))); + dpush(tag(bignum_bitwise_ior(x,y))); } PRIMITIVE(bignum_xor) { POP_BIGNUMS(x,y); - dpush(tag(bignum_bitwise_xor(x,y))); + dpush(tag(bignum_bitwise_xor(x,y))); } PRIMITIVE(bignum_shift) { - F_FIXNUM y = untag_fixnum(dpop()); - F_BIGNUM* x = untag(dpop()); - dpush(tag(bignum_arithmetic_shift(x,y))); + fixnum y = untag_fixnum(dpop()); + bignum* x = untag(dpop()); + dpush(tag(bignum_arithmetic_shift(x,y))); } PRIMITIVE(bignum_less) @@ -191,19 +191,19 @@ PRIMITIVE(bignum_greatereq) PRIMITIVE(bignum_not) { - drepl(tag(bignum_bitwise_not(untag(dpeek())))); + drepl(tag(bignum_bitwise_not(untag(dpeek())))); } PRIMITIVE(bignum_bitp) { - F_FIXNUM bit = to_fixnum(dpop()); - F_BIGNUM *x = untag(dpop()); + fixnum bit = to_fixnum(dpop()); + bignum *x = untag(dpop()); box_boolean(bignum_logbitp(bit,x)); } PRIMITIVE(bignum_log2) { - drepl(tag(bignum_integer_length(untag(dpeek())))); + drepl(tag(bignum_integer_length(untag(dpeek())))); } unsigned int bignum_producer(unsigned int digit) @@ -214,19 +214,19 @@ unsigned int bignum_producer(unsigned int digit) PRIMITIVE(byte_array_to_bignum) { - CELL n_digits = array_capacity(untag_check(dpeek())); - F_BIGNUM * bignum = digit_stream_to_bignum(n_digits,bignum_producer,0x100,0); - drepl(tag(bignum)); + cell n_digits = array_capacity(untag_check(dpeek())); + bignum * result = digit_stream_to_bignum(n_digits,bignum_producer,0x100,0); + drepl(tag(result)); } -CELL unbox_array_size(void) +cell unbox_array_size(void) { - switch(tagged(dpeek()).type()) + switch(tagged(dpeek()).type()) { case FIXNUM_TYPE: { - F_FIXNUM n = untag_fixnum(dpeek()); - if(n >= 0 && n < (F_FIXNUM)ARRAY_SIZE_MAX) + fixnum n = untag_fixnum(dpeek()); + if(n >= 0 && n < (fixnum)ARRAY_SIZE_MAX) { dpop(); return n; @@ -235,9 +235,9 @@ CELL unbox_array_size(void) } case BIGNUM_TYPE: { - F_BIGNUM * zero = untag(bignum_zero); - F_BIGNUM * max = cell_to_bignum(ARRAY_SIZE_MAX); - F_BIGNUM * n = untag(dpeek()); + bignum * zero = untag(bignum_zero); + bignum * max = cell_to_bignum(ARRAY_SIZE_MAX); + bignum * n = untag(dpeek()); if(bignum_compare(n,zero) != bignum_comparison_less && bignum_compare(n,max) == bignum_comparison_less) { @@ -264,8 +264,8 @@ PRIMITIVE(bignum_to_float) PRIMITIVE(str_to_float) { - F_BYTE_ARRAY *bytes = untag_check(dpeek()); - CELL capacity = array_capacity(bytes); + byte_array *bytes = untag_check(dpeek()); + cell capacity = array_capacity(bytes); char *c_str = (char *)(bytes + 1); char *end = c_str; @@ -278,9 +278,9 @@ PRIMITIVE(str_to_float) PRIMITIVE(float_to_str) { - F_BYTE_ARRAY *array = allot_byte_array(33); + byte_array *array = allot_byte_array(33); snprintf((char *)(array + 1),32,"%.16g",untag_float_check(dpop())); - dpush(tag(array)); + dpush(tag(array)); } #define POP_FLOATS(x,y) \ @@ -367,23 +367,23 @@ PRIMITIVE(bits_double) box_double(bits_double(to_unsigned_8(dpop()))); } -VM_C_API F_FIXNUM to_fixnum(CELL tagged) +VM_C_API fixnum to_fixnum(cell tagged) { switch(TAG(tagged)) { case FIXNUM_TYPE: return untag_fixnum(tagged); case BIGNUM_TYPE: - return bignum_to_fixnum(untag(tagged)); + return bignum_to_fixnum(untag(tagged)); default: type_error(FIXNUM_TYPE,tagged); return -1; /* can't happen */ } } -VM_C_API CELL to_cell(CELL tagged) +VM_C_API cell to_cell(cell tagged) { - return (CELL)to_fixnum(tagged); + return (cell)to_fixnum(tagged); } VM_C_API void box_signed_1(s8 n) @@ -416,12 +416,12 @@ VM_C_API void box_unsigned_4(u32 n) dpush(allot_cell(n)); } -VM_C_API void box_signed_cell(F_FIXNUM integer) +VM_C_API void box_signed_cell(fixnum integer) { dpush(allot_integer(integer)); } -VM_C_API void box_unsigned_cell(CELL cell) +VM_C_API void box_unsigned_cell(cell cell) { dpush(allot_cell(cell)); } @@ -429,19 +429,19 @@ VM_C_API void box_unsigned_cell(CELL cell) VM_C_API void box_signed_8(s64 n) { if(n < FIXNUM_MIN || n > FIXNUM_MAX) - dpush(tag(long_long_to_bignum(n))); + dpush(tag(long_long_to_bignum(n))); else dpush(tag_fixnum(n)); } -VM_C_API s64 to_signed_8(CELL obj) +VM_C_API s64 to_signed_8(cell obj) { - switch(tagged(obj).type()) + switch(tagged(obj).type()) { case FIXNUM_TYPE: return untag_fixnum(obj); case BIGNUM_TYPE: - return bignum_to_long_long(untag(obj)); + return bignum_to_long_long(untag(obj)); default: type_error(BIGNUM_TYPE,obj); return -1; @@ -451,19 +451,19 @@ VM_C_API s64 to_signed_8(CELL obj) VM_C_API void box_unsigned_8(u64 n) { if(n > FIXNUM_MAX) - dpush(tag(ulong_long_to_bignum(n))); + dpush(tag(ulong_long_to_bignum(n))); else dpush(tag_fixnum(n)); } -VM_C_API u64 to_unsigned_8(CELL obj) +VM_C_API u64 to_unsigned_8(cell obj) { - switch(tagged(obj).type()) + switch(tagged(obj).type()) { case FIXNUM_TYPE: return untag_fixnum(obj); case BIGNUM_TYPE: - return bignum_to_ulong_long(untag(obj)); + return bignum_to_ulong_long(untag(obj)); default: type_error(BIGNUM_TYPE,obj); return -1; @@ -475,7 +475,7 @@ VM_C_API void box_float(float flo) dpush(allot_float(flo)); } -VM_C_API float to_float(CELL value) +VM_C_API float to_float(cell value) { return untag_float_check(value); } @@ -485,32 +485,32 @@ VM_C_API void box_double(double flo) dpush(allot_float(flo)); } -VM_C_API double to_double(CELL value) +VM_C_API double to_double(cell value) { return untag_float_check(value); } /* The fixnum+, fixnum- and fixnum* primitives are defined in cpu_*.S. On overflow, they call these functions. */ -VM_ASM_API void overflow_fixnum_add(F_FIXNUM x, F_FIXNUM y) +VM_ASM_API void overflow_fixnum_add(fixnum x, fixnum y) { - drepl(tag(fixnum_to_bignum( + drepl(tag(fixnum_to_bignum( untag_fixnum(x) + untag_fixnum(y)))); } -VM_ASM_API void overflow_fixnum_subtract(F_FIXNUM x, F_FIXNUM y) +VM_ASM_API void overflow_fixnum_subtract(fixnum x, fixnum y) { - drepl(tag(fixnum_to_bignum( + drepl(tag(fixnum_to_bignum( untag_fixnum(x) - untag_fixnum(y)))); } -VM_ASM_API void overflow_fixnum_multiply(F_FIXNUM x, F_FIXNUM y) +VM_ASM_API void overflow_fixnum_multiply(fixnum x, fixnum y) { - F_BIGNUM *bx = fixnum_to_bignum(x); + bignum *bx = fixnum_to_bignum(x); GC_BIGNUM(bx); - F_BIGNUM *by = fixnum_to_bignum(y); + bignum *by = fixnum_to_bignum(y); GC_BIGNUM(by); - drepl(tag(bignum_multiply(bx,by))); + drepl(tag(bignum_multiply(bx,by))); } } diff --git a/vm/math.hpp b/vm/math.hpp index 05624d56e2..763ed55f9a 100644 --- a/vm/math.hpp +++ b/vm/math.hpp @@ -1,14 +1,14 @@ namespace factor { -extern CELL bignum_zero; -extern CELL bignum_pos_one; -extern CELL bignum_neg_one; +extern cell bignum_zero; +extern cell bignum_pos_one; +extern cell bignum_neg_one; -#define CELL_MAX (CELL)(-1) -#define FIXNUM_MAX (((F_FIXNUM)1 << (WORD_SIZE - TAG_BITS - 1)) - 1) -#define FIXNUM_MIN (-((F_FIXNUM)1 << (WORD_SIZE - TAG_BITS - 1))) -#define ARRAY_SIZE_MAX ((CELL)1 << (WORD_SIZE - TAG_BITS - 2)) +#define cell_MAX (cell)(-1) +#define FIXNUM_MAX (((fixnum)1 << (WORD_SIZE - TAG_BITS - 1)) - 1) +#define FIXNUM_MIN (-((fixnum)1 << (WORD_SIZE - TAG_BITS - 1))) +#define ARRAY_SIZE_MAX ((cell)1 << (WORD_SIZE - TAG_BITS - 2)) PRIMITIVE(fixnum_add); PRIMITIVE(fixnum_subtract); @@ -43,59 +43,59 @@ PRIMITIVE(bignum_bitp); PRIMITIVE(bignum_log2); PRIMITIVE(byte_array_to_bignum); -inline static CELL allot_integer(F_FIXNUM x) +inline static cell allot_integer(fixnum x) { if(x < FIXNUM_MIN || x > FIXNUM_MAX) - return tag(fixnum_to_bignum(x)); + return tag(fixnum_to_bignum(x)); else return tag_fixnum(x); } -inline static CELL allot_cell(CELL x) +inline static cell allot_cell(cell x) { - if(x > (CELL)FIXNUM_MAX) - return tag(cell_to_bignum(x)); + if(x > (cell)FIXNUM_MAX) + return tag(cell_to_bignum(x)); else return tag_fixnum(x); } -CELL unbox_array_size(void); +cell unbox_array_size(void); -inline static double untag_float(CELL tagged) +inline static double untag_float(cell tagged) { - return untag(tagged)->n; + return untag(tagged)->n; } -inline static double untag_float_check(CELL tagged) +inline static double untag_float_check(cell tagged) { - return untag_check(tagged)->n; + return untag_check(tagged)->n; } -inline static CELL allot_float(double n) +inline static cell allot_float(double n) { - F_FLOAT *flo = allot(sizeof(F_FLOAT)); + boxed_float *flo = allot(sizeof(boxed_float)); flo->n = n; return tag(flo); } -inline static F_FIXNUM float_to_fixnum(CELL tagged) +inline static fixnum float_to_fixnum(cell tagged) { - return (F_FIXNUM)untag_float(tagged); + return (fixnum)untag_float(tagged); } -inline static F_BIGNUM *float_to_bignum(CELL tagged) +inline static bignum *float_to_bignum(cell tagged) { return double_to_bignum(untag_float(tagged)); } -inline static double fixnum_to_float(CELL tagged) +inline static double fixnum_to_float(cell tagged) { return (double)untag_fixnum(tagged); } -inline static double bignum_to_float(CELL tagged) +inline static double bignum_to_float(cell tagged) { - return bignum_to_double(untag(tagged)); + return bignum_to_double(untag(tagged)); } PRIMITIVE(fixnum_to_float); @@ -121,9 +121,9 @@ PRIMITIVE(double_bits); PRIMITIVE(bits_double); VM_C_API void box_float(float flo); -VM_C_API float to_float(CELL value); +VM_C_API float to_float(cell value); VM_C_API void box_double(double flo); -VM_C_API double to_double(CELL value); +VM_C_API double to_double(cell value); VM_C_API void box_signed_1(s8 n); VM_C_API void box_unsigned_1(u8 n); @@ -131,19 +131,19 @@ VM_C_API void box_signed_2(s16 n); VM_C_API void box_unsigned_2(u16 n); VM_C_API void box_signed_4(s32 n); VM_C_API void box_unsigned_4(u32 n); -VM_C_API void box_signed_cell(F_FIXNUM integer); -VM_C_API void box_unsigned_cell(CELL cell); +VM_C_API void box_signed_cell(fixnum integer); +VM_C_API void box_unsigned_cell(cell cell); VM_C_API void box_signed_8(s64 n); VM_C_API void box_unsigned_8(u64 n); -VM_C_API s64 to_signed_8(CELL obj); -VM_C_API u64 to_unsigned_8(CELL obj); +VM_C_API s64 to_signed_8(cell obj); +VM_C_API u64 to_unsigned_8(cell obj); -VM_C_API F_FIXNUM to_fixnum(CELL tagged); -VM_C_API CELL to_cell(CELL tagged); +VM_C_API fixnum to_fixnum(cell tagged); +VM_C_API cell to_cell(cell tagged); -VM_ASM_API void overflow_fixnum_add(F_FIXNUM x, F_FIXNUM y); -VM_ASM_API void overflow_fixnum_subtract(F_FIXNUM x, F_FIXNUM y); -VM_ASM_API void overflow_fixnum_multiply(F_FIXNUM x, F_FIXNUM y); +VM_ASM_API void overflow_fixnum_add(fixnum x, fixnum y); +VM_ASM_API void overflow_fixnum_subtract(fixnum x, fixnum y); +VM_ASM_API void overflow_fixnum_multiply(fixnum x, fixnum y); } diff --git a/vm/os-genunix.cpp b/vm/os-genunix.cpp index 53b65b1f7d..1513d6840e 100755 --- a/vm/os-genunix.cpp +++ b/vm/os-genunix.cpp @@ -3,7 +3,7 @@ namespace factor { -void c_to_factor_toplevel(CELL quot) +void c_to_factor_toplevel(cell quot) { c_to_factor(quot); } diff --git a/vm/os-genunix.hpp b/vm/os-genunix.hpp index 91cdba9d2c..bc12f716cf 100644 --- a/vm/os-genunix.hpp +++ b/vm/os-genunix.hpp @@ -4,7 +4,7 @@ namespace factor #define VM_C_API extern "C" #define NULL_DLL NULL -void c_to_factor_toplevel(CELL quot); +void c_to_factor_toplevel(cell quot); void init_signals(void); void early_init(void); const char *vm_executable_path(void); diff --git a/vm/os-linux-arm.cpp b/vm/os-linux-arm.cpp index fe98226369..8e131b9011 100644 --- a/vm/os-linux-arm.cpp +++ b/vm/os-linux-arm.cpp @@ -3,7 +3,7 @@ namespace factor { -void flush_icache(CELL start, CELL len) +void flush_icache(cell start, cell len) { int result; diff --git a/vm/os-linux-arm.hpp b/vm/os-linux-arm.hpp index c767ec858e..70c3eb3ff6 100644 --- a/vm/os-linux-arm.hpp +++ b/vm/os-linux-arm.hpp @@ -14,6 +14,6 @@ inline static void *ucontext_stack_pointer(void *uap) #define UAP_PROGRAM_COUNTER(ucontext) \ (((ucontext_t *)(ucontext))->uc_mcontext.arm_pc) -void flush_icache(CELL start, CELL len); +void flush_icache(cell start, cell len); } diff --git a/vm/os-linux-ppc.hpp b/vm/os-linux-ppc.hpp index da098ddeaf..c0d13e6f17 100644 --- a/vm/os-linux-ppc.hpp +++ b/vm/os-linux-ppc.hpp @@ -3,7 +3,7 @@ namespace factor { -#define FRAME_RETURN_ADDRESS(frame) *((XT *)(frame_successor(frame) + 1) + 1) +#define FRAME_RETURN_ADDRESS(frame) *((void **)(frame_successor(frame) + 1) + 1) inline static void *ucontext_stack_pointer(void *uap) { diff --git a/vm/os-macosx-ppc.hpp b/vm/os-macosx-ppc.hpp index 026b523b16..d80959eaec 100644 --- a/vm/os-macosx-ppc.hpp +++ b/vm/os-macosx-ppc.hpp @@ -13,7 +13,7 @@ Used under BSD license with permission from Paolo Bonzini and Bruno Haible, http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org Modified for Factor by Slava Pestov */ -#define FRAME_RETURN_ADDRESS(frame) *((XT *)(frame_successor(frame) + 1) + 2) +#define FRAME_RETURN_ADDRESS(frame) *((void **)(frame_successor(frame) + 1) + 2) #define MACH_EXC_STATE_TYPE ppc_exception_state_t #define MACH_EXC_STATE_FLAVOR PPC_EXCEPTION_STATE @@ -36,7 +36,7 @@ Modified for Factor by Slava Pestov */ MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss)) #endif -inline static CELL fix_stack_pointer(CELL sp) +inline static cell fix_stack_pointer(cell sp) { return sp; } diff --git a/vm/os-macosx-x86.32.hpp b/vm/os-macosx-x86.32.hpp index 9f781631c2..e6454fd039 100644 --- a/vm/os-macosx-x86.32.hpp +++ b/vm/os-macosx-x86.32.hpp @@ -34,7 +34,7 @@ Modified for Factor by Slava Pestov */ MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss)) #endif -inline static CELL fix_stack_pointer(CELL sp) +inline static cell fix_stack_pointer(cell sp) { return ((sp + 4) & ~15) - 4; } diff --git a/vm/os-macosx-x86.64.hpp b/vm/os-macosx-x86.64.hpp index cd4253bcc8..4d8976991e 100644 --- a/vm/os-macosx-x86.64.hpp +++ b/vm/os-macosx-x86.64.hpp @@ -34,7 +34,7 @@ Modified for Factor by Slava Pestov and Daniel Ehrenberg */ MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss)) #endif -inline static CELL fix_stack_pointer(CELL sp) +inline static cell fix_stack_pointer(cell sp) { return ((sp + 8) & ~15) - 8; } diff --git a/vm/os-macosx.hpp b/vm/os-macosx.hpp index bb54592364..aa166910f5 100644 --- a/vm/os-macosx.hpp +++ b/vm/os-macosx.hpp @@ -17,6 +17,6 @@ inline static void *ucontext_stack_pointer(void *uap) return ucontext->uc_stack.ss_sp; } -void c_to_factor_toplevel(CELL quot); +void c_to_factor_toplevel(cell quot); } diff --git a/vm/os-macosx.mm b/vm/os-macosx.mm index e7c2c1d602..792ba0d541 100644 --- a/vm/os-macosx.mm +++ b/vm/os-macosx.mm @@ -5,7 +5,7 @@ namespace factor { -void c_to_factor_toplevel(CELL quot) +void c_to_factor_toplevel(cell quot) { for(;;) { @@ -13,9 +13,9 @@ NS_DURING c_to_factor(quot); NS_VOIDRETURN; NS_HANDLER - dpush(allot_alien(F,(CELL)localException)); + dpush(allot_alien(F,(cell)localException)); quot = userenv[COCOA_EXCEPTION_ENV]; - if(!tagged(quot).type_p(QUOTATION_TYPE)) + if(!tagged(quot).type_p(QUOTATION_TYPE)) { /* No Cocoa exception handler was registered, so extra/cocoa/ is not loaded. So we pass the exception diff --git a/vm/os-unix.cpp b/vm/os-unix.cpp index 417f79c5ba..c0a268018e 100755 --- a/vm/os-unix.cpp +++ b/vm/os-unix.cpp @@ -26,7 +26,7 @@ s64 current_micros(void) return (s64)t.tv_sec * 1000000 + t.tv_usec; } -void sleep_micros(CELL usec) +void sleep_micros(cell usec) { usleep(usec); } @@ -37,18 +37,18 @@ void init_ffi(void) null_dll = dlopen(NULL_DLL,RTLD_LAZY); } -void ffi_dlopen(F_DLL *dll) +void ffi_dlopen(dll *dll) { dll->dll = dlopen(alien_offset(dll->path), RTLD_LAZY); } -void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol) +void *ffi_dlsym(dll *dll, symbol_char *symbol) { void *handle = (dll == NULL ? null_dll : dll->dll); return dlsym(handle,symbol); } -void ffi_dlclose(F_DLL *dll) +void ffi_dlclose(dll *dll) { if(dlclose(dll->dll)) general_error(ERROR_FFI,F,F,NULL); @@ -58,11 +58,11 @@ void ffi_dlclose(F_DLL *dll) PRIMITIVE(existsp) { struct stat sb; - char *path = (char *)(untag_check(dpop()) + 1); + char *path = (char *)(untag_check(dpop()) + 1); box_boolean(stat(path,&sb) >= 0); } -F_SEGMENT *alloc_segment(CELL size) +segment *alloc_segment(cell size) { int pagesize = getpagesize(); @@ -74,21 +74,21 @@ F_SEGMENT *alloc_segment(CELL size) out_of_memory(); if(mprotect(array,pagesize,PROT_NONE) == -1) - fatal_error("Cannot protect low guard page",(CELL)array); + 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); + fatal_error("Cannot protect high guard page",(cell)array); - F_SEGMENT *retval = (F_SEGMENT *)safe_malloc(sizeof(F_SEGMENT)); + segment *retval = (segment *)safe_malloc(sizeof(segment)); - retval->start = (CELL)(array + pagesize); + retval->start = (cell)(array + pagesize); retval->size = size; retval->end = retval->start + size; return retval; } -void dealloc_segment(F_SEGMENT *block) +void dealloc_segment(segment *block) { int pagesize = getpagesize(); @@ -101,7 +101,7 @@ void dealloc_segment(F_SEGMENT *block) free(block); } -static F_STACK_FRAME *uap_stack_pointer(void *uap) +static stack_frame *uap_stack_pointer(void *uap) { /* There is a race condition here, but in practice a signal delivered during stack frame setup/teardown or while transitioning @@ -109,9 +109,9 @@ static F_STACK_FRAME *uap_stack_pointer(void *uap) a divide by zero or stack underflow in the listener */ if(in_code_heap_p(UAP_PROGRAM_COUNTER(uap))) { - F_STACK_FRAME *ptr = (F_STACK_FRAME *)ucontext_stack_pointer(uap); + stack_frame *ptr = (stack_frame *)ucontext_stack_pointer(uap); if(!ptr) - critical_error("Invalid uap",(CELL)uap); + critical_error("Invalid uap",(cell)uap); return ptr; } else @@ -120,16 +120,16 @@ static F_STACK_FRAME *uap_stack_pointer(void *uap) void memory_signal_handler(int signal, siginfo_t *siginfo, void *uap) { - signal_fault_addr = (CELL)siginfo->si_addr; + signal_fault_addr = (cell)siginfo->si_addr; signal_callstack_top = uap_stack_pointer(uap); - UAP_PROGRAM_COUNTER(uap) = (CELL)memory_signal_handler_impl; + UAP_PROGRAM_COUNTER(uap) = (cell)memory_signal_handler_impl; } void misc_signal_handler(int signal, siginfo_t *siginfo, void *uap) { signal_number = signal; signal_callstack_top = uap_stack_pointer(uap); - UAP_PROGRAM_COUNTER(uap) = (CELL)misc_signal_handler_impl; + UAP_PROGRAM_COUNTER(uap) = (cell)misc_signal_handler_impl; } static void sigaction_safe(int signum, const struct sigaction *act, struct sigaction *oldact) diff --git a/vm/os-unix.hpp b/vm/os-unix.hpp index cb0afc4e61..24e8016db4 100755 --- a/vm/os-unix.hpp +++ b/vm/os-unix.hpp @@ -11,8 +11,8 @@ namespace factor { -typedef char F_CHAR; -typedef char F_SYMBOL; +typedef char vm_char; +typedef char symbol_char; #define STRING_LITERAL(string) string @@ -24,13 +24,13 @@ typedef char F_SYMBOL; #define FSEEK fseeko #define FIXNUM_FORMAT "%ld" -#define CELL_FORMAT "%lu" -#define CELL_HEX_FORMAT "%lx" +#define cell_FORMAT "%lu" +#define cell_HEX_FORMAT "%lx" #ifdef FACTOR_64 - #define CELL_HEX_PAD_FORMAT "%016lx" + #define cell_HEX_PAD_FORMAT "%016lx" #else - #define CELL_HEX_PAD_FORMAT "%08lx" + #define cell_HEX_PAD_FORMAT "%08lx" #endif #define FIXNUM_FORMAT "%ld" @@ -43,16 +43,16 @@ typedef char F_SYMBOL; void start_thread(void *(*start_routine)(void *)); void init_ffi(void); -void ffi_dlopen(F_DLL *dll); -void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol); -void ffi_dlclose(F_DLL *dll); +void ffi_dlopen(dll *dll); +void *ffi_dlsym(dll *dll, symbol_char *symbol); +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); s64 current_micros(void); -void sleep_micros(CELL usec); +void sleep_micros(cell usec); void open_console(void); diff --git a/vm/os-windows-ce.cpp b/vm/os-windows-ce.cpp index af127016de..71c72e55f8 100755 --- a/vm/os-windows-ce.cpp +++ b/vm/os-windows-ce.cpp @@ -19,7 +19,7 @@ char *strerror(int err) return "strerror() is not defined on WinCE. Use native I/O."; } -void flush_icache(CELL start, CELL end) +void flush_icache(cell start, cell end) { FlushInstructionCache(GetCurrentProcess(), 0, 0); } @@ -35,7 +35,7 @@ PRIMITIVE(os_envs) not_implemented_error(); } -void c_to_factor_toplevel(CELL quot) +void c_to_factor_toplevel(cell quot) { c_to_factor(quot); } diff --git a/vm/os-windows-ce.hpp b/vm/os-windows-ce.hpp index 49b6d73077..49450f91c7 100755 --- a/vm/os-windows-ce.hpp +++ b/vm/os-windows-ce.hpp @@ -8,7 +8,7 @@ namespace factor { -typedef wchar_t F_SYMBOL; +typedef wchar_t symbol_char; #define FACTOR_OS_STRING "wince" #define FACTOR_DLL L"factor-ce.dll" @@ -16,14 +16,14 @@ typedef wchar_t F_SYMBOL; int errno; char *strerror(int err); -void flush_icache(CELL start, CELL end); +void flush_icache(cell start, cell end); char *getenv(char *name); #define snprintf _snprintf #define snwprintf _snwprintf s64 current_micros(void); -void c_to_factor_toplevel(CELL quot); +void c_to_factor_toplevel(cell quot); void open_console(void); } diff --git a/vm/os-windows-nt.cpp b/vm/os-windows-nt.cpp index d148a32df6..0a63dce513 100755 --- a/vm/os-windows-nt.cpp +++ b/vm/os-windows-nt.cpp @@ -24,7 +24,7 @@ long exception_handler(PEXCEPTION_POINTERS pe) if(e->ExceptionCode == EXCEPTION_ACCESS_VIOLATION) { signal_fault_addr = e->ExceptionInformation[1]; - c->EIP = (CELL)memory_signal_handler_impl; + c->EIP = (cell)memory_signal_handler_impl; } /* If the Widcomm bluetooth stack is installed, the BTTray.exe process injects code into running programs. For some reason this results in @@ -35,13 +35,13 @@ long exception_handler(PEXCEPTION_POINTERS pe) else if(e->ExceptionCode != 0x40010006) { signal_number = e->ExceptionCode; - c->EIP = (CELL)misc_signal_handler_impl; + c->EIP = (cell)misc_signal_handler_impl; } return EXCEPTION_CONTINUE_EXECUTION; } -void c_to_factor_toplevel(CELL quot) +void c_to_factor_toplevel(cell quot) { if(!AddVectoredExceptionHandler(0, (void*)exception_handler)) fatal_error("AddVectoredExceptionHandler failed", 0); diff --git a/vm/os-windows-nt.hpp b/vm/os-windows-nt.hpp index e55d6ee97c..107e42ea2e 100755 --- a/vm/os-windows-nt.hpp +++ b/vm/os-windows-nt.hpp @@ -11,13 +11,13 @@ namespace factor { -typedef char F_SYMBOL; +typedef char symbol_char; #define FACTOR_OS_STRING "winnt" #define FACTOR_DLL L"factor.dll" #define FACTOR_DLL_NAME "factor.dll" -void c_to_factor_toplevel(CELL quot); +void c_to_factor_toplevel(cell quot); long exception_handler(PEXCEPTION_POINTERS pe); void open_console(void); diff --git a/vm/os-windows.cpp b/vm/os-windows.cpp index 24b49ff61b..796a1c7184 100755 --- a/vm/os-windows.cpp +++ b/vm/os-windows.cpp @@ -12,23 +12,23 @@ void init_ffi(void) fatal_error("GetModuleHandle(\"" FACTOR_DLL_NAME "\") failed", 0); } -void ffi_dlopen(F_DLL *dll) +void ffi_dlopen(dll *dll) { dll->dll = LoadLibraryEx(alien_offset(dll->path), NULL, 0); } -void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol) +void *ffi_dlsym(dll *dll, symbol_char *symbol) { return GetProcAddress(dll ? (HMODULE)dll->dll : hFactorDll, symbol); } -void ffi_dlclose(F_DLL *dll) +void ffi_dlclose(dll *dll) { FreeLibrary((HMODULE)dll->dll); dll->dll = NULL; } -bool windows_stat(F_CHAR *path) +bool windows_stat(vm_char *path) { BY_HANDLE_FILE_INFORMATION bhfi; HANDLE h = CreateFileW(path, @@ -56,18 +56,18 @@ bool windows_stat(F_CHAR *path) return ret; } -void windows_image_path(F_CHAR *full_path, F_CHAR *temp_path, unsigned int length) +void windows_image_path(vm_char *full_path, vm_char *temp_path, unsigned int length) { snwprintf(temp_path, length-1, L"%s.image", full_path); temp_path[sizeof(temp_path) - 1] = 0; } /* You must free() this yourself. */ -const F_CHAR *default_image_path(void) +const vm_char *default_image_path(void) { - F_CHAR full_path[MAX_UNICODE_PATH]; - F_CHAR *ptr; - F_CHAR temp_path[MAX_UNICODE_PATH]; + vm_char full_path[MAX_UNICODE_PATH]; + vm_char *ptr; + vm_char temp_path[MAX_UNICODE_PATH]; if(!GetModuleFileName(NULL, full_path, MAX_UNICODE_PATH)) fatal_error("GetModuleFileName() failed", 0); @@ -82,9 +82,9 @@ const F_CHAR *default_image_path(void) } /* You must free() this yourself. */ -const F_CHAR *vm_executable_path(void) +const vm_char *vm_executable_path(void) { - F_CHAR full_path[MAX_UNICODE_PATH]; + vm_char full_path[MAX_UNICODE_PATH]; if(!GetModuleFileName(NULL, full_path, MAX_UNICODE_PATH)) fatal_error("GetModuleFileName() failed", 0); return safe_strdup(full_path); @@ -93,11 +93,11 @@ const F_CHAR *vm_executable_path(void) PRIMITIVE(existsp) { - F_CHAR *path = (F_CHAR *)(untag_check(dpop()) + 1); + vm_char *path = (vm_char *)(untag_check(dpop()) + 1); box_boolean(windows_stat(path)); } -F_SEGMENT *alloc_segment(CELL size) +segment *alloc_segment(cell size) { char *mem; DWORD ignore; @@ -107,22 +107,22 @@ F_SEGMENT *alloc_segment(CELL size) out_of_memory(); if (!VirtualProtect(mem, getpagesize(), PAGE_NOACCESS, &ignore)) - fatal_error("Cannot allocate low guard page", (CELL)mem); + fatal_error("Cannot allocate low guard page", (cell)mem); if (!VirtualProtect(mem + size + getpagesize(), getpagesize(), PAGE_NOACCESS, &ignore)) - fatal_error("Cannot allocate high guard page", (CELL)mem); + fatal_error("Cannot allocate high guard page", (cell)mem); - F_SEGMENT *block = safe_malloc(sizeof(F_SEGMENT)); + segment *block = safe_malloc(sizeof(segment)); - block->start = (CELL)mem + getpagesize(); + block->start = (cell)mem + getpagesize(); block->size = size; block->end = block->start + size; return block; } -void dealloc_segment(F_SEGMENT *block) +void dealloc_segment(segment *block) { SYSTEM_INFO si; GetSystemInfo(&si); diff --git a/vm/os-windows.hpp b/vm/os-windows.hpp index db83688b13..2926ea50a8 100755 --- a/vm/os-windows.hpp +++ b/vm/os-windows.hpp @@ -8,7 +8,7 @@ namespace factor { -typedef wchar_t F_CHAR; +typedef wchar_t vm_char; #define STRING_LITERAL(string) L##string @@ -22,14 +22,14 @@ typedef wchar_t F_CHAR; #define FSEEK fseek #ifdef WIN64 - #define CELL_FORMAT "%Iu" - #define CELL_HEX_FORMAT "%Ix" - #define CELL_HEX_PAD_FORMAT "%016Ix" + #define cell_FORMAT "%Iu" + #define cell_HEX_FORMAT "%Ix" + #define cell_HEX_PAD_FORMAT "%016Ix" #define FIXNUM_FORMAT "%Id" #else - #define CELL_FORMAT "%lu" - #define CELL_HEX_FORMAT "%lx" - #define CELL_HEX_PAD_FORMAT "%08lx" + #define cell_FORMAT "%lu" + #define cell_HEX_FORMAT "%lx" + #define cell_HEX_PAD_FORMAT "%08lx" #define FIXNUM_FORMAT "%ld" #endif @@ -42,16 +42,16 @@ typedef wchar_t F_CHAR; #define EPOCH_OFFSET 0x019db1ded53e8000LL void init_ffi(void); -void ffi_dlopen(F_DLL *dll); -void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol); -void ffi_dlclose(F_DLL *dll); +void ffi_dlopen(dll *dll); +void *ffi_dlsym(dll *dll, symbol_char *symbol); +void ffi_dlclose(dll *dll); void sleep_micros(u64 msec); inline static void init_signals(void) {} inline static void early_init(void) {} -const F_CHAR *vm_executable_path(void); -const F_CHAR *default_image_path(void); +const vm_char *vm_executable_path(void); +const vm_char *default_image_path(void); long getpagesize (void); s64 current_micros(void); diff --git a/vm/primitives.hpp b/vm/primitives.hpp index b26638274b..f53fcff17f 100644 --- a/vm/primitives.hpp +++ b/vm/primitives.hpp @@ -1,8 +1,6 @@ namespace factor { -//typedef extern "C" void (*F_PRIMITIVE)(void); - extern void *primitives[]; #define PRIMITIVE(name) extern "C" void primitive_##name() diff --git a/vm/profiler.cpp b/vm/profiler.cpp index 7a832e6219..9651e4a27e 100755 --- a/vm/profiler.cpp +++ b/vm/profiler.cpp @@ -11,14 +11,14 @@ void init_profiler(void) } /* Allocates memory */ -F_CODE_BLOCK *compile_profiling_stub(CELL word_) +code_block *compile_profiling_stub(cell word_) { - gc_root word(word_); + gc_root word(word_); jit jit(WORD_TYPE,word.value()); jit.emit_with(userenv[JIT_PROFILING],word.value()); - return jit.code_block(); + return jit.to_code_block(); } /* Allocates memory */ @@ -33,13 +33,13 @@ static void set_profiling(bool profiling) and allocate profiling blocks if necessary */ gc(); - gc_root words(find_all_words()); + gc_root words(find_all_words()); - CELL i; - CELL length = array_capacity(words.untagged()); + cell i; + cell length = array_capacity(words.untagged()); for(i = 0; i < length; i++) { - tagged word(array_nth(words.untagged(),i)); + tagged word(array_nth(words.untagged(),i)); if(profiling) word->counter = tag_fixnum(0); update_word_xt(word.value()); diff --git a/vm/profiler.hpp b/vm/profiler.hpp index 60f83721b2..00f3e8067b 100755 --- a/vm/profiler.hpp +++ b/vm/profiler.hpp @@ -3,7 +3,7 @@ namespace factor extern bool profiling_p; void init_profiler(void); -F_CODE_BLOCK *compile_profiling_stub(CELL word); +code_block *compile_profiling_stub(cell word); PRIMITIVE(profiling); } diff --git a/vm/quotations.cpp b/vm/quotations.cpp index d0d995cd65..2b9a37a6f7 100755 --- a/vm/quotations.cpp +++ b/vm/quotations.cpp @@ -36,63 +36,63 @@ includes stack shufflers, some fixnum arithmetic words, and words such as tag, slot and eq?. A primitive call is relatively expensive (two subroutine calls) so this results in a big speedup for relatively little effort. */ -bool quotation_jit::primitive_call_p(CELL i) +bool quotation_jit::primitive_call_p(cell i) { - return (i + 2) == array_capacity(array.untagged()) - && tagged(array_nth(array.untagged(),i)).type_p(FIXNUM_TYPE) - && array_nth(array.untagged(),i + 1) == userenv[JIT_PRIMITIVE_WORD]; + return (i + 2) == array_capacity(elements.untagged()) + && tagged(array_nth(elements.untagged(),i)).type_p(FIXNUM_TYPE) + && array_nth(elements.untagged(),i + 1) == userenv[JIT_PRIMITIVE_WORD]; } -bool quotation_jit::fast_if_p(CELL i) +bool quotation_jit::fast_if_p(cell i) { - return (i + 3) == array_capacity(array.untagged()) - && tagged(array_nth(array.untagged(),i)).type_p(QUOTATION_TYPE) - && tagged(array_nth(array.untagged(),i + 1)).type_p(QUOTATION_TYPE) - && array_nth(array.untagged(),i + 2) == userenv[JIT_IF_WORD]; + return (i + 3) == array_capacity(elements.untagged()) + && tagged(array_nth(elements.untagged(),i)).type_p(QUOTATION_TYPE) + && tagged(array_nth(elements.untagged(),i + 1)).type_p(QUOTATION_TYPE) + && array_nth(elements.untagged(),i + 2) == userenv[JIT_IF_WORD]; } -bool quotation_jit::fast_dip_p(CELL i) +bool quotation_jit::fast_dip_p(cell i) { - return (i + 2) <= array_capacity(array.untagged()) - && tagged(array_nth(array.untagged(),i)).type_p(QUOTATION_TYPE) - && array_nth(array.untagged(),i + 1) == userenv[JIT_DIP_WORD]; + return (i + 2) <= array_capacity(elements.untagged()) + && tagged(array_nth(elements.untagged(),i)).type_p(QUOTATION_TYPE) + && array_nth(elements.untagged(),i + 1) == userenv[JIT_DIP_WORD]; } -bool quotation_jit::fast_2dip_p(CELL i) +bool quotation_jit::fast_2dip_p(cell i) { - return (i + 2) <= array_capacity(array.untagged()) - && tagged(array_nth(array.untagged(),i)).type_p(QUOTATION_TYPE) - && array_nth(array.untagged(),i + 1) == userenv[JIT_2DIP_WORD]; + return (i + 2) <= array_capacity(elements.untagged()) + && tagged(array_nth(elements.untagged(),i)).type_p(QUOTATION_TYPE) + && array_nth(elements.untagged(),i + 1) == userenv[JIT_2DIP_WORD]; } -bool quotation_jit::fast_3dip_p(CELL i) +bool quotation_jit::fast_3dip_p(cell i) { - return (i + 2) <= array_capacity(array.untagged()) - && tagged(array_nth(array.untagged(),i)).type_p(QUOTATION_TYPE) - && array_nth(array.untagged(),i + 1) == userenv[JIT_3DIP_WORD]; + return (i + 2) <= array_capacity(elements.untagged()) + && tagged(array_nth(elements.untagged(),i)).type_p(QUOTATION_TYPE) + && array_nth(elements.untagged(),i + 1) == userenv[JIT_3DIP_WORD]; } -bool quotation_jit::mega_lookup_p(CELL i) +bool quotation_jit::mega_lookup_p(cell i) { - return (i + 3) < array_capacity(array.untagged()) - && tagged(array_nth(array.untagged(),i)).type_p(ARRAY_TYPE) - && tagged(array_nth(array.untagged(),i + 1)).type_p(FIXNUM_TYPE) - && tagged(array_nth(array.untagged(),i + 2)).type_p(ARRAY_TYPE) - && array_nth(array.untagged(),i + 3) == userenv[MEGA_LOOKUP_WORD]; + return (i + 3) < array_capacity(elements.untagged()) + && tagged(array_nth(elements.untagged(),i)).type_p(ARRAY_TYPE) + && tagged(array_nth(elements.untagged(),i + 1)).type_p(FIXNUM_TYPE) + && tagged(array_nth(elements.untagged(),i + 2)).type_p(ARRAY_TYPE) + && array_nth(elements.untagged(),i + 3) == userenv[MEGA_LOOKUP_WORD]; } bool quotation_jit::stack_frame_p() { - F_FIXNUM length = array_capacity(array.untagged()); - F_FIXNUM i; + fixnum length = array_capacity(elements.untagged()); + fixnum i; for(i = 0; i < length - 1; i++) { - CELL obj = array_nth(array.untagged(),i); - switch(tagged(obj).type()) + cell obj = array_nth(elements.untagged(),i); + switch(tagged(obj).type()) { case WORD_TYPE: - if(untag(obj)->subprimitive == F) + if(untag(obj)->subprimitive == F) return true; break; case QUOTATION_TYPE: @@ -117,21 +117,21 @@ void quotation_jit::iterate_quotation() if(stack_frame) emit(userenv[JIT_PROLOG]); - CELL i; - CELL length = array_capacity(array.untagged()); + cell i; + cell length = array_capacity(elements.untagged()); bool tail_call = false; for(i = 0; i < length; i++) { set_position(i); - gc_root obj(array_nth(array.untagged(),i)); + gc_root obj(array_nth(elements.untagged(),i)); switch(obj.type()) { case WORD_TYPE: /* Intrinsics */ - if(obj.as()->subprimitive != F) + if(obj.as()->subprimitive != F) emit_subprimitive(obj.value()); /* The (execute) primitive is special-cased */ else if(obj.value() == userenv[JIT_EXECUTE_WORD]) @@ -159,7 +159,7 @@ void quotation_jit::iterate_quotation() } break; case WRAPPER_TYPE: - push(obj.as()->object); + push(obj.as()->object); break; case FIXNUM_TYPE: /* Primitive calls */ @@ -183,12 +183,12 @@ void quotation_jit::iterate_quotation() if(compiling) { - jit_compile(array_nth(array.untagged(),i),relocate); - jit_compile(array_nth(array.untagged(),i + 1),relocate); + jit_compile(array_nth(elements.untagged(),i),relocate); + jit_compile(array_nth(elements.untagged(),i + 1),relocate); } - emit_with(userenv[JIT_IF_1],array_nth(array.untagged(),i)); - emit_with(userenv[JIT_IF_2],array_nth(array.untagged(),i + 1)); + emit_with(userenv[JIT_IF_1],array_nth(elements.untagged(),i)); + emit_with(userenv[JIT_IF_2],array_nth(elements.untagged(),i + 1)); i += 2; @@ -226,9 +226,9 @@ void quotation_jit::iterate_quotation() if(mega_lookup_p(i)) { emit_mega_cache_lookup( - array_nth(array.untagged(),i), - untag_fixnum(array_nth(array.untagged(),i + 1)), - array_nth(array.untagged(),i + 2)); + array_nth(elements.untagged(),i), + untag_fixnum(array_nth(elements.untagged(),i + 1)), + array_nth(elements.untagged(),i + 2)); i += 3; tail_call = true; break; @@ -249,26 +249,26 @@ void quotation_jit::iterate_quotation() } } -void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code) +void set_quot_xt(quotation *quot, code_block *code) { if(code->block.type != QUOTATION_TYPE) - critical_error("Bad param to set_quot_xt",(CELL)code); + critical_error("Bad param to set_quot_xt",(cell)code); quot->code = code; - quot->xt = (XT)(code + 1); + quot->xt = code->xt(); quot->compiledp = T; } /* Allocates memory */ -void jit_compile(CELL quot_, bool relocating) +void jit_compile(cell quot_, bool relocating) { - gc_root quot(quot_); + gc_root quot(quot_); if(quot->compiledp != F) return; - quotation_jit jit(quot.value(),true,relocating); - jit.iterate_quotation(); + quotation_jit compiler(quot.value(),true,relocating); + compiler.iterate_quotation(); - F_CODE_BLOCK *compiled = jit.code_block(); + code_block *compiled = compiler.to_code_block(); set_quot_xt(quot.untagged(),compiled); if(relocating) relocate_code_block(compiled); @@ -282,30 +282,30 @@ PRIMITIVE(jit_compile) /* push a new quotation on the stack */ PRIMITIVE(array_to_quotation) { - F_QUOTATION *quot = allot(sizeof(F_QUOTATION)); + quotation *quot = allot(sizeof(quotation)); quot->array = dpeek(); quot->xt = (void *)lazy_jit_compile; quot->compiledp = F; quot->cached_effect = F; quot->cache_counter = F; - drepl(tag(quot)); + drepl(tag(quot)); } PRIMITIVE(quotation_xt) { - F_QUOTATION *quot = untag_check(dpeek()); - drepl(allot_cell((CELL)quot->xt)); + quotation *quot = untag_check(dpeek()); + drepl(allot_cell((cell)quot->xt)); } void compile_all_words(void) { - gc_root words(find_all_words()); + gc_root words(find_all_words()); - CELL i; - CELL length = array_capacity(words.untagged()); + cell i; + cell length = array_capacity(words.untagged()); for(i = 0; i < length; i++) { - gc_root word(array_nth(words.untagged(),i)); + gc_root word(array_nth(words.untagged(),i)); if(!word->code || !word_optimized_p(word.untagged())) jit_compile_word(word.value(),word->def,false); @@ -318,10 +318,10 @@ void compile_all_words(void) } /* Allocates memory */ -F_FIXNUM quot_code_offset_to_scan(CELL quot_, CELL offset) +fixnum quot_code_offset_to_scan(cell quot_, cell offset) { - gc_root quot(quot_); - gc_root array(quot->array); + gc_root quot(quot_); + gc_root array(quot->array); quotation_jit jit(quot.value(),false,false); jit.compute_position(offset); @@ -330,9 +330,9 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot_, CELL offset) return jit.get_position(); } -VM_ASM_API CELL lazy_jit_compile_impl(CELL quot_, F_STACK_FRAME *stack) +VM_ASM_API cell lazy_jit_compile_impl(cell quot_, stack_frame *stack) { - gc_root quot(quot_); + gc_root quot(quot_); stack_chain->callstack_top = stack; jit_compile(quot.value(),true); return quot.value(); diff --git a/vm/quotations.hpp b/vm/quotations.hpp index 6472cb1329..a4545f3956 100755 --- a/vm/quotations.hpp +++ b/vm/quotations.hpp @@ -2,29 +2,29 @@ namespace factor { struct quotation_jit : public jit { - gc_root array; + gc_root elements; bool compiling, relocate; - quotation_jit(CELL quot, bool compiling_, bool relocate_) + quotation_jit(cell quot, bool compiling_, bool relocate_) : jit(QUOTATION_TYPE,quot), - array(owner.as().untagged()->array), + elements(owner.as().untagged()->array), compiling(compiling_), relocate(relocate_) {}; - void emit_mega_cache_lookup(CELL methods, F_FIXNUM index, CELL cache); - bool primitive_call_p(CELL i); - bool fast_if_p(CELL i); - bool fast_dip_p(CELL i); - bool fast_2dip_p(CELL i); - bool fast_3dip_p(CELL i); - bool mega_lookup_p(CELL i); + void emit_mega_cache_lookup(cell methods, fixnum index, cell cache); + bool primitive_call_p(cell i); + bool fast_if_p(cell i); + bool fast_dip_p(cell i); + bool fast_2dip_p(cell i); + bool fast_3dip_p(cell i); + bool mega_lookup_p(cell i); bool stack_frame_p(); void iterate_quotation(); }; -void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code); -void jit_compile(CELL quot, bool relocate); -F_FIXNUM quot_code_offset_to_scan(CELL quot, CELL offset); +void set_quot_xt(quotation *quot, code_block *code); +void jit_compile(cell quot, bool relocate); +fixnum quot_code_offset_to_scan(cell quot, cell offset); PRIMITIVE(jit_compile); @@ -33,6 +33,6 @@ void compile_all_words(void); PRIMITIVE(array_to_quotation); PRIMITIVE(quotation_xt); -VM_ASM_API CELL lazy_jit_compile_impl(CELL quot, F_STACK_FRAME *stack); +VM_ASM_API cell lazy_jit_compile_impl(cell quot, stack_frame *stack); } diff --git a/vm/run.cpp b/vm/run.cpp index b10fd0e96b..c6a4bad695 100755 --- a/vm/run.cpp +++ b/vm/run.cpp @@ -1,22 +1,22 @@ #include "master.hpp" -factor::CELL userenv[USER_ENV]; +factor::cell userenv[USER_ENV]; namespace factor { -CELL T; +cell T; PRIMITIVE(getenv) { - F_FIXNUM e = untag_fixnum(dpeek()); + fixnum e = untag_fixnum(dpeek()); drepl(userenv[e]); } PRIMITIVE(setenv) { - F_FIXNUM e = untag_fixnum(dpop()); - CELL value = dpop(); + fixnum e = untag_fixnum(dpop()); + cell value = dpop(); userenv[e] = value; } @@ -37,33 +37,33 @@ PRIMITIVE(sleep) PRIMITIVE(set_slot) { - F_FIXNUM slot = untag_fixnum(dpop()); - F_OBJECT *object = untag(dpop()); - CELL value = dpop(); + fixnum slot = untag_fixnum(dpop()); + object *obj = untag(dpop()); + cell value = dpop(); - object->slots()[slot] = value; - write_barrier(object); + obj->slots()[slot] = value; + write_barrier(obj); } PRIMITIVE(load_locals) { - F_FIXNUM count = untag_fixnum(dpop()); - memcpy((CELL *)(rs + CELLS),(CELL *)(ds - CELLS * (count - 1)),CELLS * count); - ds -= CELLS * count; - rs += CELLS * count; + fixnum count = untag_fixnum(dpop()); + memcpy((cell *)(rs + sizeof(cell)),(cell *)(ds - sizeof(cell) * (count - 1)),sizeof(cell) * count); + ds -= sizeof(cell) * count; + rs += sizeof(cell) * count; } -static CELL clone_object(CELL object_) +static cell clone_object(cell obj_) { - gc_root object(object_); + gc_root obj(obj_); - if(immediate_p(object.value())) - return object.value(); + if(immediate_p(obj.value())) + return obj.value(); else { - CELL size = object_size(object.value()); - F_OBJECT *new_obj = allot_object(object.type(),size); - memcpy(new_obj,object.untagged(),size); + cell size = object_size(obj.value()); + object *new_obj = allot_object(obj.type(),size); + memcpy(new_obj,obj.untagged(),size); return tag_dynamic(new_obj); } } diff --git a/vm/run.hpp b/vm/run.hpp index 48c3f9f6c2..2204585fe5 100755 --- a/vm/run.hpp +++ b/vm/run.hpp @@ -3,7 +3,7 @@ namespace factor #define USER_ENV 70 -typedef enum { +enum special_object { NAMESTACK_ENV, /* used by library only */ CATCHSTACK_ENV, /* used by library only, per-callback */ @@ -14,7 +14,7 @@ typedef enum { BREAK_ENV = 5, /* quotation called by throw primitive */ ERROR_ENV, /* a marker consed onto kernel errors */ - CELL_SIZE_ENV = 7, /* sizeof(CELL) */ + cell_SIZE_ENV = 7, /* sizeof(cell) */ CPU_ENV, /* CPU architecture */ OS_ENV, /* operating system name */ @@ -88,13 +88,13 @@ typedef enum { SLEEP_QUEUE_ENV = 66, STACK_TRACES_ENV = 67, -} F_ENVTYPE; +}; #define FIRST_SAVE_ENV BOOT_ENV #define LAST_SAVE_ENV STAGE2_ENV /* Canonical T object. It's just a word */ -extern CELL T; +extern cell T; PRIMITIVE(getenv); PRIMITIVE(setenv); @@ -108,4 +108,4 @@ PRIMITIVE(clone); } /* TAGGED user environment data; see getenv/setenv prims */ -VM_C_API factor::CELL userenv[USER_ENV]; +VM_C_API factor::cell userenv[USER_ENV]; diff --git a/vm/segments.hpp b/vm/segments.hpp index 6e8ea3f491..a715b4dabc 100644 --- a/vm/segments.hpp +++ b/vm/segments.hpp @@ -1,10 +1,10 @@ namespace factor { -struct F_SEGMENT { - CELL start; - CELL size; - CELL end; +struct segment { + cell start; + cell size; + cell end; }; } diff --git a/vm/stacks.hpp b/vm/stacks.hpp index 3a4e88cb9d..4af31e17d9 100644 --- a/vm/stacks.hpp +++ b/vm/stacks.hpp @@ -2,17 +2,17 @@ namespace factor { #define DEFPUSHPOP(prefix,ptr) \ - inline static CELL prefix##peek() { return *(CELL *)ptr; } \ - inline static void prefix##repl(CELL tagged) { *(CELL *)ptr = tagged; } \ - inline static CELL prefix##pop(void) \ + inline static cell prefix##peek() { return *(cell *)ptr; } \ + inline static void prefix##repl(cell tagged) { *(cell *)ptr = tagged; } \ + inline static cell prefix##pop(void) \ { \ - CELL value = prefix##peek(); \ - ptr -= CELLS; \ + cell value = prefix##peek(); \ + ptr -= sizeof(cell); \ return value; \ } \ - inline static void prefix##push(CELL tagged) \ + inline static void prefix##push(cell tagged) \ { \ - ptr += CELLS; \ + ptr += sizeof(cell); \ prefix##repl(tagged); \ } diff --git a/vm/strings.cpp b/vm/strings.cpp index a6905aad25..c00c17bc45 100644 --- a/vm/strings.cpp +++ b/vm/strings.cpp @@ -3,39 +3,39 @@ namespace factor { -CELL string_nth(F_STRING* string, CELL index) +cell string_nth(string* str, cell index) { /* If high bit is set, the most significant 16 bits of the char come from the aux vector. The least significant bit of the corresponding aux vector entry is negated, so that we can XOR the two components together and get the original code point back. */ - CELL lo_bits = string->data()[index]; + cell lo_bits = str->data()[index]; if((lo_bits & 0x80) == 0) return lo_bits; else { - F_BYTE_ARRAY *aux = untag(string->aux); - CELL hi_bits = aux->data()[index]; + byte_array *aux = untag(str->aux); + cell hi_bits = aux->data()[index]; return (hi_bits << 7) ^ lo_bits; } } -void set_string_nth_fast(F_STRING *string, CELL index, CELL ch) +void set_string_nth_fast(string *str, cell index, cell ch) { - string->data()[index] = ch; + str->data()[index] = ch; } -void set_string_nth_slow(F_STRING *string_, CELL index, CELL ch) +void set_string_nth_slow(string *str_, cell index, cell ch) { - gc_root string(string_); + gc_root str(str_); - F_BYTE_ARRAY *aux; + byte_array *aux; - string->data()[index] = ((ch & 0x7f) | 0x80); + str->data()[index] = ((ch & 0x7f) | 0x80); - if(string->aux == F) + if(str->aux == F) { /* We don't need to pre-initialize the byte array with any data, since we @@ -43,146 +43,144 @@ void set_string_nth_slow(F_STRING *string_, CELL index, CELL ch) if the most significant bit of a character is set. Initially all of the bits are clear. */ - aux = allot_array_internal( - untag_fixnum(string->length) - * sizeof(u16)); + aux = allot_array_internal(untag_fixnum(str->length) * sizeof(u16)); - write_barrier(string.untagged()); - string->aux = tag(aux); + write_barrier(str.untagged()); + str->aux = tag(aux); } else - aux = untag(string->aux); + aux = untag(str->aux); aux->data()[index] = ((ch >> 7) ^ 1); } /* allocates memory */ -void set_string_nth(F_STRING* string, CELL index, CELL ch) +void set_string_nth(string *str, cell index, cell ch) { if(ch <= 0x7f) - set_string_nth_fast(string,index,ch); + set_string_nth_fast(str,index,ch); else - set_string_nth_slow(string,index,ch); + set_string_nth_slow(str,index,ch); } /* Allocates memory */ -F_STRING *allot_string_internal(CELL capacity) +string *allot_string_internal(cell capacity) { - F_STRING *string = allot(string_size(capacity)); + string *str = allot(string_size(capacity)); - string->length = tag_fixnum(capacity); - string->hashcode = F; - string->aux = F; + str->length = tag_fixnum(capacity); + str->hashcode = F; + str->aux = F; - return string; + return str; } /* Allocates memory */ -void fill_string(F_STRING *string_, CELL start, CELL capacity, CELL fill) +void fill_string(string *str_, cell start, cell capacity, cell fill) { - gc_root string(string_); + gc_root str(str_); if(fill <= 0x7f) - memset(&string->data()[start],fill,capacity - start); + memset(&str->data()[start],fill,capacity - start); else { - CELL i; + cell i; for(i = start; i < capacity; i++) - set_string_nth(string.untagged(),i,fill); + set_string_nth(str.untagged(),i,fill); } } /* Allocates memory */ -F_STRING *allot_string(CELL capacity, CELL fill) +string *allot_string(cell capacity, cell fill) { - gc_root string(allot_string_internal(capacity)); - fill_string(string.untagged(),0,capacity,fill); - return string.untagged(); + gc_root str(allot_string_internal(capacity)); + fill_string(str.untagged(),0,capacity,fill); + return str.untagged(); } PRIMITIVE(string) { - CELL initial = to_cell(dpop()); - CELL length = unbox_array_size(); - dpush(tag(allot_string(length,initial))); + cell initial = to_cell(dpop()); + cell length = unbox_array_size(); + dpush(tag(allot_string(length,initial))); } -static bool reallot_string_in_place_p(F_STRING *string, CELL capacity) +static bool reallot_string_in_place_p(string *str, cell capacity) { - return in_zone(&nursery,string) && capacity <= string_capacity(string); + return in_zone(&nursery,str) && capacity <= string_capacity(str); } -F_STRING* reallot_string(F_STRING *string_, CELL capacity) +string* reallot_string(string *str_, cell capacity) { - gc_root string(string_); + gc_root str(str_); - if(reallot_string_in_place_p(string.untagged(),capacity)) + if(reallot_string_in_place_p(str.untagged(),capacity)) { - string->length = tag_fixnum(capacity); + str->length = tag_fixnum(capacity); - if(string->aux != F) + if(str->aux != F) { - F_BYTE_ARRAY *aux = untag(string->aux); + byte_array *aux = untag(str->aux); aux->capacity = tag_fixnum(capacity * 2); } - return string.untagged(); + return str.untagged(); } else { - CELL to_copy = string_capacity(string.untagged()); + cell to_copy = string_capacity(str.untagged()); if(capacity < to_copy) to_copy = capacity; - gc_root new_string(allot_string_internal(capacity)); + gc_root new_str(allot_string_internal(capacity)); - memcpy(new_string->data(),string->data(),to_copy); + memcpy(new_str->data(),str->data(),to_copy); - if(string->aux != F) + if(str->aux != F) { - F_BYTE_ARRAY *new_aux = allot_byte_array(capacity * sizeof(u16)); + byte_array *new_aux = allot_byte_array(capacity * sizeof(u16)); - write_barrier(new_string.untagged()); - new_string->aux = tag(new_aux); + write_barrier(new_str.untagged()); + new_str->aux = tag(new_aux); - F_BYTE_ARRAY *aux = untag(string->aux); + byte_array *aux = untag(str->aux); memcpy(new_aux->data(),aux->data(),to_copy * sizeof(u16)); } - fill_string(new_string.untagged(),to_copy,capacity,'\0'); - return new_string.untagged(); + fill_string(new_str.untagged(),to_copy,capacity,'\0'); + return new_str.untagged(); } } PRIMITIVE(resize_string) { - F_STRING* string = untag_check(dpop()); - CELL capacity = unbox_array_size(); - dpush(tag(reallot_string(string,capacity))); + string* str = untag_check(dpop()); + cell capacity = unbox_array_size(); + dpush(tag(reallot_string(str,capacity))); } PRIMITIVE(string_nth) { - F_STRING *string = untag(dpop()); - CELL index = untag_fixnum(dpop()); - dpush(tag_fixnum(string_nth(string,index))); + string *str = untag(dpop()); + cell index = untag_fixnum(dpop()); + dpush(tag_fixnum(string_nth(str,index))); } PRIMITIVE(set_string_nth_fast) { - F_STRING *string = untag(dpop()); - CELL index = untag_fixnum(dpop()); - CELL value = untag_fixnum(dpop()); - set_string_nth_fast(string,index,value); + string *str = untag(dpop()); + cell index = untag_fixnum(dpop()); + cell value = untag_fixnum(dpop()); + set_string_nth_fast(str,index,value); } PRIMITIVE(set_string_nth_slow) { - F_STRING *string = untag(dpop()); - CELL index = untag_fixnum(dpop()); - CELL value = untag_fixnum(dpop()); - set_string_nth_slow(string,index,value); + string *str = untag(dpop()); + cell index = untag_fixnum(dpop()); + cell value = untag_fixnum(dpop()); + set_string_nth_slow(str,index,value); } } diff --git a/vm/strings.hpp b/vm/strings.hpp index f9cdc74bb1..9a082b0b83 100644 --- a/vm/strings.hpp +++ b/vm/strings.hpp @@ -1,25 +1,25 @@ namespace factor { -inline static CELL string_capacity(F_STRING *str) +inline static cell string_capacity(string *str) { return untag_fixnum(str->length); } -inline static CELL string_size(CELL size) +inline static cell string_size(cell size) { - return sizeof(F_STRING) + size; + return sizeof(string) + size; } -F_STRING* allot_string_internal(CELL capacity); -F_STRING* allot_string(CELL capacity, CELL fill); +string* allot_string_internal(cell capacity); +string* allot_string(cell capacity, cell fill); PRIMITIVE(string); -F_STRING *reallot_string(F_STRING *string, CELL capacity); +string *reallot_string(string *string, cell capacity); PRIMITIVE(resize_string); /* String getters and setters */ -CELL string_nth(F_STRING* string, CELL index); -void set_string_nth(F_STRING* string, CELL index, CELL value); +cell string_nth(string* string, cell index); +void set_string_nth(string* string, cell index, cell value); PRIMITIVE(string_nth); PRIMITIVE(set_string_nth_slow); diff --git a/vm/tagged.hpp b/vm/tagged.hpp index c31389f6b0..ea1942e10c 100644 --- a/vm/tagged.hpp +++ b/vm/tagged.hpp @@ -1,33 +1,33 @@ namespace factor { -template CELL tag(T *value) +template cell tag(T *value) { return RETAG(value,tag_for(T::type_number)); } -inline static CELL tag_dynamic(F_OBJECT *value) +inline static cell tag_dynamic(object *value) { - return RETAG(value,tag_for(value->header.hi_tag())); + return RETAG(value,tag_for(value->h.hi_tag())); } template struct tagged { - CELL value_; + cell value_; - CELL value() const { return value_; } + cell value() const { return value_; } T *untagged() const { return (T *)(UNTAG(value_)); } - CELL type() const { - CELL tag = TAG(value_); + cell type() const { + cell tag = TAG(value_); if(tag == OBJECT_TYPE) - return untagged()->header.hi_tag(); + return untagged()->h.hi_tag(); else return tag; } - bool type_p(CELL type_) const { return type() == type_; } + bool type_p(cell type_) const { return type() == type_; } T *untag_check() const { if(T::type_number != TYPE_COUNT && !type_p(T::type_number)) @@ -35,7 +35,7 @@ struct tagged return untagged(); } - explicit tagged(CELL tagged) : value_(tagged) { + explicit tagged(cell tagged) : value_(tagged) { #ifdef FACTOR_DEBUG untag_check(); #endif @@ -48,10 +48,10 @@ struct tagged } T *operator->() const { return untagged(); } - CELL *operator&() const { return &value_; } + cell *operator&() const { return &value_; } const tagged& operator=(const T *x) { value_ = tag(x); return *this; } - const tagged& operator=(const CELL &x) { value_ = x; return *this; } + const tagged& operator=(const cell &x) { value_ = x; return *this; } bool operator==(const tagged &x) { return value_ == x.value_; } bool operator!=(const tagged &x) { return value_ != x.value_; } @@ -59,12 +59,12 @@ struct tagged template tagged as() { return tagged(value_); } }; -template T *untag_check(CELL value) +template T *untag_check(cell value) { return tagged(value).untag_check(); } -template T *untag(CELL value) +template T *untag(cell value) { return tagged(value).untagged(); } diff --git a/vm/tuples.cpp b/vm/tuples.cpp index 5807d4baf4..d7e22bb807 100644 --- a/vm/tuples.cpp +++ b/vm/tuples.cpp @@ -4,34 +4,34 @@ namespace factor { /* push a new tuple on the stack */ -F_TUPLE *allot_tuple(CELL layout_) +tuple *allot_tuple(cell layout_) { - gc_root layout(layout_); - gc_root tuple(allot(tuple_size(layout.untagged()))); - tuple->layout = layout.value(); - return tuple.untagged(); + gc_root layout(layout_); + gc_root t(allot(tuple_size(layout.untagged()))); + t->layout = layout.value(); + return t.untagged(); } PRIMITIVE(tuple) { - gc_root layout(dpop()); - F_TUPLE *tuple = allot_tuple(layout.value()); - F_FIXNUM i; + gc_root layout(dpop()); + tuple *t = allot_tuple(layout.value()); + fixnum i; for(i = tuple_size(layout.untagged()) - 1; i >= 0; i--) - tuple->data()[i] = F; + t->data()[i] = F; - dpush(tag(tuple)); + dpush(tag(t)); } /* push a new tuple on the stack, filling its slots from the stack */ PRIMITIVE(tuple_boa) { - gc_root layout(dpop()); - gc_root tuple(allot_tuple(layout.value())); - CELL size = untag_fixnum(layout.untagged()->size) * CELLS; - memcpy(tuple->data(),(CELL *)(ds - (size - CELLS)),size); + gc_root layout(dpop()); + gc_root t(allot_tuple(layout.value())); + cell size = untag_fixnum(layout.untagged()->size) * sizeof(cell); + memcpy(t->data(),(cell *)(ds - (size - sizeof(cell))),size); ds -= size; - dpush(tuple.value()); + dpush(t.value()); } } diff --git a/vm/tuples.hpp b/vm/tuples.hpp index 477510307b..831bb3bbac 100644 --- a/vm/tuples.hpp +++ b/vm/tuples.hpp @@ -1,21 +1,10 @@ namespace factor { -inline static CELL tuple_size(F_TUPLE_LAYOUT *layout) +inline static cell tuple_size(tuple_layout *layout) { - CELL size = untag_fixnum(layout->size); - return sizeof(F_TUPLE) + size * CELLS; -} - -inline static CELL tuple_nth(F_TUPLE *tuple, CELL slot) -{ - return tuple->data()[slot]; -} - -inline static void set_tuple_nth(F_TUPLE *tuple, CELL slot, CELL value) -{ - tuple->data()[slot] = value; - write_barrier(tuple); + cell size = untag_fixnum(layout->size); + return sizeof(tuple) + size * sizeof(cell); } PRIMITIVE(tuple); diff --git a/vm/utilities.cpp b/vm/utilities.cpp index 2ccc0aaf78..532de80ed1 100755 --- a/vm/utilities.cpp +++ b/vm/utilities.cpp @@ -11,9 +11,9 @@ void *safe_malloc(size_t size) return ptr; } -F_CHAR *safe_strdup(const F_CHAR *str) +vm_char *safe_strdup(const vm_char *str) { - F_CHAR *ptr = STRDUP(str); + vm_char *ptr = STRDUP(str); if(!ptr) fatal_error("Out of memory in safe_strdup", 0); return ptr; } @@ -30,30 +30,30 @@ void print_string(const char *str) fputs(str,stdout); } -void print_cell(CELL x) +void print_cell(cell x) { - printf(CELL_FORMAT,x); + printf(cell_FORMAT,x); } -void print_cell_hex(CELL x) +void print_cell_hex(cell x) { - printf(CELL_HEX_FORMAT,x); + printf(cell_HEX_FORMAT,x); } -void print_cell_hex_pad(CELL x) +void print_cell_hex_pad(cell x) { - printf(CELL_HEX_PAD_FORMAT,x); + printf(cell_HEX_PAD_FORMAT,x); } -void print_fixnum(F_FIXNUM x) +void print_fixnum(fixnum x) { printf(FIXNUM_FORMAT,x); } -CELL read_cell_hex(void) +cell read_cell_hex(void) { - CELL cell; - if(scanf(CELL_HEX_FORMAT,&cell) < 0) exit(1); + cell cell; + if(scanf(cell_HEX_FORMAT,&cell) < 0) exit(1); return cell; }; diff --git a/vm/utilities.hpp b/vm/utilities.hpp index 249ea562f5..d311b954ed 100755 --- a/vm/utilities.hpp +++ b/vm/utilities.hpp @@ -2,14 +2,14 @@ namespace factor { void *safe_malloc(size_t size); -F_CHAR *safe_strdup(const F_CHAR *str); +vm_char *safe_strdup(const vm_char *str); void nl(void); void print_string(const char *str); -void print_cell(CELL x); -void print_cell_hex(CELL x); -void print_cell_hex_pad(CELL x); -void print_fixnum(F_FIXNUM x); -CELL read_cell_hex(void); +void print_cell(cell x); +void print_cell_hex(cell x); +void print_cell_hex_pad(cell x); +void print_fixnum(fixnum x); +cell read_cell_hex(void); } diff --git a/vm/words.cpp b/vm/words.cpp index d1523ebccf..cb2fdf0dd6 100644 --- a/vm/words.cpp +++ b/vm/words.cpp @@ -3,79 +3,76 @@ namespace factor { -F_WORD *allot_word(CELL vocab_, CELL name_) +word *allot_word(cell vocab_, cell name_) { - gc_root vocab(vocab_); - gc_root name(name_); + gc_root vocab(vocab_); + gc_root name(name_); - gc_root word(allot(sizeof(F_WORD))); + gc_root new_word(allot(sizeof(word))); - word->hashcode = tag_fixnum((rand() << 16) ^ rand()); - word->vocabulary = vocab.value(); - word->name = name.value(); - word->def = userenv[UNDEFINED_ENV]; - word->props = F; - word->counter = tag_fixnum(0); - word->direct_entry_def = F; - word->subprimitive = F; - word->profiling = NULL; - word->code = NULL; + new_word->hashcode = tag_fixnum((rand() << 16) ^ rand()); + new_word->vocabulary = vocab.value(); + new_word->name = name.value(); + new_word->def = userenv[UNDEFINED_ENV]; + new_word->props = F; + new_word->counter = tag_fixnum(0); + new_word->direct_entry_def = F; + new_word->subprimitive = F; + new_word->profiling = NULL; + new_word->code = NULL; - jit_compile_word(word.value(),word->def,true); - update_word_xt(word.value()); + jit_compile_word(new_word.value(),new_word->def,true); + update_word_xt(new_word.value()); if(profiling_p) - relocate_code_block(word->profiling); + relocate_code_block(new_word->profiling); - return word.untagged(); + return new_word.untagged(); } /* ( name vocabulary -- word ) */ PRIMITIVE(word) { - CELL vocab = dpop(); - CELL name = dpop(); - dpush(tag(allot_word(vocab,name))); + cell vocab = dpop(); + cell name = dpop(); + dpush(tag(allot_word(vocab,name))); } /* word-xt ( word -- start end ) */ PRIMITIVE(word_xt) { - F_WORD *word = untag_check(dpop()); - F_CODE_BLOCK *code = (profiling_p ? word->profiling : word->code); - dpush(allot_cell((CELL)code + sizeof(F_CODE_BLOCK))); - dpush(allot_cell((CELL)code + code->block.size)); + word *w = untag_check(dpop()); + code_block *code = (profiling_p ? w->profiling : w->code); + dpush(allot_cell((cell)code->xt())); + dpush(allot_cell((cell)code + code->block.size)); } /* Allocates memory */ -void update_word_xt(CELL word_) +void update_word_xt(cell w_) { - gc_root word(word_); + gc_root w(w_); if(profiling_p) { - if(!word->profiling) - { - F_CODE_BLOCK *profiling = compile_profiling_stub(word.value()); - word->profiling = profiling; - } + if(!w->profiling) + w->profiling = compile_profiling_stub(w.value()); - word->xt = (XT)(word->profiling + 1); + w->xt = w->profiling->xt(); } else - word->xt = (XT)(word->code + 1); + w->xt = w->code->xt(); } PRIMITIVE(optimized_p) { - drepl(tag_boolean(word_optimized_p(untag_check(dpeek())))); + drepl(tag_boolean(word_optimized_p(untag_check(dpeek())))); } PRIMITIVE(wrapper) { - F_WRAPPER *wrapper = allot(sizeof(F_WRAPPER)); - wrapper->object = dpeek(); - drepl(tag(wrapper)); + wrapper *new_wrapper = allot(sizeof(wrapper)); + new_wrapper->object = dpeek(); + drepl(tag(new_wrapper)); } } diff --git a/vm/words.hpp b/vm/words.hpp index 15c541e9ea..9c8e7ad57a 100644 --- a/vm/words.hpp +++ b/vm/words.hpp @@ -1,13 +1,13 @@ namespace factor { -F_WORD *allot_word(CELL vocab, CELL name); +word *allot_word(cell vocab, cell name); PRIMITIVE(word); PRIMITIVE(word_xt); -void update_word_xt(CELL word); +void update_word_xt(cell word); -inline bool word_optimized_p(F_WORD *word) +inline bool word_optimized_p(word *word) { return word->code->block.type == WORD_TYPE; } diff --git a/vm/write_barrier.cpp b/vm/write_barrier.cpp index 3ea138f456..4137b0a6eb 100644 --- a/vm/write_barrier.cpp +++ b/vm/write_barrier.cpp @@ -2,6 +2,6 @@ using namespace factor; -CELL cards_offset; -CELL decks_offset; -CELL allot_markers_offset; +cell cards_offset; +cell decks_offset; +cell allot_markers_offset; diff --git a/vm/write_barrier.hpp b/vm/write_barrier.hpp index 9c317d45b4..ae7fbb25dd 100644 --- a/vm/write_barrier.hpp +++ b/vm/write_barrier.hpp @@ -13,51 +13,75 @@ namespace factor #define CARD_POINTS_TO_NURSERY 0x80 #define CARD_POINTS_TO_AGING 0x40 #define CARD_MARK_MASK (CARD_POINTS_TO_NURSERY | CARD_POINTS_TO_AGING) -typedef u8 F_CARD; +typedef u8 card; #define CARD_BITS 8 #define CARD_SIZE (1<> CARD_BITS) + cards_offset) -#define CARD_TO_ADDR(c) (CELL*)(((CELL)(c) - cards_offset)<> CARD_BITS) + cards_offset); +} -typedef u8 F_DECK; +inline static cell card_to_addr(card *c) +{ + return ((cell)c - cards_offset) << CARD_BITS; +} + +inline static cell card_offset(card *c) +{ + return *(c - (cell)data->cards + (cell)data->allot_markers); +} + +typedef u8 card_deck; #define DECK_BITS (CARD_BITS + 10) #define DECK_SIZE (1<> DECK_BITS) + decks_offset) -#define DECK_TO_ADDR(c) (CELL*)(((CELL)(c) - decks_offset) << DECK_BITS) +inline static card_deck *addr_to_deck(cell a) +{ + return (card_deck *)(((cell)a >> DECK_BITS) + decks_offset); +} -#define DECK_TO_CARD(d) (F_CARD*)((((CELL)(d) - decks_offset) << (DECK_BITS - CARD_BITS)) + cards_offset) +inline static cell deck_to_addr(card_deck *c) +{ + return ((cell)c - decks_offset) << DECK_BITS; +} -#define ADDR_TO_ALLOT_MARKER(a) (F_CARD*)(((CELL)(a) >> CARD_BITS) + allot_markers_offset) -#define CARD_OFFSET(c) (*((c) - (CELL)data_heap->cards + (CELL)data_heap->allot_markers)) +inline static card *deck_to_card(card_deck *d) +{ + return (card *)((((cell)d - decks_offset) << (DECK_BITS - CARD_BITS)) + cards_offset); +} #define INVALID_ALLOT_MARKER 0xff -VM_C_API CELL allot_markers_offset; +VM_C_API cell allot_markers_offset; + +inline static card *addr_to_allot_marker(object *a) +{ + return (card *)(((cell)a >> CARD_BITS) + allot_markers_offset); +} /* the write barrier must be called any time we are potentially storing a pointer from an older generation to a younger one */ -inline static void write_barrier(F_OBJECT *address) +inline static void write_barrier(object *obj) { - *ADDR_TO_CARD(address) = CARD_MARK_MASK; - *ADDR_TO_DECK(address) = CARD_MARK_MASK; + *addr_to_card((cell)obj) = CARD_MARK_MASK; + *addr_to_deck((cell)obj) = CARD_MARK_MASK; } /* we need to remember the first object allocated in the card */ -inline static void allot_barrier(F_OBJECT *address) +inline static void allot_barrier(object *address) { - F_CARD *ptr = ADDR_TO_ALLOT_MARKER(address); + card *ptr = addr_to_allot_marker(address); if(*ptr == INVALID_ALLOT_MARKER) - *ptr = ((CELL)address & ADDR_CARD_MASK); + *ptr = ((cell)address & ADDR_CARD_MASK); } } From abf7912ae70c2889ec068acb64a515de8d4f2c52 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 May 2009 05:07:14 -0500 Subject: [PATCH 36/44] Cleanups --- vm/factor.cpp | 3 --- vm/local_roots.hpp | 9 ++++++++- vm/quotations.cpp | 8 ++++---- 3 files changed, 12 insertions(+), 8 deletions(-) diff --git a/vm/factor.cpp b/vm/factor.cpp index 28f0afacf6..b607adba63 100755 --- a/vm/factor.cpp +++ b/vm/factor.cpp @@ -125,10 +125,7 @@ VM_C_API void init_factor(vm_parameters *p) load_image(p); init_c_io(); init_inline_caching(p->max_pic_size); - -#ifndef FACTOR_DEBUG init_signals(); -#endif if(p->console) open_console(); diff --git a/vm/local_roots.hpp b/vm/local_roots.hpp index 9506a421f5..e074d999e7 100644 --- a/vm/local_roots.hpp +++ b/vm/local_roots.hpp @@ -20,7 +20,14 @@ struct gc_root : public tagged const gc_root& operator=(const T *x) { tagged::operator=(x); return *this; } const gc_root& operator=(const cell &x) { tagged::operator=(x); return *this; } - ~gc_root() { cell old = gc_local_pop(); assert(old == (cell)this); } + ~gc_root() { +#ifdef FACTOR_DEBUG + cell old = gc_local_pop(); + assert(old == (cell)this); +#else + gc_local_pop(); +#endif + } }; /* A similar hack for the bignum implementation */ diff --git a/vm/quotations.cpp b/vm/quotations.cpp index 2b9a37a6f7..c87cf8dc82 100755 --- a/vm/quotations.cpp +++ b/vm/quotations.cpp @@ -323,11 +323,11 @@ fixnum quot_code_offset_to_scan(cell quot_, cell offset) gc_root quot(quot_); gc_root array(quot->array); - quotation_jit jit(quot.value(),false,false); - jit.compute_position(offset); - jit.iterate_quotation(); + quotation_jit compiler(quot.value(),false,false); + compiler.compute_position(offset); + compiler.iterate_quotation(); - return jit.get_position(); + return compiler.get_position(); } VM_ASM_API cell lazy_jit_compile_impl(cell quot_, stack_frame *stack) From 3250c6935e64aa8f4d7596d8a0d9df8810c30f61 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 May 2009 05:15:48 -0500 Subject: [PATCH 37/44] Don't make a curry --- core/slots/slots.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 63c0319c1c..6bb854daf6 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -122,7 +122,7 @@ ERROR: bad-slot-value value class ; [ \ over , over reader-word 1quotation - [ dip call ] curry [ dip swap ] curry % + [ dip call ] curry [ ] like [ dip swap ] curry % swap setter-word , ] [ ] make (( object quot -- object )) define-inline ] [ 2drop ] if ; From 28cb6ea5c345f3b03bccceb0d1083982a208c4f1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 May 2009 06:43:20 -0500 Subject: [PATCH 38/44] NetBSD build fix --- vm/os-netbsd.cpp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/vm/os-netbsd.cpp b/vm/os-netbsd.cpp index cd397bdae1..7a3cb30652 100755 --- a/vm/os-netbsd.cpp +++ b/vm/os-netbsd.cpp @@ -3,13 +3,13 @@ namespace factor { -extern int main(); +extern "C" int main(); const char *vm_executable_path(void) { static Dl_info info = {0}; if (!info.dli_fname) - dladdr(main, &info); + dladdr((void *)main, &info); return info.dli_fname; } From b2c3183b21d8b2569f61aff2f31fcb09f82aaa10 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 May 2009 06:44:17 -0500 Subject: [PATCH 39/44] Split up tools.vocabs. Note that load-everything is now named load-all --- basis/bootstrap/tools/tools.factor | 5 +- basis/editors/editors.factor | 10 +- basis/help/apropos/apropos.factor | 4 +- basis/help/handbook/handbook.factor | 3 +- basis/help/html/html.factor | 2 +- basis/help/lint/lint.factor | 2 +- basis/help/tutorial/tutorial.factor | 2 +- basis/help/vocabs/vocabs.factor | 3 +- basis/http/server/server-docs.factor | 2 +- basis/http/server/server.factor | 4 +- basis/present/present-tests.factor | 2 +- basis/tools/completion/completion.factor | 8 +- .../tools/deploy/config/editor/editor.factor | 2 +- basis/tools/deploy/shaker/shaker.factor | 2 +- basis/tools/test/test.factor | 6 +- basis/tools/vocabs/summary.txt | 1 - basis/tools/vocabs/vocabs-docs.factor | 83 ----- basis/tools/vocabs/vocabs.factor | 310 ------------------ basis/ui/backend/cocoa/tools/tools.factor | 3 +- basis/ui/tools/listener/listener-docs.factor | 2 +- basis/ui/tools/listener/listener.factor | 5 +- basis/ui/tools/operations/operations.factor | 2 +- basis/ui/tools/tools.factor | 2 +- basis/vocabs/cache/authors.txt | 1 + basis/vocabs/cache/cache.factor | 21 ++ basis/vocabs/cache/summary.txt | 1 + basis/vocabs/errors/authors.txt | 1 + basis/vocabs/errors/errors.factor | 35 ++ basis/vocabs/errors/summary.txt | 1 + basis/vocabs/files/authors.txt | 1 + basis/vocabs/files/files-docs.factor | 11 + basis/vocabs/files/files.factor | 34 ++ basis/vocabs/files/summary.txt | 1 + basis/vocabs/hierarchy/hierarchy-docs.factor | 33 ++ .../hierarchy/hierarchy-tests.factor} | 4 +- basis/vocabs/hierarchy/hierarchy.factor | 99 ++++++ basis/vocabs/hierarchy/summary.txt | 1 + basis/vocabs/metadata/authors.txt | 1 + basis/vocabs/metadata/metadata-docs.factor | 44 +++ basis/vocabs/metadata/metadata.factor | 70 ++++ basis/vocabs/metadata/summary.txt | 1 + basis/vocabs/refresh/authors.txt | 1 + .../refresh}/monitor/authors.txt | 0 .../refresh}/monitor/monitor-tests.factor | 4 +- .../refresh}/monitor/monitor.factor | 12 +- .../refresh}/monitor/summary.txt | 0 basis/vocabs/refresh/refresh-docs.factor | 22 ++ basis/vocabs/refresh/refresh.factor | 91 +++++ basis/vocabs/refresh/summary.txt | 1 + core/alien/dlls/authors.txt | 1 + core/alien/dlls/dlls.factor | 4 + core/parser/parser.factor | 3 +- core/source-files/source-files-docs.factor | 4 +- core/vocabs/loader/loader-docs.factor | 2 +- core/vocabs/loader/loader-tests.factor | 4 +- extra/benchmark/benchmark.factor | 2 +- extra/benchmark/gc0/authors.txt | 1 + extra/benchmark/gc0/gc0.factor | 9 + extra/benchmark/gc2/authors.txt | 1 + extra/benchmark/gc2/gc2.factor | 24 ++ extra/fuel/help/help.factor | 8 +- extra/fuel/xref/xref.factor | 2 +- extra/galois-talk/galois-talk.factor | 2 +- .../google-tech-talk/google-tech-talk.factor | 2 +- extra/mason/common/common.factor | 4 +- extra/mason/report/report.factor | 6 +- extra/mason/test/test.factor | 11 +- extra/otug-talk/otug-talk.factor | 12 +- extra/vpri-talk/vpri-talk.factor | 8 +- 69 files changed, 595 insertions(+), 471 deletions(-) delete mode 100644 basis/tools/vocabs/summary.txt delete mode 100644 basis/tools/vocabs/vocabs-docs.factor delete mode 100644 basis/tools/vocabs/vocabs.factor create mode 100644 basis/vocabs/cache/authors.txt create mode 100644 basis/vocabs/cache/cache.factor create mode 100644 basis/vocabs/cache/summary.txt create mode 100644 basis/vocabs/errors/authors.txt create mode 100644 basis/vocabs/errors/errors.factor create mode 100644 basis/vocabs/errors/summary.txt create mode 100644 basis/vocabs/files/authors.txt create mode 100644 basis/vocabs/files/files-docs.factor create mode 100644 basis/vocabs/files/files.factor create mode 100644 basis/vocabs/files/summary.txt create mode 100644 basis/vocabs/hierarchy/hierarchy-docs.factor rename basis/{tools/vocabs/vocabs-tests.factor => vocabs/hierarchy/hierarchy-tests.factor} (72%) create mode 100644 basis/vocabs/hierarchy/hierarchy.factor create mode 100644 basis/vocabs/hierarchy/summary.txt create mode 100644 basis/vocabs/metadata/authors.txt create mode 100644 basis/vocabs/metadata/metadata-docs.factor create mode 100644 basis/vocabs/metadata/metadata.factor create mode 100644 basis/vocabs/metadata/summary.txt create mode 100644 basis/vocabs/refresh/authors.txt rename basis/{tools/vocabs => vocabs/refresh}/monitor/authors.txt (100%) rename basis/{tools/vocabs => vocabs/refresh}/monitor/monitor-tests.factor (67%) rename basis/{tools/vocabs => vocabs/refresh}/monitor/monitor.factor (80%) rename basis/{tools/vocabs => vocabs/refresh}/monitor/summary.txt (100%) create mode 100644 basis/vocabs/refresh/refresh-docs.factor create mode 100644 basis/vocabs/refresh/refresh.factor create mode 100644 basis/vocabs/refresh/summary.txt create mode 100644 core/alien/dlls/authors.txt create mode 100644 core/alien/dlls/dlls.factor create mode 100644 extra/benchmark/gc0/authors.txt create mode 100644 extra/benchmark/gc0/gc0.factor create mode 100644 extra/benchmark/gc2/authors.txt create mode 100644 extra/benchmark/gc2/gc2.factor diff --git a/basis/bootstrap/tools/tools.factor b/basis/bootstrap/tools/tools.factor index cb0792ee1e..6017469925 100644 --- a/basis/bootstrap/tools/tools.factor +++ b/basis/bootstrap/tools/tools.factor @@ -14,7 +14,8 @@ IN: bootstrap.tools "tools.test" "tools.time" "tools.threads" - "tools.vocabs" - "tools.vocabs.monitor" + "vocabs.hierarchy" + "vocabs.refresh" + "vocabs.refresh.monitor" "editors" } [ require ] each diff --git a/basis/editors/editors.factor b/basis/editors/editors.factor index 6088400bd8..d5b4b909e3 100644 --- a/basis/editors/editors.factor +++ b/basis/editors/editors.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: parser lexer kernel namespaces sequences definitions io.files -io.backend io.pathnames io summary continuations tools.crossref -tools.vocabs prettyprint source-files source-files.errors assocs -vocabs vocabs.loader splitting accessors debugger prettyprint -help.topics ; +USING: parser lexer kernel namespaces sequences definitions +io.files io.backend io.pathnames io summary continuations +tools.crossref vocabs.hierarchy prettyprint source-files +source-files.errors assocs vocabs vocabs.loader splitting +accessors debugger prettyprint help.topics ; IN: editors TUPLE: no-edit-hook ; diff --git a/basis/help/apropos/apropos.factor b/basis/help/apropos/apropos.factor index b241db4c0e..63cbcb3f1e 100644 --- a/basis/help/apropos/apropos.factor +++ b/basis/help/apropos/apropos.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs fry help.markup help.topics io kernel make math math.parser namespaces sequences sorting -summary tools.completion tools.vocabs help.vocabs +summary tools.completion vocabs.hierarchy help.vocabs vocabs words unicode.case help ; IN: help.apropos diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor index 262c46bbc3..b83fb22ccf 100644 --- a/basis/help/handbook/handbook.factor +++ b/basis/help/handbook/handbook.factor @@ -281,7 +281,7 @@ ARTICLE: "handbook-tools-reference" "Developer tools" { $heading "Workflow" } { $subsection "listener" } { $subsection "editor" } -{ $subsection "tools.vocabs" } +{ $subsection "vocabs.refresh" } { $subsection "tools.test" } { $subsection "help" } { $heading "Debugging" } @@ -292,6 +292,7 @@ ARTICLE: "handbook-tools-reference" "Developer tools" { $heading "Browsing" } { $subsection "see" } { $subsection "tools.crossref" } +{ $subsection "vocabs.hierarchy" } { $heading "Performance" } { $subsection "timing" } { $subsection "profiling" } diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor index f4a8742486..348fcbbbfb 100644 --- a/basis/help/html/html.factor +++ b/basis/help/html/html.factor @@ -3,7 +3,7 @@ USING: io.encodings.utf8 io.encodings.ascii io.encodings.binary io.files io.files.temp io.directories html.streams help kernel assocs sequences make words accessors arrays help.topics vocabs -tools.vocabs help.vocabs namespaces prettyprint io +vocabs.hierarchy help.vocabs namespaces prettyprint io vocabs.loader serialize fry memoize ascii unicode.case math.order sorting debugger html xml.syntax xml.writer math.parser ; IN: help.html diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor index 42f29bc8b7..f25d5f0f93 100755 --- a/basis/help/lint/lint.factor +++ b/basis/help/lint/lint.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs continuations fry help help.lint.checks help.topics io kernel namespaces parser sequences -source-files.errors tools.vocabs vocabs words classes +source-files.errors vocabs.hierarchy vocabs words classes locals tools.errors ; FROM: help.lint.checks => all-vocabs ; IN: help.lint diff --git a/basis/help/tutorial/tutorial.factor b/basis/help/tutorial/tutorial.factor index 2ed18b7cd5..7686022b70 100644 --- a/basis/help/tutorial/tutorial.factor +++ b/basis/help/tutorial/tutorial.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax ui.commands ui.operations editors vocabs.loader kernel sequences prettyprint tools.test -tools.vocabs strings unicode.categories unicode.case +vocabs.refresh strings unicode.categories unicode.case ui.tools.browser ui.tools.common ; IN: help.tutorial diff --git a/basis/help/vocabs/vocabs.factor b/basis/help/vocabs/vocabs.factor index a8c93feee4..b23143e572 100644 --- a/basis/help/vocabs/vocabs.factor +++ b/basis/help/vocabs/vocabs.factor @@ -6,7 +6,8 @@ classes.singleton classes.tuple classes.union combinators definitions effects fry generic help help.markup help.stylesheet help.topics io io.files io.pathnames io.styles kernel macros make namespaces prettyprint sequences sets sorting summary -tools.vocabs vocabs vocabs.loader words words.symbol definitions.icons ; +vocabs vocabs.files vocabs.hierarchy vocabs.loader +vocabs.metadata words words.symbol definitions.icons ; IN: help.vocabs : about ( vocab -- ) diff --git a/basis/http/server/server-docs.factor b/basis/http/server/server-docs.factor index 29f61416fa..daf0305972 100644 --- a/basis/http/server/server-docs.factor +++ b/basis/http/server/server-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax io.streams.string quotations strings urls http tools.vocabs math io.servers.connection ; +USING: help.markup help.syntax io.streams.string quotations strings urls http vocabs.refresh math io.servers.connection ; IN: http.server HELP: trivial-responder diff --git a/basis/http/server/server.factor b/basis/http/server/server.factor index 8b22b9a885..3beb730499 100755 --- a/basis/http/server/server.factor +++ b/basis/http/server/server.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2003, 2008 Slava Pestov. +! Copyright (C) 2003, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors sequences arrays namespaces splitting vocabs.loader destructors assocs debugger continuations -combinators tools.vocabs tools.time math math.parser present +combinators vocabs.refresh tools.time math math.parser present io vectors io.sockets io.sockets.secure diff --git a/basis/present/present-tests.factor b/basis/present/present-tests.factor index 22d352cb5a..559b9ac01d 100644 --- a/basis/present/present-tests.factor +++ b/basis/present/present-tests.factor @@ -1,5 +1,5 @@ IN: present.tests -USING: tools.test present math vocabs tools.vocabs sequences kernel ; +USING: tools.test present math vocabs sequences kernel ; [ "3" ] [ 3 present ] unit-test [ "Hi" ] [ "Hi" present ] unit-test diff --git a/basis/tools/completion/completion.factor b/basis/tools/completion/completion.factor index 99def097a2..00d86a1608 100644 --- a/basis/tools/completion/completion.factor +++ b/basis/tools/completion/completion.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel arrays sequences math namespaces -strings io fry vectors words assocs combinators sorting -unicode.case unicode.categories math.order vocabs -tools.vocabs unicode.data locals ; +USING: accessors kernel arrays sequences math namespaces strings io +fry vectors words assocs combinators sorting unicode.case +unicode.categories math.order vocabs vocabs.hierarchy unicode.data +locals ; IN: tools.completion :: (fuzzy) ( accum i full ch -- accum i full ? ) diff --git a/basis/tools/deploy/config/editor/editor.factor b/basis/tools/deploy/config/editor/editor.factor index ac89e3290b..78d86a4707 100644 --- a/basis/tools/deploy/config/editor/editor.factor +++ b/basis/tools/deploy/config/editor/editor.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs io.pathnames kernel parser prettyprint sequences -splitting tools.deploy.config tools.vocabs vocabs.loader ; +splitting tools.deploy.config vocabs.loader vocabs.metadata ; IN: tools.deploy.config.editor : deploy-config-path ( vocab -- string ) diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 9b02d3208f..fd43d1ccc9 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -37,7 +37,7 @@ IN: tools.deploy.shaker ] when strip-dictionary? [ "compiler.units" init-hooks get delete-at - "tools.vocabs" init-hooks get delete-at + "vocabs.cache" init-hooks get delete-at ] when ; : strip-debugger ( -- ) diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor index c0c2f1892d..3dc7b8740b 100644 --- a/basis/tools/test/test.factor +++ b/basis/tools/test/test.factor @@ -4,9 +4,9 @@ USING: accessors arrays assocs combinators compiler.units continuations debugger effects fry generalizations io io.files io.styles kernel lexer locals macros math.parser namespaces parser prettyprint quotations sequences source-files splitting -stack-checker summary unicode.case vectors vocabs vocabs.loader words -tools.vocabs tools.errors source-files.errors io.streams.string make -compiler.errors ; +stack-checker summary unicode.case vectors vocabs vocabs.loader +vocabs.files words tools.errors source-files.errors +io.streams.string make compiler.errors ; IN: tools.test TUPLE: test-failure < source-file-error continuation ; diff --git a/basis/tools/vocabs/summary.txt b/basis/tools/vocabs/summary.txt deleted file mode 100644 index 1ae5f43784..0000000000 --- a/basis/tools/vocabs/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Reloading vocabularies and cross-referencing vocabularies diff --git a/basis/tools/vocabs/vocabs-docs.factor b/basis/tools/vocabs/vocabs-docs.factor deleted file mode 100644 index 98902f8fe6..0000000000 --- a/basis/tools/vocabs/vocabs-docs.factor +++ /dev/null @@ -1,83 +0,0 @@ -USING: help.markup help.syntax strings ; -IN: tools.vocabs - -ARTICLE: "tools.vocabs" "Vocabulary tools" -"Reloading source files changed on disk:" -{ $subsection refresh } -{ $subsection refresh-all } -"Vocabulary summaries:" -{ $subsection vocab-summary } -{ $subsection set-vocab-summary } -"Vocabulary tags:" -{ $subsection vocab-tags } -{ $subsection set-vocab-tags } -{ $subsection add-vocab-tags } -"Getting and setting vocabulary meta-data:" -{ $subsection vocab-file-contents } -{ $subsection set-vocab-file-contents } -"Global meta-data:" -{ $subsection all-vocabs } -{ $subsection all-vocabs-seq } -{ $subsection all-tags } -{ $subsection all-authors } -"Because loading the above data is expensive, it is cached. The cache is flushed by the " { $vocab-link "tools.vocabs.monitor" } " vocabulary. It can also be flushed manually when file system change monitors are not available:" -{ $subsection reset-cache } ; - -ABOUT: "tools.vocabs" - -HELP: vocab-files -{ $values { "vocab" "a vocabulary specifier" } { "seq" "a sequence of pathname strings" } } -{ $description "Outputs a sequence of files comprising this vocabulary, or " { $link f } " if the vocabulary does not have a directory on disk." } ; - -HELP: vocab-tests -{ $values { "vocab" "a vocabulary specifier" } { "tests" "a sequence of pathname strings" } } -{ $description "Outputs a sequence of pathnames where the unit tests for " { $snippet "vocab" } " are located." } ; - -HELP: source-modified? -{ $values { "path" "a pathname string" } { "?" "a boolean" } } -{ $description "Tests if the source file has been modified since it was last loaded. This compares the file's CRC32 checksum of the file's contents against the previously-recorded value." } ; - -HELP: refresh -{ $values { "prefix" string } } -{ $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ; - -HELP: refresh-all -{ $description "Reloads source files and documentation for all loaded vocabularies which have been modified on disk." } ; - -{ refresh refresh-all } related-words - -HELP: vocab-file-contents -{ $values { "vocab" "a vocabulary specifier" } { "name" string } { "seq" "a sequence of lines, or " { $link f } } } -{ $description "Outputs the contents of the file named " { $snippet "name" } " from the vocabulary's directory, or " { $link f } " if the file does not exist." } ; - -HELP: set-vocab-file-contents -{ $values { "seq" "a sequence of lines" } { "vocab" "a vocabulary specifier" } { "name" string } } -{ $description "Stores a sequence of lines to the file named " { $snippet "name" } " from the vocabulary's directory." } ; - -HELP: vocab-summary -{ $values { "vocab" "a vocabulary specifier" } { "summary" "a string or " { $link f } } } -{ $description "Outputs a one-line string description of the vocabulary's intended purpose from the " { $snippet "summary.txt" } " file in the vocabulary's directory. Outputs " { $link f } " if the file does not exist." } ; - -HELP: set-vocab-summary -{ $values { "string" "a string or " { $link f } } { "vocab" "a vocabulary specifier" } } -{ $description "Stores a one-line string description of the vocabulary to the " { $snippet "summary.txt" } " file in the vocabulary's directory." } ; - -HELP: vocab-tags -{ $values { "vocab" "a vocabulary specifier" } { "tags" "a sequence of strings" } } -{ $description "Outputs a list of short tags classifying the vocabulary from the " { $snippet "tags.txt" } " file in the vocabulary's directory. Outputs " { $link f } " if the file does not exist." } ; - -HELP: set-vocab-tags -{ $values { "tags" "a sequence of strings" } { "vocab" "a vocabulary specifier" } } -{ $description "Stores a list of short tags classifying the vocabulary to the " { $snippet "tags.txt" } " file in the vocabulary's directory." } ; - -HELP: all-vocabs -{ $values { "assoc" "an association list mapping vocabulary roots to sequences of vocabulary specifiers" } } -{ $description "Outputs an association list of all vocabularies which have been loaded or are available for loading." } ; - -HELP: load-all-under -{ $values { "prefix" string } } -{ $description "Load all vocabularies that match the provided prefix." } ; - -HELP: all-vocabs-under -{ $values { "prefix" string } } -{ $description "Return a sequence of vocab or vocab-links for each vocab matching the provided prefix. Unlike " { $link all-child-vocabs } " this word will return both loaded and unloaded vocabularies." } ; diff --git a/basis/tools/vocabs/vocabs.factor b/basis/tools/vocabs/vocabs.factor deleted file mode 100644 index 7cd94827db..0000000000 --- a/basis/tools/vocabs/vocabs.factor +++ /dev/null @@ -1,310 +0,0 @@ -! Copyright (C) 2007, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel io io.styles io.files io.files.info io.directories -io.pathnames io.encodings.utf8 vocabs.loader vocabs sequences -namespaces make math.parser arrays hashtables assocs memoize -summary sorting splitting combinators source-files debugger -continuations compiler.errors init checksums checksums.crc32 -sets accessors generic definitions words ; -IN: tools.vocabs - -: vocab-tests-file ( vocab -- path ) - dup "-tests.factor" vocab-dir+ vocab-append-path dup - [ dup exists? [ drop f ] unless ] [ drop f ] if ; - -: vocab-tests-dir ( vocab -- paths ) - dup vocab-dir "tests" append-path vocab-append-path dup [ - dup exists? [ - dup directory-files [ ".factor" tail? ] filter - [ append-path ] with map - ] [ drop f ] if - ] [ drop f ] if ; - -: vocab-tests ( vocab -- tests ) - [ - [ vocab-tests-file [ , ] when* ] - [ vocab-tests-dir [ % ] when* ] bi - ] { } make ; - -: vocab-files ( vocab -- seq ) - [ - [ vocab-source-path [ , ] when* ] - [ vocab-docs-path [ , ] when* ] - [ vocab-tests % ] tri - ] { } make ; - -: vocab-heading. ( vocab -- ) - nl - "==== " write - [ vocab-name ] [ vocab write-object ] bi ":" print - nl ; - -: load-error. ( triple -- ) - [ first vocab-heading. ] [ second print-error ] bi ; - -: load-failures. ( failures -- ) - [ load-error. nl ] each ; - -SYMBOL: failures - -: require-all ( vocabs -- failures ) - [ - V{ } clone blacklist set - V{ } clone failures set - [ - [ require ] - [ swap vocab-name failures get set-at ] - recover - ] each - failures get - ] with-scope ; - -: source-modified? ( path -- ? ) - dup source-files get at [ - dup path>> - dup exists? [ - utf8 file-lines crc32 checksum-lines - swap checksum>> = not - ] [ - 2drop f - ] if - ] [ - exists? - ] ?if ; - -SYMBOL: changed-vocabs - -: changed-vocab ( vocab -- ) - dup vocab changed-vocabs get and - [ dup changed-vocabs get set-at ] [ drop ] if ; - -: unchanged-vocab ( vocab -- ) - changed-vocabs get delete-at ; - -: unchanged-vocabs ( vocabs -- ) - [ unchanged-vocab ] each ; - -: changed-vocab? ( vocab -- ? ) - changed-vocabs get dup [ key? ] [ 2drop t ] if ; - -: filter-changed ( vocabs -- vocabs' ) - [ changed-vocab? ] filter ; - -SYMBOL: modified-sources -SYMBOL: modified-docs - -: (to-refresh) ( vocab variable loaded? path -- ) - dup [ - swap [ - pick changed-vocab? [ - source-modified? [ get push ] [ 2drop ] if - ] [ 3drop ] if - ] [ drop get push ] if - ] [ 2drop 2drop ] if ; - -: to-refresh ( prefix -- modified-sources modified-docs unchanged ) - [ - V{ } clone modified-sources set - V{ } clone modified-docs set - - child-vocabs [ - [ - [ - [ modified-sources ] - [ vocab source-loaded?>> ] - [ vocab-source-path ] - tri (to-refresh) - ] [ - [ modified-docs ] - [ vocab docs-loaded?>> ] - [ vocab-docs-path ] - tri (to-refresh) - ] bi - ] each - - modified-sources get - modified-docs get - ] - [ modified-docs get modified-sources get append diff ] bi - ] with-scope ; - -: do-refresh ( modified-sources modified-docs unchanged -- ) - unchanged-vocabs - [ - [ [ vocab f >>source-loaded? drop ] each ] - [ [ vocab f >>docs-loaded? drop ] each ] bi* - ] - [ - append prune - [ unchanged-vocabs ] - [ require-all load-failures. ] bi - ] 2bi ; - -: refresh ( prefix -- ) to-refresh do-refresh ; - -: refresh-all ( -- ) "" refresh ; - -MEMO: vocab-file-contents ( vocab name -- seq ) - vocab-append-path dup - [ dup exists? [ utf8 file-lines ] [ drop f ] if ] when ; - -: set-vocab-file-contents ( seq vocab name -- ) - dupd vocab-append-path [ - utf8 set-file-lines - \ vocab-file-contents reset-memoized - ] [ - "The " swap vocab-name - " vocabulary was not loaded from the file system" - 3append throw - ] ?if ; - -: vocab-summary-path ( vocab -- string ) - vocab-dir "summary.txt" append-path ; - -: vocab-summary ( vocab -- summary ) - dup dup vocab-summary-path vocab-file-contents - [ - vocab-name " vocabulary" append - ] [ - nip first - ] if-empty ; - -M: vocab summary - [ - dup vocab-summary % - " (" % - words>> assoc-size # - " words)" % - ] "" make ; - -M: vocab-link summary vocab-summary ; - -: set-vocab-summary ( string vocab -- ) - [ 1array ] dip - dup vocab-summary-path - set-vocab-file-contents ; - -: vocab-tags-path ( vocab -- string ) - vocab-dir "tags.txt" append-path ; - -: vocab-tags ( vocab -- tags ) - dup vocab-tags-path vocab-file-contents harvest ; - -: set-vocab-tags ( tags vocab -- ) - dup vocab-tags-path set-vocab-file-contents ; - -: add-vocab-tags ( tags vocab -- ) - [ vocab-tags append prune ] keep set-vocab-tags ; - -: vocab-authors-path ( vocab -- string ) - vocab-dir "authors.txt" append-path ; - -: vocab-authors ( vocab -- authors ) - dup vocab-authors-path vocab-file-contents harvest ; - -: set-vocab-authors ( authors vocab -- ) - dup vocab-authors-path set-vocab-file-contents ; - - - - -: vocab-subdirs ( dir -- dirs ) - [ - [ [ link-info directory? ] [ valid-vocab-dirname ] bi and ] filter - ] with-directory-files natural-sort ; - -: (all-child-vocabs) ( root name -- vocabs ) - [ - vocab-dir append-path dup exists? - [ vocab-subdirs ] [ drop { } ] if - ] keep [ - swap [ "." glue ] with map - ] unless-empty ; - -: vocab-dir? ( root name -- ? ) - over - [ ".factor" vocab-dir+ append-path exists? ] - [ 2drop f ] - if ; - -: vocabs-in-dir ( root name -- ) - dupd (all-child-vocabs) [ - 2dup vocab-dir? [ dup >vocab-link , ] when - vocabs-in-dir - ] with each ; - -: all-vocabs ( -- assoc ) - vocab-roots get [ - dup [ "" vocabs-in-dir ] { } make - ] { } map>assoc ; - -: all-vocabs-under ( prefix -- vocabs ) - [ - vocab-roots get [ over vocabs-in-dir ] each drop - ] { } make ; - -MEMO: all-vocabs-seq ( -- seq ) - all-vocabs values concat ; - -: unportable? ( name -- ? ) - vocab-tags "unportable" swap member? ; - -: filter-unportable ( seq -- seq' ) - [ vocab-name unportable? not ] filter ; - -: try-everything ( -- failures ) - all-vocabs-seq - filter-unportable - require-all ; - -: load-everything ( -- ) - try-everything load-failures. ; - -: load-all-under ( prefix -- ) - all-vocabs-under filter-unportable require-all load-failures. ; - -: unrooted-child-vocabs ( prefix -- seq ) - dup empty? [ CHAR: . suffix ] unless - vocabs - [ find-vocab-root not ] filter - [ - vocab-name swap ?head CHAR: . rot member? not and - ] with filter - [ vocab ] map ; - -: all-child-vocabs ( prefix -- assoc ) - vocab-roots get [ - dup pick (all-child-vocabs) [ >vocab-link ] map - ] { } map>assoc - swap unrooted-child-vocabs f swap 2array suffix ; - -: all-child-vocabs-seq ( prefix -- assoc ) - vocab-roots get swap [ - dupd (all-child-vocabs) - [ vocab-dir? ] with filter - ] curry map concat ; - -MEMO: all-tags ( -- seq ) - all-vocabs-seq [ vocab-tags ] gather natural-sort ; - -MEMO: all-authors ( -- seq ) - all-vocabs-seq [ vocab-authors ] gather natural-sort ; - -: reset-cache ( -- ) - root-cache get-global clear-assoc - \ vocab-file-contents reset-memoized - \ all-vocabs-seq reset-memoized - \ all-authors reset-memoized - \ all-tags reset-memoized ; - -SINGLETON: cache-observer - -M: cache-observer vocabs-changed drop reset-cache ; - -[ - f changed-vocabs set-global - cache-observer add-vocab-observer -] "tools.vocabs" add-init-hook \ No newline at end of file diff --git a/basis/ui/backend/cocoa/tools/tools.factor b/basis/ui/backend/cocoa/tools/tools.factor index eb8823b107..cf5493f33d 100644 --- a/basis/ui/backend/cocoa/tools/tools.factor +++ b/basis/ui/backend/cocoa/tools/tools.factor @@ -4,7 +4,8 @@ USING: alien.syntax cocoa cocoa.nibs cocoa.application cocoa.classes cocoa.dialogs cocoa.pasteboard cocoa.subclassing core-foundation core-foundation.strings help.topics kernel memory namespaces parser system ui ui.tools.browser -ui.tools.listener ui.backend.cocoa eval locals tools.vocabs ; +ui.tools.listener ui.backend.cocoa eval locals +vocabs.refresh ; IN: ui.backend.cocoa.tools : finder-run-files ( alien -- ) diff --git a/basis/ui/tools/listener/listener-docs.factor b/basis/ui/tools/listener/listener-docs.factor index ec4fc80a4d..998020c9c4 100644 --- a/basis/ui/tools/listener/listener-docs.factor +++ b/basis/ui/tools/listener/listener-docs.factor @@ -1,7 +1,7 @@ USING: help.markup help.syntax ui.commands ui.operations ui.gadgets.editors ui.gadgets.panes listener io words ui.tools.listener.completion ui.tools.common help.tips -tools.vocabs vocabs ; +vocabs vocabs.refresh ; IN: ui.tools.listener HELP: interactor diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor index eca16e7286..6ed3577a06 100644 --- a/basis/ui/tools/listener/listener.factor +++ b/basis/ui/tools/listener/listener.factor @@ -6,14 +6,15 @@ compiler.units help.tips concurrency.flags concurrency.mailboxes continuations destructors documents documents.elements fry hashtables help help.markup io io.styles kernel lexer listener math models sets models.delay models.arrow namespaces parser prettyprint quotations -sequences strings threads tools.vocabs vocabs vocabs.loader +sequences strings threads vocabs vocabs.refresh vocabs.loader vocabs.parser words debugger ui ui.commands ui.pens.solid ui.gadgets ui.gadgets.glass ui.gadgets.buttons ui.gadgets.editors ui.gadgets.labeled ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.status-bar ui.gadgets.tracks ui.gadgets.borders ui.gestures ui.operations ui.tools.browser ui.tools.common ui.tools.debugger ui.tools.listener.completion ui.tools.listener.popups -ui.tools.listener.history ui.images ui.tools.error-list tools.errors.model ; +ui.tools.listener.history ui.images ui.tools.error-list +tools.errors.model ; FROM: source-files.errors => all-errors ; IN: ui.tools.listener diff --git a/basis/ui/tools/operations/operations.factor b/basis/ui/tools/operations/operations.factor index 3c16011897..650d751ee2 100644 --- a/basis/ui/tools/operations/operations.factor +++ b/basis/ui/tools/operations/operations.factor @@ -4,7 +4,7 @@ USING: continuations definitions generic help.topics threads stack-checker summary io.pathnames io.styles kernel namespaces parser prettyprint quotations tools.crossref tools.annotations editors tools.profiler tools.test tools.time tools.walker vocabs vocabs.loader -words sequences tools.vocabs classes compiler.errors compiler.units +words sequences classes compiler.errors compiler.units accessors vocabs.parser macros.expander ui ui.tools.browser ui.tools.listener ui.tools.listener.completion ui.tools.profiler ui.tools.inspector ui.tools.traceback ui.commands ui.gadgets.editors diff --git a/basis/ui/tools/tools.factor b/basis/ui/tools/tools.factor index c825c60dbb..7ea34e651f 100644 --- a/basis/ui/tools/tools.factor +++ b/basis/ui/tools/tools.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: memory system kernel tools.vocabs ui.tools.operations +USING: memory system kernel vocabs.refresh ui.tools.operations ui.tools.listener ui.tools.browser ui.tools.common ui.tools.error-list ui.tools.walker ui.commands ui.gestures ui ui.private ; IN: ui.tools diff --git a/basis/vocabs/cache/authors.txt b/basis/vocabs/cache/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/vocabs/cache/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/vocabs/cache/cache.factor b/basis/vocabs/cache/cache.factor new file mode 100644 index 0000000000..63a8d6d292 --- /dev/null +++ b/basis/vocabs/cache/cache.factor @@ -0,0 +1,21 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs kernel namespaces memoize init vocabs +vocabs.hierarchy vocabs.loader vocabs.metadata vocabs.refresh ; +IN: vocabs.cache + +: reset-cache ( -- ) + root-cache get-global clear-assoc + \ vocab-file-contents reset-memoized + \ all-vocabs-seq reset-memoized + \ all-authors reset-memoized + \ all-tags reset-memoized ; + +SINGLETON: cache-observer + +M: cache-observer vocabs-changed drop reset-cache ; + +[ + f changed-vocabs set-global + cache-observer add-vocab-observer +] "vocabs.cache" add-init-hook \ No newline at end of file diff --git a/basis/vocabs/cache/summary.txt b/basis/vocabs/cache/summary.txt new file mode 100644 index 0000000000..92ab1fe8eb --- /dev/null +++ b/basis/vocabs/cache/summary.txt @@ -0,0 +1 @@ +Caching vocabulary data from disk diff --git a/basis/vocabs/errors/authors.txt b/basis/vocabs/errors/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/vocabs/errors/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/vocabs/errors/errors.factor b/basis/vocabs/errors/errors.factor new file mode 100644 index 0000000000..8f88eb3816 --- /dev/null +++ b/basis/vocabs/errors/errors.factor @@ -0,0 +1,35 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs continuations debugger io io.styles kernel +namespaces sequences vocabs vocabs.loader ; +IN: vocabs.errors + + + +: load-failures. ( failures -- ) + [ load-error. nl ] each ; + +: require-all ( vocabs -- failures ) + [ + V{ } clone blacklist set + V{ } clone failures set + [ + [ require ] + [ swap vocab-name failures get set-at ] + recover + ] each + failures get + ] with-scope ; \ No newline at end of file diff --git a/basis/vocabs/errors/summary.txt b/basis/vocabs/errors/summary.txt new file mode 100644 index 0000000000..b7e7040366 --- /dev/null +++ b/basis/vocabs/errors/summary.txt @@ -0,0 +1 @@ +Loading vocabularies and batching errors diff --git a/basis/vocabs/files/authors.txt b/basis/vocabs/files/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/vocabs/files/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/vocabs/files/files-docs.factor b/basis/vocabs/files/files-docs.factor new file mode 100644 index 0000000000..e2c6a5f373 --- /dev/null +++ b/basis/vocabs/files/files-docs.factor @@ -0,0 +1,11 @@ +USING: help.markup help.syntax strings ; +IN: vocabs.files + +HELP: vocab-files +{ $values { "vocab" "a vocabulary specifier" } { "seq" "a sequence of pathname strings" } } +{ $description "Outputs a sequence of files comprising this vocabulary, or " { $link f } " if the vocabulary does not have a directory on disk." } ; + +HELP: vocab-tests +{ $values { "vocab" "a vocabulary specifier" } { "tests" "a sequence of pathname strings" } } +{ $description "Outputs a sequence of pathnames where the unit tests for " { $snippet "vocab" } " are located." } ; + diff --git a/basis/vocabs/files/files.factor b/basis/vocabs/files/files.factor new file mode 100644 index 0000000000..c1d7dcfd59 --- /dev/null +++ b/basis/vocabs/files/files.factor @@ -0,0 +1,34 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: io.directories io.files io.pathnames kernel make +sequences vocabs.loader ; +IN: vocabs.files + + + +: vocab-tests ( vocab -- tests ) + [ + [ vocab-tests-file [ , ] when* ] + [ vocab-tests-dir [ % ] when* ] bi + ] { } make ; + +: vocab-files ( vocab -- seq ) + [ + [ vocab-source-path [ , ] when* ] + [ vocab-docs-path [ , ] when* ] + [ vocab-tests % ] tri + ] { } make ; \ No newline at end of file diff --git a/basis/vocabs/files/summary.txt b/basis/vocabs/files/summary.txt new file mode 100644 index 0000000000..b1633e3782 --- /dev/null +++ b/basis/vocabs/files/summary.txt @@ -0,0 +1 @@ +Getting a list of files in a vocabulary diff --git a/basis/vocabs/hierarchy/hierarchy-docs.factor b/basis/vocabs/hierarchy/hierarchy-docs.factor new file mode 100644 index 0000000000..c5d8554635 --- /dev/null +++ b/basis/vocabs/hierarchy/hierarchy-docs.factor @@ -0,0 +1,33 @@ +USING: help.markup help.syntax strings vocabs.loader ; +IN: vocabs.hierarchy + +ARTICLE: "vocabs.hierarchy" "Vocabulary hierarchy tools" +"These tools operate on all vocabularies found in the current set of " { $link vocab-roots } ", loaded or not." +$nl +"Loading vocabulary hierarchies:" +{ $subsection load } +{ $subsection load-all } +"Getting all vocabularies on disk:" +{ $subsection all-vocabs } +{ $subsection all-vocabs-seq } +"Getting " { $link "vocabs.metadata" } " for all vocabularies on disk:" +{ $subsection all-tags } +{ $subsection all-authors } ; + +ABOUT: "vocabs.hierarchy" + +HELP: all-vocabs +{ $values { "assoc" "an association list mapping vocabulary roots to sequences of vocabulary specifiers" } } +{ $description "Outputs an association list of all vocabularies which have been loaded or are available for loading." } ; + +HELP: load +{ $values { "prefix" string } } +{ $description "Load all vocabularies that match the provided prefix." } +{ $notes "This word differs from " { $link require } " in that it loads all subvocabularies, not just the given one." } ; + +HELP: load-all +{ $description "Load all vocabularies in the source tree." } ; + +HELP: all-vocabs-under +{ $values { "prefix" string } } +{ $description "Return a sequence of vocab or vocab-links for each vocab matching the provided prefix. Unlike " { $link all-child-vocabs } " this word will return both loaded and unloaded vocabularies." } ; diff --git a/basis/tools/vocabs/vocabs-tests.factor b/basis/vocabs/hierarchy/hierarchy-tests.factor similarity index 72% rename from basis/tools/vocabs/vocabs-tests.factor rename to basis/vocabs/hierarchy/hierarchy-tests.factor index a4430c07bc..acbae804d2 100644 --- a/basis/tools/vocabs/vocabs-tests.factor +++ b/basis/vocabs/hierarchy/hierarchy-tests.factor @@ -1,5 +1,5 @@ -IN: tools.vocabs.tests -USING: continuations namespaces tools.test tools.vocabs tools.vocabs.private ; +IN: vocabs.hierarchy.tests +USING: continuations namespaces tools.test vocabs.hierarchy vocabs.hierarchy.private ; [ ] [ changed-vocabs get-global diff --git a/basis/vocabs/hierarchy/hierarchy.factor b/basis/vocabs/hierarchy/hierarchy.factor new file mode 100644 index 0000000000..046ccb8c2d --- /dev/null +++ b/basis/vocabs/hierarchy/hierarchy.factor @@ -0,0 +1,99 @@ +! Copyright (C) 2007, 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays assocs combinators.short-circuit fry +io.directories io.files io.files.info io.pathnames kernel make +memoize namespaces sequences sorting splitting vocabs sets +vocabs.loader vocabs.metadata vocabs.errors ; +IN: vocabs.hierarchy + +vocab-link , ] when + vocabs-in-dir + ] with each ; + +PRIVATE> + +: all-vocabs ( -- assoc ) + vocab-roots get [ + dup [ "" vocabs-in-dir ] { } make + ] { } map>assoc ; + +: all-vocabs-under ( prefix -- vocabs ) + [ + [ vocab-roots get ] dip '[ _ vocabs-in-dir ] each + ] { } make ; + +MEMO: all-vocabs-seq ( -- seq ) + "" all-vocabs-under ; + + + +: all-child-vocabs ( prefix -- assoc ) + vocab-roots get [ + dup pick (all-child-vocabs) [ >vocab-link ] map + ] { } map>assoc + swap unrooted-child-vocabs f swap 2array suffix ; + +: all-child-vocabs-seq ( prefix -- assoc ) + vocab-roots get swap '[ + dup _ (all-child-vocabs) + [ vocab-dir? ] with filter + ] map concat ; + + + +: (load) ( prefix -- failures ) + all-vocabs-under + filter-unportable + require-all ; + +: load ( prefix -- ) + (load) load-failures. ; + +: load-all ( -- ) + "" load ; + +MEMO: all-tags ( -- seq ) + all-vocabs-seq [ vocab-tags ] gather natural-sort ; + +MEMO: all-authors ( -- seq ) + all-vocabs-seq [ vocab-authors ] gather natural-sort ; \ No newline at end of file diff --git a/basis/vocabs/hierarchy/summary.txt b/basis/vocabs/hierarchy/summary.txt new file mode 100644 index 0000000000..b8d931570e --- /dev/null +++ b/basis/vocabs/hierarchy/summary.txt @@ -0,0 +1 @@ +Searching for vocabularies on disk diff --git a/basis/vocabs/metadata/authors.txt b/basis/vocabs/metadata/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/vocabs/metadata/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/vocabs/metadata/metadata-docs.factor b/basis/vocabs/metadata/metadata-docs.factor new file mode 100644 index 0000000000..002f8534b4 --- /dev/null +++ b/basis/vocabs/metadata/metadata-docs.factor @@ -0,0 +1,44 @@ +USING: help.markup help.syntax strings ; +IN: vocabs.metadata + +ARTICLE: "vocabs.metadata" "Vocabulary metadata" +"Vocabulary summaries:" +{ $subsection vocab-summary } +{ $subsection set-vocab-summary } +"Vocabulary authors:" +{ $subsection vocab-authors } +{ $subsection set-vocab-authors } +"Vocabulary tags:" +{ $subsection vocab-tags } +{ $subsection set-vocab-tags } +{ $subsection add-vocab-tags } +"Getting and setting arbitrary vocabulary metadata:" +{ $subsection vocab-file-contents } +{ $subsection set-vocab-file-contents } ; + +ABOUT: "vocabs.metadata" + +HELP: vocab-file-contents +{ $values { "vocab" "a vocabulary specifier" } { "name" string } { "seq" "a sequence of lines, or " { $link f } } } +{ $description "Outputs the contents of the file named " { $snippet "name" } " from the vocabulary's directory, or " { $link f } " if the file does not exist." } ; + +HELP: set-vocab-file-contents +{ $values { "seq" "a sequence of lines" } { "vocab" "a vocabulary specifier" } { "name" string } } +{ $description "Stores a sequence of lines to the file named " { $snippet "name" } " from the vocabulary's directory." } ; + +HELP: vocab-summary +{ $values { "vocab" "a vocabulary specifier" } { "summary" "a string or " { $link f } } } +{ $description "Outputs a one-line string description of the vocabulary's intended purpose from the " { $snippet "summary.txt" } " file in the vocabulary's directory. Outputs " { $link f } " if the file does not exist." } ; + +HELP: set-vocab-summary +{ $values { "string" "a string or " { $link f } } { "vocab" "a vocabulary specifier" } } +{ $description "Stores a one-line string description of the vocabulary to the " { $snippet "summary.txt" } " file in the vocabulary's directory." } ; + +HELP: vocab-tags +{ $values { "vocab" "a vocabulary specifier" } { "tags" "a sequence of strings" } } +{ $description "Outputs a list of short tags classifying the vocabulary from the " { $snippet "tags.txt" } " file in the vocabulary's directory. Outputs " { $link f } " if the file does not exist." } ; + +HELP: set-vocab-tags +{ $values { "tags" "a sequence of strings" } { "vocab" "a vocabulary specifier" } } +{ $description "Stores a list of short tags classifying the vocabulary to the " { $snippet "tags.txt" } " file in the vocabulary's directory." } ; + diff --git a/basis/vocabs/metadata/metadata.factor b/basis/vocabs/metadata/metadata.factor new file mode 100644 index 0000000000..85a503c7f0 --- /dev/null +++ b/basis/vocabs/metadata/metadata.factor @@ -0,0 +1,70 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs io.encodings.utf8 io.files +io.pathnames kernel make math.parser memoize sequences sets +sorting summary vocabs vocabs.loader ; +IN: vocabs.metadata + +MEMO: vocab-file-contents ( vocab name -- seq ) + vocab-append-path dup + [ dup exists? [ utf8 file-lines ] [ drop f ] if ] when ; + +: set-vocab-file-contents ( seq vocab name -- ) + dupd vocab-append-path [ + utf8 set-file-lines + \ vocab-file-contents reset-memoized + ] [ + "The " swap vocab-name + " vocabulary was not loaded from the file system" + 3append throw + ] ?if ; + +: vocab-summary-path ( vocab -- string ) + vocab-dir "summary.txt" append-path ; + +: vocab-summary ( vocab -- summary ) + dup dup vocab-summary-path vocab-file-contents + [ + vocab-name " vocabulary" append + ] [ + nip first + ] if-empty ; + +M: vocab summary + [ + dup vocab-summary % + " (" % + words>> assoc-size # + " words)" % + ] "" make ; + +M: vocab-link summary vocab-summary ; + +: set-vocab-summary ( string vocab -- ) + [ 1array ] dip + dup vocab-summary-path + set-vocab-file-contents ; + +: vocab-tags-path ( vocab -- string ) + vocab-dir "tags.txt" append-path ; + +: vocab-tags ( vocab -- tags ) + dup vocab-tags-path vocab-file-contents harvest ; + +: set-vocab-tags ( tags vocab -- ) + dup vocab-tags-path set-vocab-file-contents ; + +: add-vocab-tags ( tags vocab -- ) + [ vocab-tags append prune ] keep set-vocab-tags ; + +: vocab-authors-path ( vocab -- string ) + vocab-dir "authors.txt" append-path ; + +: vocab-authors ( vocab -- authors ) + dup vocab-authors-path vocab-file-contents harvest ; + +: set-vocab-authors ( authors vocab -- ) + dup vocab-authors-path set-vocab-file-contents ; + +: unportable? ( vocab -- ? ) + vocab-tags "unportable" swap member? ; \ No newline at end of file diff --git a/basis/vocabs/metadata/summary.txt b/basis/vocabs/metadata/summary.txt new file mode 100644 index 0000000000..eec7fd52e9 --- /dev/null +++ b/basis/vocabs/metadata/summary.txt @@ -0,0 +1 @@ +Managing vocabulary author, tag and summary information diff --git a/basis/vocabs/refresh/authors.txt b/basis/vocabs/refresh/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/vocabs/refresh/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/tools/vocabs/monitor/authors.txt b/basis/vocabs/refresh/monitor/authors.txt similarity index 100% rename from basis/tools/vocabs/monitor/authors.txt rename to basis/vocabs/refresh/monitor/authors.txt diff --git a/basis/tools/vocabs/monitor/monitor-tests.factor b/basis/vocabs/refresh/monitor/monitor-tests.factor similarity index 67% rename from basis/tools/vocabs/monitor/monitor-tests.factor rename to basis/vocabs/refresh/monitor/monitor-tests.factor index 0e767a3d34..86091189a5 100644 --- a/basis/tools/vocabs/monitor/monitor-tests.factor +++ b/basis/vocabs/refresh/monitor/monitor-tests.factor @@ -1,5 +1,5 @@ -USING: tools.test tools.vocabs.monitor io.pathnames ; -IN: tools.vocabs.monitor.tests +USING: tools.test vocabs.refresh.monitor io.pathnames ; +IN: vocabs.refresh.monitor.tests [ "kernel" ] [ "core/kernel/kernel.factor" path>vocab ] unit-test [ "kernel" ] [ "core/kernel/" path>vocab ] unit-test diff --git a/basis/tools/vocabs/monitor/monitor.factor b/basis/vocabs/refresh/monitor/monitor.factor similarity index 80% rename from basis/tools/vocabs/monitor/monitor.factor rename to basis/vocabs/refresh/monitor/monitor.factor index 1914da78b2..1445b9f882 100644 --- a/basis/tools/vocabs/monitor/monitor.factor +++ b/basis/vocabs/refresh/monitor/monitor.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: threads io.files io.pathnames io.monitors init kernel -vocabs vocabs.loader tools.vocabs namespaces continuations -sequences splitting assocs command-line concurrency.messaging -io.backend sets tr accessors ; -IN: tools.vocabs.monitor +USING: accessors assocs command-line concurrency.messaging +continuations init io.backend io.files io.monitors io.pathnames +kernel namespaces sequences sets splitting threads +tr vocabs vocabs.loader vocabs.refresh vocabs.cache ; +IN: vocabs.refresh.monitor TR: convert-separators "/\\" ".." ; @@ -56,4 +56,4 @@ TR: convert-separators "/\\" ".." ; [ "-no-monitors" (command-line) member? [ start-monitor-thread ] unless -] "tools.vocabs.monitor" add-init-hook +] "vocabs.refresh.monitor" add-init-hook diff --git a/basis/tools/vocabs/monitor/summary.txt b/basis/vocabs/refresh/monitor/summary.txt similarity index 100% rename from basis/tools/vocabs/monitor/summary.txt rename to basis/vocabs/refresh/monitor/summary.txt diff --git a/basis/vocabs/refresh/refresh-docs.factor b/basis/vocabs/refresh/refresh-docs.factor new file mode 100644 index 0000000000..5652d2ac6a --- /dev/null +++ b/basis/vocabs/refresh/refresh-docs.factor @@ -0,0 +1,22 @@ +USING: help.markup help.syntax strings ; +IN: vocabs.refresh + +HELP: source-modified? +{ $values { "path" "a pathname string" } { "?" "a boolean" } } +{ $description "Tests if the source file has been modified since it was last loaded. This compares the file's CRC32 checksum of the file's contents against the previously-recorded value." } ; + +HELP: refresh +{ $values { "prefix" string } } +{ $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ; + +HELP: refresh-all +{ $description "Reloads source files and documentation for all loaded vocabularies which have been modified on disk." } ; + +{ refresh refresh-all } related-words + +ARTICLE: "vocabs.refresh" "Runtime code reloading" +"Reloading source files changed on disk:" +{ $subsection refresh } +{ $subsection refresh-all } ; + +ABOUT: "vocabs.refresh" diff --git a/basis/vocabs/refresh/refresh.factor b/basis/vocabs/refresh/refresh.factor new file mode 100644 index 0000000000..9ec89e3102 --- /dev/null +++ b/basis/vocabs/refresh/refresh.factor @@ -0,0 +1,91 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs checksums checksums.crc32 +io.encodings.utf8 io.files kernel namespaces sequences sets +source-files vocabs vocabs.errors vocabs.loader ; +IN: vocabs.refresh + +: source-modified? ( path -- ? ) + dup source-files get at [ + dup path>> + dup exists? [ + utf8 file-lines crc32 checksum-lines + swap checksum>> = not + ] [ + 2drop f + ] if + ] [ + exists? + ] ?if ; + +SYMBOL: changed-vocabs + +: changed-vocab ( vocab -- ) + dup vocab changed-vocabs get and + [ dup changed-vocabs get set-at ] [ drop ] if ; + +: unchanged-vocab ( vocab -- ) + changed-vocabs get delete-at ; + +: unchanged-vocabs ( vocabs -- ) + [ unchanged-vocab ] each ; + +: changed-vocab? ( vocab -- ? ) + changed-vocabs get dup [ key? ] [ 2drop t ] if ; + +: filter-changed ( vocabs -- vocabs' ) + [ changed-vocab? ] filter ; + +SYMBOL: modified-sources +SYMBOL: modified-docs + +: (to-refresh) ( vocab variable loaded? path -- ) + dup [ + swap [ + pick changed-vocab? [ + source-modified? [ get push ] [ 2drop ] if + ] [ 3drop ] if + ] [ drop get push ] if + ] [ 2drop 2drop ] if ; + +: to-refresh ( prefix -- modified-sources modified-docs unchanged ) + [ + V{ } clone modified-sources set + V{ } clone modified-docs set + + child-vocabs [ + [ + [ + [ modified-sources ] + [ vocab source-loaded?>> ] + [ vocab-source-path ] + tri (to-refresh) + ] [ + [ modified-docs ] + [ vocab docs-loaded?>> ] + [ vocab-docs-path ] + tri (to-refresh) + ] bi + ] each + + modified-sources get + modified-docs get + ] + [ modified-docs get modified-sources get append diff ] bi + ] with-scope ; + +: do-refresh ( modified-sources modified-docs unchanged -- ) + unchanged-vocabs + [ + [ [ vocab f >>source-loaded? drop ] each ] + [ [ vocab f >>docs-loaded? drop ] each ] bi* + ] + [ + append prune + [ unchanged-vocabs ] + [ require-all load-failures. ] bi + ] 2bi ; + +: refresh ( prefix -- ) to-refresh do-refresh ; + +: refresh-all ( -- ) "" refresh ; \ No newline at end of file diff --git a/basis/vocabs/refresh/summary.txt b/basis/vocabs/refresh/summary.txt new file mode 100644 index 0000000000..4f75199aa5 --- /dev/null +++ b/basis/vocabs/refresh/summary.txt @@ -0,0 +1 @@ +Reloading changed vocabularies from disk diff --git a/core/alien/dlls/authors.txt b/core/alien/dlls/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/core/alien/dlls/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/core/alien/dlls/dlls.factor b/core/alien/dlls/dlls.factor new file mode 100644 index 0000000000..ca0082c21a --- /dev/null +++ b/core/alien/dlls/dlls.factor @@ -0,0 +1,4 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: ; +IN: alien.dlls diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 7915dc69e0..01e0b18887 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -198,9 +198,10 @@ SYMBOL: interactive-vocabs "tools.test" "tools.threads" "tools.time" - "tools.vocabs" "vocabs" "vocabs.loader" + "vocabs.refresh" + "vocabs.hierarchy" "words" "scratchpad" } interactive-vocabs set-global diff --git a/core/source-files/source-files-docs.factor b/core/source-files/source-files-docs.factor index eb1284cd25..91c039dbae 100644 --- a/core/source-files/source-files-docs.factor +++ b/core/source-files/source-files-docs.factor @@ -3,7 +3,7 @@ definitions quotations compiler.units ; IN: source-files ARTICLE: "source-files" "Source files" -"Words in the " { $vocab-link "source-files" } " vocabulary are used to keep track of loaded source files. This is used to implement " { $link "tools.vocabs" } "." +"Words in the " { $vocab-link "source-files" } " vocabulary are used to keep track of loaded source files. This is used to implement " { $link "vocabs.refresh" } "." $nl "The source file database:" { $subsection source-files } @@ -41,7 +41,7 @@ HELP: record-checksum $low-level-note ; HELP: reset-checksums -{ $description "Resets recorded modification times and CRC32 checksums for all loaded source files, creating a checkpoint for " { $link "tools.vocabs" } "." } ; +{ $description "Resets recorded modification times and CRC32 checksums for all loaded source files, creating a checkpoint for " { $link "vocabs.refresh" } "." } ; HELP: forget-source { $values { "path" "a pathname string" } } diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor index e0d6fd4493..03d234807d 100644 --- a/core/vocabs/loader/loader-docs.factor +++ b/core/vocabs/loader/loader-docs.factor @@ -106,7 +106,7 @@ HELP: reload HELP: require { $values { "vocab" "a vocabulary specifier" } } { $description "Loads a vocabulary if it has not already been loaded." } -{ $notes "To unconditionally reload a vocabulary, use " { $link reload } ". To reload changed source files only, use the words in " { $link "tools.vocabs" } "." } ; +{ $notes "To unconditionally reload a vocabulary, use " { $link reload } ". To reload changed source files only, use the words in " { $link "vocabs.refresh" } "." } ; HELP: run { $values { "vocab" "a vocabulary specifier" } } diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index f7c8a89e8c..88a37cb450 100644 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -1,9 +1,9 @@ -IN: vocabs.loader.tests USING: vocabs.loader tools.test continuations vocabs math kernel arrays sequences namespaces io.streams.string parser source-files words assocs classes.tuple definitions -debugger compiler.units tools.vocabs accessors eval +debugger compiler.units accessors eval combinators vocabs.parser grouping ; +IN: vocabs.loader.tests ! This vocab should not exist, but just in case... [ ] [ diff --git a/extra/benchmark/benchmark.factor b/extra/benchmark/benchmark.factor index 220f16fad5..6c64e34835 100755 --- a/extra/benchmark/benchmark.factor +++ b/extra/benchmark/benchmark.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel vocabs vocabs.loader tools.time tools.vocabs +USING: kernel vocabs vocabs.loader tools.time vocabs.hierarchy arrays assocs io.styles io help.markup prettyprint sequences continuations debugger math namespaces memory ; IN: benchmark diff --git a/extra/benchmark/gc0/authors.txt b/extra/benchmark/gc0/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/benchmark/gc0/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/benchmark/gc0/gc0.factor b/extra/benchmark/gc0/gc0.factor new file mode 100644 index 0000000000..997e8df23f --- /dev/null +++ b/extra/benchmark/gc0/gc0.factor @@ -0,0 +1,9 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays kernel math ; +IN: benchmark.gc0 + +: allocate ( -- obj ) 10 f ; +: gc0 ( -- ) f 60000000 [ allocate nip ] times drop ; + +MAIN: gc0 \ No newline at end of file diff --git a/extra/benchmark/gc2/authors.txt b/extra/benchmark/gc2/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/benchmark/gc2/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/benchmark/gc2/gc2.factor b/extra/benchmark/gc2/gc2.factor new file mode 100644 index 0000000000..58f645aa7f --- /dev/null +++ b/extra/benchmark/gc2/gc2.factor @@ -0,0 +1,24 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays byte-arrays kernel namespaces sequences math memory ; +IN: benchmark.gc2 + +! Runs slowly if clean cards are not unmarked. +SYMBOL: oldies + +: make-old-objects ( -- ) + 1000000 [ 1 f ] replicate oldies set gc + oldies get [ "HI" swap set-first ] each ; + +: allocate ( -- x ) 20000 (byte-array) ; + +: age ( -- ) + 1000 [ allocate drop ] times ; + +: gc2 ( -- ) + [ + make-old-objects + 50000 [ age ] times + ] with-scope ; + +MAIN: gc2 \ No newline at end of file diff --git a/extra/fuel/help/help.factor b/extra/fuel/help/help.factor index 30d6845a9b..6c43e646df 100644 --- a/extra/fuel/help/help.factor +++ b/extra/fuel/help/help.factor @@ -3,8 +3,8 @@ USING: accessors arrays assocs combinators help help.crossref help.markup help.topics io io.streams.string kernel make namespaces -parser prettyprint sequences summary tools.vocabs help.vocabs -vocabs vocabs.loader words see ; +parser prettyprint sequences summary help.vocabs +vocabs vocabs.loader vocabs.hierarchy vocabs.metadata words see ; IN: fuel.help @@ -21,9 +21,9 @@ IN: fuel.help [ see ] with-string-writer ; inline : fuel-methods-str ( word -- str ) - methods dup empty? not [ + methods [ f ] [ [ [ see nl ] each ] with-string-writer - ] [ drop f ] if ; inline + ] if-empty ; inline : fuel-related-words ( word -- seq ) dup "related" word-prop remove ; inline diff --git a/extra/fuel/xref/xref.factor b/extra/fuel/xref/xref.factor index ec06b9892e..160b7212c4 100644 --- a/extra/fuel/xref/xref.factor +++ b/extra/fuel/xref/xref.factor @@ -3,7 +3,7 @@ USING: accessors arrays assocs definitions help.topics io.pathnames kernel math math.order memoize namespaces sequences sets sorting -tools.completion tools.crossref tools.vocabs vocabs vocabs.parser +tools.completion tools.crossref vocabs vocabs.parser vocabs.hierarchy words ; IN: fuel.xref diff --git a/extra/galois-talk/galois-talk.factor b/extra/galois-talk/galois-talk.factor index be713542ed..ba929867e9 100644 --- a/extra/galois-talk/galois-talk.factor +++ b/extra/galois-talk/galois-talk.factor @@ -3,7 +3,7 @@ USING: slides help.markup math arrays hashtables namespaces sequences kernel sequences parser memoize io.encodings.binary locals kernel.private help.vocabs assocs quotations -urls peg.ebnf tools.vocabs tools.annotations tools.crossref +urls peg.ebnf tools.annotations tools.crossref help.topics math.functions compiler.tree.optimizer compiler.cfg.optimizer fry ; IN: galois-talk diff --git a/extra/google-tech-talk/google-tech-talk.factor b/extra/google-tech-talk/google-tech-talk.factor index ab8e72fc76..8e2eeeb1a7 100644 --- a/extra/google-tech-talk/google-tech-talk.factor +++ b/extra/google-tech-talk/google-tech-talk.factor @@ -3,7 +3,7 @@ USING: slides help.markup math arrays hashtables namespaces sequences kernel sequences parser memoize io.encodings.binary locals kernel.private help.vocabs assocs quotations -urls peg.ebnf tools.vocabs tools.annotations tools.crossref +urls peg.ebnf tools.annotations tools.crossref help.topics math.functions compiler.tree.optimizer compiler.cfg.optimizer fry ; IN: google-tech-talk diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor index b255b351f0..e4a9d9da13 100755 --- a/extra/mason/common/common.factor +++ b/extra/mason/common/common.factor @@ -90,8 +90,8 @@ SYMBOL: stamp : ?prepare-build-machine ( -- ) builds/factor exists? [ prepare-build-machine ] unless ; -CONSTANT: load-everything-vocabs-file "load-everything-vocabs" -CONSTANT: load-everything-errors-file "load-everything-errors" +CONSTANT: load-all-vocabs-file "load-everything-vocabs" +CONSTANT: load-all-errors-file "load-everything-errors" CONSTANT: test-all-vocabs-file "test-all-vocabs" CONSTANT: test-all-errors-file "test-all-errors" diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor index 64d31b4368..7707d16299 100644 --- a/extra/mason/report/report.factor +++ b/extra/mason/report/report.factor @@ -89,8 +89,8 @@ IN: mason.report timings-table "Load failures" - load-everything-vocabs-file - load-everything-errors-file + load-all-vocabs-file + load-all-errors-file error-dump "Compiler errors" @@ -120,7 +120,7 @@ IN: mason.report : build-clean? ( -- ? ) { - [ load-everything-vocabs-file eval-file empty? ] + [ load-all-vocabs-file eval-file empty? ] [ test-all-vocabs-file eval-file empty? ] [ help-lint-vocabs-file eval-file empty? ] [ compiler-errors-file eval-file empty? ] diff --git a/extra/mason/test/test.factor b/extra/mason/test/test.factor index 22b932ac5b..d50c77f71b 100644 --- a/extra/mason/test/test.factor +++ b/extra/mason/test/test.factor @@ -3,14 +3,15 @@ USING: accessors assocs benchmark bootstrap.stage2 compiler.errors source-files.errors generic help.html help.lint io.directories io.encodings.utf8 io.files kernel mason.common math namespaces -prettyprint sequences sets sorting tools.test tools.time tools.vocabs -words system io tools.errors locals ; +prettyprint sequences sets sorting tools.test tools.time +words system io tools.errors vocabs.hierarchy vocabs.errors +vocabs.refresh locals ; IN: mason.test : do-load ( -- ) - try-everything - [ keys load-everything-vocabs-file to-file ] - [ load-everything-errors-file utf8 [ load-failures. ] with-file-writer ] + "" (load) + [ keys load-all-vocabs-file to-file ] + [ load-all-errors-file utf8 [ load-failures. ] with-file-writer ] bi ; GENERIC: word-vocabulary ( word -- vocabulary ) diff --git a/extra/otug-talk/otug-talk.factor b/extra/otug-talk/otug-talk.factor index b7256246fe..35a83a63de 100644 --- a/extra/otug-talk/otug-talk.factor +++ b/extra/otug-talk/otug-talk.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: slides help.markup math arrays hashtables namespaces sequences -kernel sequences parser memoize io.encodings.binary locals -kernel.private help.vocabs assocs quotations tools.vocabs +USING: slides help.markup math arrays hashtables namespaces +sequences kernel sequences parser memoize io.encodings.binary +locals kernel.private help.vocabs assocs quotations tools.annotations tools.crossref help.topics math.functions -compiler.tree.optimizer compiler.cfg.optimizer fry ui.gadgets.panes -tetris tetris.game combinators generalizations multiline -sequences.private ; +compiler.tree.optimizer compiler.cfg.optimizer fry +ui.gadgets.panes tetris tetris.game combinators generalizations +multiline sequences.private ; IN: otug-talk : $tetris ( element -- ) diff --git a/extra/vpri-talk/vpri-talk.factor b/extra/vpri-talk/vpri-talk.factor index 1e5c9602b9..4ee499bf50 100644 --- a/extra/vpri-talk/vpri-talk.factor +++ b/extra/vpri-talk/vpri-talk.factor @@ -2,10 +2,10 @@ ! See http://factorcode.org/license.txt for BSD license. USING: slides help.markup math arrays hashtables namespaces sequences kernel sequences parser memoize io.encodings.binary -locals kernel.private help.vocabs assocs quotations -urls peg.ebnf tools.vocabs tools.annotations tools.crossref -help.topics math.functions compiler.tree.optimizer -compiler.cfg.optimizer fry ; +locals kernel.private help.vocabs assocs quotations urls +peg.ebnf tools.annotations tools.crossref help.topics +math.functions compiler.tree.optimizer compiler.cfg.optimizer +fry ; IN: vpri-talk CONSTANT: vpri-slides From 4b52f7d6f25893c42232f877467e54dbb5db76b5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 May 2009 06:44:55 -0500 Subject: [PATCH 40/44] Remove bogus alien.dlls directory --- core/alien/dlls/authors.txt | 1 - core/alien/dlls/dlls.factor | 4 ---- 2 files changed, 5 deletions(-) delete mode 100644 core/alien/dlls/authors.txt delete mode 100644 core/alien/dlls/dlls.factor diff --git a/core/alien/dlls/authors.txt b/core/alien/dlls/authors.txt deleted file mode 100644 index d4f5d6b3ae..0000000000 --- a/core/alien/dlls/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov \ No newline at end of file diff --git a/core/alien/dlls/dlls.factor b/core/alien/dlls/dlls.factor deleted file mode 100644 index ca0082c21a..0000000000 --- a/core/alien/dlls/dlls.factor +++ /dev/null @@ -1,4 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: ; -IN: alien.dlls From 2bfde0250e90bba379e2e73cda04bfd9004a3e30 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 May 2009 08:00:06 -0400 Subject: [PATCH 41/44] Fixing some build issues on Linux with GCC 4.3 --- vm/alien.cpp | 20 +++++++------ vm/code_block.cpp | 68 ++++++++++++++++++++++++++------------------- vm/code_heap.cpp | 65 ++++++++++++++++++++++++------------------- vm/data_gc.cpp | 2 +- vm/debug.cpp | 2 +- vm/errors.cpp | 4 +-- vm/errors.hpp | 4 +-- vm/inline_cache.cpp | 8 ++++-- vm/os-genunix.cpp | 2 +- vm/os-linux.cpp | 2 +- 10 files changed, 100 insertions(+), 77 deletions(-) diff --git a/vm/alien.cpp b/vm/alien.cpp index 7bb458c8cd..6a8c334788 100755 --- a/vm/alien.cpp +++ b/vm/alien.cpp @@ -10,10 +10,12 @@ char *pinned_alien_offset(cell obj) switch(tagged(obj).type()) { case ALIEN_TYPE: - alien *ptr = untag(obj); - if(ptr->expired != F) - general_error(ERROR_EXPIRED,obj,F,NULL); - return pinned_alien_offset(ptr->alien) + ptr->displacement; + { + alien *ptr = untag(obj); + if(ptr->expired != F) + general_error(ERROR_EXPIRED,obj,F,NULL); + return pinned_alien_offset(ptr->alien) + ptr->displacement; + } case F_TYPE: return NULL; default: @@ -165,10 +167,12 @@ VM_C_API char *alien_offset(cell obj) case BYTE_ARRAY_TYPE: return untag(obj)->data(); case ALIEN_TYPE: - alien *ptr = untag(obj); - if(ptr->expired != F) - general_error(ERROR_EXPIRED,obj,F,NULL); - return alien_offset(ptr->alien) + ptr->displacement; + { + alien *ptr = untag(obj); + if(ptr->expired != F) + general_error(ERROR_EXPIRED,obj,F,NULL); + return alien_offset(ptr->alien) + ptr->displacement; + } case F_TYPE: return NULL; default: diff --git a/vm/code_block.cpp b/vm/code_block.cpp index 38a421704b..403d9c33d1 100644 --- a/vm/code_block.cpp +++ b/vm/code_block.cpp @@ -279,21 +279,27 @@ void mark_object_code_block(object *object) switch(object->h.hi_tag()) { case WORD_TYPE: - word *w = (word *)object; - if(w->code) - mark_code_block(w->code); - if(w->profiling) - mark_code_block(w->profiling); - break; + { + word *w = (word *)object; + if(w->code) + mark_code_block(w->code); + if(w->profiling) + mark_code_block(w->profiling); + break; + } case QUOTATION_TYPE: - quotation *q = (quotation *)object; - if(q->compiledp != F) - mark_code_block(q->code); - break; + { + quotation *q = (quotation *)object; + if(q->compiledp != F) + mark_code_block(q->code); + break; + } case CALLSTACK_TYPE: - callstack *stack = (callstack *)object; - iterate_callstack_object(stack,mark_stack_frame_step); - break; + { + callstack *stack = (callstack *)object; + iterate_callstack_object(stack,mark_stack_frame_step); + break; + } } } @@ -318,28 +324,32 @@ void *get_rel_symbol(array *literals, cell index) switch(tagged(symbol).type()) { case BYTE_ARRAY_TYPE: - symbol_char *name = alien_offset(symbol); - void *sym = ffi_dlsym(d,name); - - if(sym) - return sym; - else { - printf("%s\n",name); - return (void *)undefined_symbol; - } - case ARRAY_TYPE: - cell i; - array *names = untag(symbol); - for(i = 0; i < array_capacity(names); i++) - { - symbol_char *name = alien_offset(array_nth(names,i)); + symbol_char *name = alien_offset(symbol); void *sym = ffi_dlsym(d,name); if(sym) return sym; + else + { + printf("%s\n",name); + return (void *)undefined_symbol; + } + } + case ARRAY_TYPE: + { + cell i; + array *names = untag(symbol); + for(i = 0; i < array_capacity(names); i++) + { + symbol_char *name = alien_offset(array_nth(names,i)); + void *sym = ffi_dlsym(d,name); + + if(sym) + return sym; + } + return (void *)undefined_symbol; } - return (void *)undefined_symbol; default: critical_error("Bad symbol specifier",symbol); return (void *)undefined_symbol; diff --git a/vm/code_heap.cpp b/vm/code_heap.cpp index 71105dabcf..5dca29b420 100755 --- a/vm/code_heap.cpp +++ b/vm/code_heap.cpp @@ -80,20 +80,22 @@ PRIMITIVE(modify_code_heap) jit_compile_word(word.value(),data.value(),false); break; case ARRAY_TYPE: - array *compiled_data = data.as().untagged(); - cell literals = array_nth(compiled_data,0); - cell relocation = array_nth(compiled_data,1); - cell labels = array_nth(compiled_data,2); - cell code = array_nth(compiled_data,3); + { + array *compiled_data = data.as().untagged(); + cell literals = array_nth(compiled_data,0); + cell relocation = array_nth(compiled_data,1); + cell labels = array_nth(compiled_data,2); + cell code = array_nth(compiled_data,3); - code_block *compiled = add_code_block( - WORD_TYPE, - code, - labels, - relocation, - literals); + code_block *compiled = add_code_block( + WORD_TYPE, + code, + labels, + relocation, + literals); - word->code = compiled; + word->code = compiled; + } break; default: critical_error("Expected a quotation or an array",data.value()); @@ -141,25 +143,28 @@ void forward_object_xts(void) switch(tagged(obj).type()) { case WORD_TYPE: - word *w = untag(obj); + { + word *w = untag(obj); - if(w->code) - w->code = forward_xt(w->code); - if(w->profiling) - w->profiling = forward_xt(w->profiling); - + if(w->code) + w->code = forward_xt(w->code); + if(w->profiling) + w->profiling = forward_xt(w->profiling); + } break; case QUOTATION_TYPE: - quotation *quot = untag(obj); + { + quotation *quot = untag(obj); - if(quot->compiledp != F) - quot->code = forward_xt(quot->code); - + if(quot->compiledp != F) + quot->code = forward_xt(quot->code); + } break; case CALLSTACK_TYPE: - callstack *stack = untag(obj); - iterate_callstack_object(stack,forward_frame_xt); - + { + callstack *stack = untag(obj); + iterate_callstack_object(stack,forward_frame_xt); + } break; default: break; @@ -185,10 +190,12 @@ void fixup_object_xts(void) update_word_xt(obj); break; case QUOTATION_TYPE: - quotation *quot = untag(obj); - if(quot->compiledp != F) - set_quot_xt(quot,quot->code); - break; + { + quotation *quot = untag(obj); + if(quot->compiledp != F) + set_quot_xt(quot,quot->code); + break; + } default: break; } diff --git a/vm/data_gc.cpp b/vm/data_gc.cpp index 57934f92a6..e26edc9721 100755 --- a/vm/data_gc.cpp +++ b/vm/data_gc.cpp @@ -637,7 +637,7 @@ void clear_gc_stats(void) { int i; for(i = 0; i < MAX_GEN_COUNT; i++) - memset(&stats[i],0,sizeof(stats)); + memset(&stats[i],0,sizeof(gc_stats)); cards_scanned = 0; decks_scanned = 0; diff --git a/vm/debug.cpp b/vm/debug.cpp index f405282098..3cd05711ad 100755 --- a/vm/debug.cpp +++ b/vm/debug.cpp @@ -293,7 +293,7 @@ void dump_code_heap(void) while(scan) { - char *status; + const char *status; switch(scan->status) { case B_FREE: diff --git a/vm/errors.cpp b/vm/errors.cpp index 7da6980ece..f2ba355293 100755 --- a/vm/errors.cpp +++ b/vm/errors.cpp @@ -16,14 +16,14 @@ void out_of_memory(void) exit(1); } -void fatal_error(char* msg, cell tagged) +void fatal_error(const char* msg, cell tagged) { print_string("fatal_error: "); print_string(msg); print_string(": "); print_cell_hex(tagged); nl(); exit(1); } -void critical_error(char* msg, cell tagged) +void critical_error(const char* msg, cell tagged) { print_string("You have triggered a bug in Factor. Please report.\n"); print_string("critical_error: "); print_string(msg); diff --git a/vm/errors.hpp b/vm/errors.hpp index c884770a02..e5968468a5 100755 --- a/vm/errors.hpp +++ b/vm/errors.hpp @@ -23,8 +23,8 @@ enum vm_error_type }; void out_of_memory(void); -void fatal_error(char* msg, cell tagged); -void critical_error(char* msg, cell tagged); +void fatal_error(const char* msg, cell tagged); +void critical_error(const char* msg, cell tagged); PRIMITIVE(die); diff --git a/vm/inline_cache.cpp b/vm/inline_cache.cpp index ea330e863a..5d9fbf069e 100644 --- a/vm/inline_cache.cpp +++ b/vm/inline_cache.cpp @@ -49,9 +49,11 @@ static cell determine_inline_cache_type(array *cache_entries) switch(TAG(klass)) { case FIXNUM_TYPE: - fixnum type = untag_fixnum(klass); - if(type >= HEADER_TYPE) - seen_hi_tag = true; + { + fixnum type = untag_fixnum(klass); + if(type >= HEADER_TYPE) + seen_hi_tag = true; + } break; case ARRAY_TYPE: seen_tuple = true; diff --git a/vm/os-genunix.cpp b/vm/os-genunix.cpp index 1513d6840e..731527d208 100755 --- a/vm/os-genunix.cpp +++ b/vm/os-genunix.cpp @@ -31,7 +31,7 @@ const char *default_image_path(void) const char *iter = path; while(*iter) { len++; iter++; } - char *new_path = safe_malloc(PATH_MAX + SUFFIX_LEN + 1); + char *new_path = (char *)safe_malloc(PATH_MAX + SUFFIX_LEN + 1); memcpy(new_path,path,len + 1); memcpy(new_path + len,SUFFIX,SUFFIX_LEN + 1); return new_path; diff --git a/vm/os-linux.cpp b/vm/os-linux.cpp index c3e10668e7..ecc8973ebe 100644 --- a/vm/os-linux.cpp +++ b/vm/os-linux.cpp @@ -6,7 +6,7 @@ namespace factor /* Snarfed from SBCL linux-so.c. You must free() this yourself. */ const char *vm_executable_path(void) { - char *path = safe_malloc(PATH_MAX + 1); + char *path = (char *)safe_malloc(PATH_MAX + 1); int size = readlink("/proc/self/exe", path, PATH_MAX); if (size < 0) From af5a7b537e2a5b14a6a64f6a2793ee72e65e85b0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 May 2009 07:11:00 -0500 Subject: [PATCH 42/44] Attempt to fix gcc 4.5.0 compile error --- vm/code_block.cpp | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/vm/code_block.cpp b/vm/code_block.cpp index 403d9c33d1..5ebb162f7e 100644 --- a/vm/code_block.cpp +++ b/vm/code_block.cpp @@ -48,21 +48,21 @@ void iterate_relocations(code_block *compiled, relocation_iterator iter) } /* Store a 32-bit value into a PowerPC LIS/ORI sequence */ -static void store_address_2_2(cell *cell, cell value) +static void store_address_2_2(cell *ptr, cell value) { - cell[-1] = ((cell[-1] & ~0xffff) | ((value >> 16) & 0xffff)); - cell[ 0] = ((cell[ 0] & ~0xffff) | (value & 0xffff)); + ptr[-1] = ((ptr[-1] & ~0xffff) | ((value >> 16) & 0xffff)); + ptr[ 0] = ((ptr[ 0] & ~0xffff) | (value & 0xffff)); } /* Store a value into a bitfield of a PowerPC instruction */ -static void store_address_masked(cell *cell, fixnum value, cell mask, fixnum shift) +static void store_address_masked(cell *ptr, fixnum value, cell mask, fixnum shift) { /* This is unaccurate but good enough */ fixnum test = (fixnum)mask >> 1; if(value <= -test || value >= test) critical_error("Value does not fit inside relocation",0); - *cell = ((*cell & ~mask) | ((value >> shift) & mask)); + *ptr = ((*ptr & ~mask) | ((value >> shift) & mask)); } /* Perform a fixup on a code block */ From a7faa2fd039a3f32a54d49dd3094c1aeb4442222 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Mon, 4 May 2009 14:16:42 +0200 Subject: [PATCH 43/44] removed mongodb.tuple.index usage from mongodb.tuple fixed mongodb article to show new define-persistent syntax --- extra/mongodb/mongodb-docs.factor | 4 ++-- extra/mongodb/tuple/tuple.factor | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/mongodb/mongodb-docs.factor b/extra/mongodb/mongodb-docs.factor index ff8a769993..afdb2777fd 100644 --- a/extra/mongodb/mongodb-docs.factor +++ b/extra/mongodb/mongodb-docs.factor @@ -15,9 +15,9 @@ ARTICLE: "mongodb" "MongoDB factor integration" { $heading "Highlevel tuple integration" } "The " { $vocab-link "mongodb.tuple" } " vocabulary lets you define persistent tuples that can be stored to and retrieved from a MongoDB database" { $unchecked-example - "USING: mongodb.driver mongodb.tuple fry ;" + "USING: mongodb.driver mongodb.tuple fry literals ;" "MDBTUPLE: person name age ; " - "person \"persons\" { { \"age\" +fieldindex+ } } define-persistent " + "person \"persons\" { } { $[ \"ageIdx\" [ \"age\" asc ] key-spec ] } define-persistent " "\"db\" \"127.0.0.1\" 27017 " "person new \"Alfred\" >>name 57 >>age" "'[ _ save-tuple person new 57 >>age select-tuple ] with-db" diff --git a/extra/mongodb/tuple/tuple.factor b/extra/mongodb/tuple/tuple.factor index cbde30ca80..9173957979 100644 --- a/extra/mongodb/tuple/tuple.factor +++ b/extra/mongodb/tuple/tuple.factor @@ -1,6 +1,6 @@ USING: accessors assocs classes.mixin classes.tuple classes.tuple.parser compiler.units fry kernel sequences mongodb.driver -mongodb.msg mongodb.tuple.collection mongodb.tuple.index +mongodb.msg mongodb.tuple.collection mongodb.tuple.persistent mongodb.tuple.state strings ; IN: mongodb.tuple From 708c8b50ffbe1b6406d3334e5bd2033f9d2069a7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 May 2009 07:19:32 -0500 Subject: [PATCH 44/44] Config.freebsd fix --- vm/Config.freebsd | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/vm/Config.freebsd b/vm/Config.freebsd index f2387286da..384b2fd57a 100644 --- a/vm/Config.freebsd +++ b/vm/Config.freebsd @@ -1,4 +1,4 @@ -include vmpp/Config.unix -PLAF_DLL_OBJS += vmpp/os-genunix.o vmpp/os-freebsd.o +include vm/Config.unix +PLAF_DLL_OBJS += vm/os-genunix.o vm/os-freebsd.o CFLAGS += -export-dynamic LIBS = -L/usr/local/lib/ -lm $(X11_UI_LIBS)