Merge branch 'master' of git://factorcode.org/git/factor

Conflicts:

	basis/compiler/tree/propagation/transforms/transforms.factor

.gitignore

@@ -8,6 +8,7 @@ Factor/factor
 *.a
 *.dll
 *.lib
+*.res
 *.image
 *.dylib
 factor

GNUmakefile

@@ -0,0 +1,223 @@
+ifdef CONFIG
+	CC = gcc
+	CPP = g++
+	AR = ar
+	LD = ld
+
+	VERSION = 0.92
+
+	BUNDLE = Factor.app
+	LIBPATH = -L/usr/X11R6/lib
+
+	CFLAGS = -Wall $(SITE_CFLAGS)
+
+	ifdef DEBUG
+		CFLAGS += -g -DFACTOR_DEBUG
+	else
+		CFLAGS += -O3
+	endif
+
+	include $(CONFIG)
+
+	ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION)
+	EXECUTABLE = factor$(EXE_SUFFIX)$(EXE_EXTENSION)
+	CONSOLE_EXECUTABLE = factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION)
+
+	DLL_OBJS = $(PLAF_DLL_OBJS) \
+		vm/aging_collector.o \
+		vm/alien.o \
+		vm/arrays.o \
+		vm/bignum.o \
+		vm/booleans.o \
+		vm/byte_arrays.o \
+		vm/callbacks.o \
+		vm/callstack.o \
+		vm/code_blocks.o \
+		vm/code_heap.o \
+		vm/compaction.o \
+		vm/contexts.o \
+		vm/data_heap.o \
+		vm/data_heap_checker.o \
+		vm/debug.o \
+		vm/dispatch.o \
+		vm/entry_points.o \
+		vm/errors.o \
+		vm/factor.o \
+		vm/free_list.o \
+		vm/full_collector.o \
+		vm/gc.o \
+		vm/image.o \
+		vm/inline_cache.o \
+		vm/instruction_operands.o \
+		vm/io.o \
+		vm/jit.o \
+		vm/math.o \
+		vm/nursery_collector.o \
+		vm/object_start_map.o \
+		vm/objects.o \
+		vm/primitives.o \
+		vm/profiler.o \
+		vm/quotations.o \
+		vm/run.o \
+		vm/strings.o \
+		vm/to_tenured_collector.o \
+		vm/tuples.o \
+		vm/utilities.o \
+	        vm/vm.o \
+		vm/words.o
+
+	EXE_OBJS = $(PLAF_EXE_OBJS)
+
+	FFI_TEST_LIBRARY = libfactor-ffi-test$(SHARED_DLL_EXTENSION)
+
+	TEST_OBJS = vm/ffi_test.o
+endif
+
+default:
+	$(MAKE) `./build-support/factor.sh make-target`
+
+help:
+	@echo "Run '$(MAKE)' with one of the following parameters:"
+	@echo ""
+	@echo "freebsd-x86-32"
+	@echo "freebsd-x86-64"
+	@echo "linux-x86-32"
+	@echo "linux-x86-64"
+	@echo "linux-ppc"
+	@echo "linux-arm"
+	@echo "openbsd-x86-32"
+	@echo "openbsd-x86-64"
+	@echo "netbsd-x86-32"
+	@echo "netbsd-x86-64"
+	@echo "macosx-x86-32"
+	@echo "macosx-x86-64"
+	@echo "macosx-ppc"
+	@echo "solaris-x86-32"
+	@echo "solaris-x86-64"
+	@echo "wince-arm"
+	@echo "winnt-x86-32"
+	@echo "winnt-x86-64"
+	@echo ""
+	@echo "Additional modifiers:"
+	@echo ""
+	@echo "DEBUG=1  compile VM with debugging information"
+	@echo "SITE_CFLAGS=...  additional optimization flags"
+	@echo "NO_UI=1  don't link with X11 libraries (ignored on Mac OS X)"
+	@echo "X11=1  force link with X11 libraries instead of Cocoa (only on Mac OS X)"
+
+openbsd-x86-32:
+	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.openbsd.x86.32
+
+openbsd-x86-64:
+	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.openbsd.x86.64
+
+freebsd-x86-32:
+	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.freebsd.x86.32
+
+freebsd-x86-64:
+	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.freebsd.x86.64
+
+netbsd-x86-32:
+	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.netbsd.x86.32
+
+netbsd-x86-64:
+	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.netbsd.x86.64
+
+macosx-ppc:
+	$(MAKE) factor factor-ffi-test macosx.app CONFIG=vm/Config.macosx.ppc
+
+macosx-x86-32:
+	$(MAKE) factor factor-ffi-test macosx.app CONFIG=vm/Config.macosx.x86.32
+
+macosx-x86-64:
+	$(MAKE) factor factor-ffi-test macosx.app CONFIG=vm/Config.macosx.x86.64
+
+linux-x86-32:
+	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.linux.x86.32
+
+linux-x86-64:
+	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.linux.x86.64
+
+linux-ppc:
+	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.linux.ppc
+
+linux-arm:
+	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.linux.arm
+
+solaris-x86-32:
+	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.solaris.x86.32
+
+solaris-x86-64:
+	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.solaris.x86.64
+
+winnt-x86-32:
+	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.windows.nt.x86.32
+	$(MAKE) factor-console CONFIG=vm/Config.windows.nt.x86.32
+
+winnt-x86-64:
+	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.windows.nt.x86.64
+	$(MAKE) factor-console CONFIG=vm/Config.windows.nt.x86.64
+
+wince-arm:
+	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.windows.ce.arm
+
+ifdef CONFIG
+
+macosx.app: factor
+	mkdir -p $(BUNDLE)/Contents/MacOS
+	mkdir -p $(BUNDLE)/Contents/Frameworks
+	mv $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor
+	ln -s Factor.app/Contents/MacOS/factor ./factor
+	cp $(ENGINE) $(BUNDLE)/Contents/Frameworks/$(ENGINE)
+
+	install_name_tool \
+		-change libfactor.dylib \
+		@executable_path/../Frameworks/libfactor.dylib \
+		Factor.app/Contents/MacOS/factor
+
+$(ENGINE): $(DLL_OBJS)
+	$(TOOLCHAIN_PREFIX)$(LINKER) $(ENGINE) $(DLL_OBJS)
+
+factor: $(EXE_OBJS) $(ENGINE)
+	$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
+		$(CFLAGS) -o $(EXECUTABLE) $(EXE_OBJS)
+
+factor-console: $(EXE_OBJS) $(ENGINE)
+	$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
+		$(CFLAGS) $(CFLAGS_CONSOLE) -o $(CONSOLE_EXECUTABLE) $(EXE_OBJS)
+
+factor-ffi-test: $(FFI_TEST_LIBRARY)
+
+$(FFI_TEST_LIBRARY): vm/ffi_test.o
+	$(TOOLCHAIN_PREFIX)$(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o $(FFI_TEST_LIBRARY) $(TEST_OBJS)
+
+vm/resources.o:
+	$(TOOLCHAIN_PREFIX)$(WINDRES) vm/factor.rs vm/resources.o
+
+vm/ffi_test.o: vm/ffi_test.c
+	$(TOOLCHAIN_PREFIX)$(CC) -c $(CFLAGS) $(FFI_TEST_CFLAGS) -o $@ $<
+
+.cpp.o:
+	$(TOOLCHAIN_PREFIX)$(CPP) -c $(CFLAGS) -o $@ $<
+
+.S.o:
+	$(TOOLCHAIN_PREFIX)$(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $<
+
+.mm.o:
+	$(TOOLCHAIN_PREFIX)$(CPP) -c $(CFLAGS) -o $@ $<
+
+.SUFFIXES: .mm
+
+endif
+
+clean:
+	rm -f vm/*.o
+	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}
+
+.PHONY: factor factor-console factor-ffi-test tags clean macosx.app

Makefile

@@ -1,219 +0,0 @@
-CC = gcc
-CPP = g++
-AR = ar
-LD = ld
-
-EXECUTABLE = factor
-CONSOLE_EXECUTABLE = factor-console
-TEST_LIBRARY = factor-ffi-test
-VERSION = 0.92
-
-BUNDLE = Factor.app
-LIBPATH = -L/usr/X11R6/lib
-CFLAGS = -Wall
-
-ifdef DEBUG
-	CFLAGS += -g -DFACTOR_DEBUG
-else
-	CFLAGS += -O3
-endif
-
-ifdef REENTRANT
-	CFLAGS += -DFACTOR_REENTRANT
-endif
-
-CFLAGS += $(SITE_CFLAGS)
-
-ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION)
-
-ifdef CONFIG
-	include $(CONFIG)
-endif
-
-DLL_OBJS = $(PLAF_DLL_OBJS) \
-	vm/aging_collector.o \
-	vm/alien.o \
-	vm/arrays.o \
-	vm/bignum.o \
-	vm/booleans.o \
-	vm/byte_arrays.o \
-	vm/callbacks.o \
-	vm/callstack.o \
-	vm/code_block.o \
-	vm/code_heap.o \
-	vm/compaction.o \
-	vm/contexts.o \
-	vm/data_heap.o \
-	vm/debug.o \
-	vm/dispatch.o \
-	vm/errors.o \
-	vm/factor.o \
-	vm/free_list.o \
-	vm/full_collector.o \
-	vm/gc.o \
-	vm/image.o \
-	vm/inline_cache.o \
-	vm/io.o \
-	vm/jit.o \
-	vm/math.o \
-	vm/nursery_collector.o \
-	vm/object_start_map.o \
-	vm/primitives.o \
-	vm/profiler.o \
-	vm/quotations.o \
-	vm/run.o \
-	vm/strings.o \
-	vm/to_tenured_collector.o \
-	vm/tuples.o \
-	vm/utilities.o \
-        vm/vm.o \
-	vm/words.o
-
-EXE_OBJS = $(PLAF_EXE_OBJS)
-
-TEST_OBJS = vm/ffi_test.o
-
-default:
-	$(MAKE) `./build-support/factor.sh make-target`
-
-help:
-	@echo "Run '$(MAKE)' with one of the following parameters:"
-	@echo ""
-	@echo "freebsd-x86-32"
-	@echo "freebsd-x86-64"
-	@echo "linux-x86-32"
-	@echo "linux-x86-64"
-	@echo "linux-ppc"
-	@echo "linux-arm"
-	@echo "openbsd-x86-32"
-	@echo "openbsd-x86-64"
-	@echo "netbsd-x86-32"
-	@echo "netbsd-x86-64"
-	@echo "macosx-x86-32"
-	@echo "macosx-x86-64"
-	@echo "macosx-ppc"
-	@echo "solaris-x86-32"
-	@echo "solaris-x86-64"
-	@echo "wince-arm"
-	@echo "winnt-x86-32"
-	@echo "winnt-x86-64"
-	@echo ""
-	@echo "Additional modifiers:"
-	@echo ""
-	@echo "DEBUG=1  compile VM with debugging information"
-	@echo "SITE_CFLAGS=...  additional optimization flags"
-	@echo "NO_UI=1  don't link with X11 libraries (ignored on Mac OS X)"
-	@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
-
-openbsd-x86-64:
-	$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.openbsd.x86.64
-
-freebsd-x86-32:
-	$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.freebsd.x86.32
-
-freebsd-x86-64:
-	$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.freebsd.x86.64
-
-netbsd-x86-32:
-	$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.netbsd.x86.32
-
-netbsd-x86-64:
-	$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.netbsd.x86.64
-
-macosx-ppc:
-	$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) macosx.app CONFIG=vm/Config.macosx.ppc
-
-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=vm/Config.macosx.x86.64
-
-linux-x86-32:
-	$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.linux.x86.32
-
-linux-x86-64:
-	$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.linux.x86.64
-
-linux-ppc:
-	$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.linux.ppc
-
-linux-arm:
-	$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.linux.arm
-
-solaris-x86-32:
-	$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.solaris.x86.32
-
-solaris-x86-64:
-	$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/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
-
-winnt-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=vm/Config.windows.ce.arm
-
-macosx.app: factor
-	mkdir -p $(BUNDLE)/Contents/MacOS
-	mkdir -p $(BUNDLE)/Contents/Frameworks
-	mv $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor
-	ln -s Factor.app/Contents/MacOS/factor ./factor
-	cp $(ENGINE) $(BUNDLE)/Contents/Frameworks/$(ENGINE)
-
-	install_name_tool \
-		-change libfactor.dylib \
-		@executable_path/../Frameworks/libfactor.dylib \
-		Factor.app/Contents/MacOS/factor
-
-$(EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS)
-	$(TOOLCHAIN_PREFIX)$(LINKER) $(ENGINE) $(DLL_OBJS)
-	$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
-		$(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
-
-$(CONSOLE_EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS)
-	$(TOOLCHAIN_PREFIX)$(LINKER) $(ENGINE) $(DLL_OBJS)
-	$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
-		$(CFLAGS) $(CFLAGS_CONSOLE) -o factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION) $(EXE_OBJS)
-
-$(TEST_LIBRARY): vm/ffi_test.o
-	$(TOOLCHAIN_PREFIX)$(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o libfactor-ffi-test$(SHARED_DLL_EXTENSION) $(TEST_OBJS)
-
-clean:
-	rm -f vm/*.o
-	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}
-
-vm/resources.o:
-	$(TOOLCHAIN_PREFIX)$(WINDRES) vm/factor.rs vm/resources.o
-
-vm/ffi_test.o: vm/ffi_test.c
-	$(TOOLCHAIN_PREFIX)$(CC) -c $(CFLAGS) $(FFI_TEST_CFLAGS) -o $@ $<
-
-.c.o:
-	$(TOOLCHAIN_PREFIX)$(CC) -c $(CFLAGS) -o $@ $<
-
-.cpp.o:
-	$(TOOLCHAIN_PREFIX)$(CPP) -c $(CFLAGS) -o $@ $<
-
-.S.o:
-	$(TOOLCHAIN_PREFIX)$(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $<
-
-.mm.o:
-	$(TOOLCHAIN_PREFIX)$(CPP) -c $(CFLAGS) -o $@ $<
-
-.PHONY: factor tags clean
-
-.SUFFIXES: .mm

Nmakefile

@@ -0,0 +1,77 @@
+LINK_FLAGS = /nologo shell32.lib
+CL_FLAGS = /nologo /O2 /W3
+
+EXE_OBJS = factor.dll.lib vm\main-windows-nt.obj vm\factor.res
+
+DLL_OBJS = vm\os-windows-nt.obj \
+	vm\os-windows.obj \
+	vm\aging_collector.obj \
+	vm\alien.obj \
+	vm\arrays.obj \
+	vm\bignum.obj \
+	vm\booleans.obj \
+	vm\byte_arrays.obj \
+	vm\callbacks.obj \
+	vm\callstack.obj \
+	vm\code_blocks.obj \
+	vm\code_heap.obj \
+	vm\compaction.obj \
+	vm\contexts.obj \
+	vm\data_heap.obj \
+	vm\data_heap_checker.obj \
+	vm\debug.obj \
+	vm\dispatch.obj \
+	vm\entry_points.obj \
+	vm\errors.obj \
+	vm\factor.obj \
+	vm\free_list.obj \
+	vm\full_collector.obj \
+	vm\gc.obj \
+	vm\image.obj \
+	vm\inline_cache.obj \
+	vm\instruction_operands.obj \
+	vm\io.obj \
+	vm\jit.obj \
+	vm\math.obj \
+	vm\nursery_collector.obj \
+	vm\object_start_map.obj \
+	vm\objects.obj \
+	vm\primitives.obj \
+	vm\profiler.obj \
+	vm\quotations.obj \
+	vm\run.obj \
+	vm\strings.obj \
+	vm\to_tenured_collector.obj \
+	vm\tuples.obj \
+	vm\utilities.obj \
+        vm\vm.obj \
+	vm\words.obj
+
+.cpp.obj:
+	cl /EHsc $(CL_FLAGS) /Fo$@ /c $<
+
+.rs.res:
+	rc $<
+
+all: factor.com factor.exe
+
+factor.dll.lib: $(DLL_OBJS)
+	link $(LINK_FLAGS) /implib:factor.dll.lib /out:factor.dll /dll $(DLL_OBJS)
+
+factor.com: $(EXE_OBJS)
+	link $(LINK_FLAGS) /out:factor.com /SUBSYSTEM:console $(EXE_OBJS)
+
+factor.exe: $(EXE_OBJS)
+	link $(LINK_FLAGS) /out:factor.exe /SUBSYSTEM:windows $(EXE_OBJS)
+
+clean:
+	del vm\*.obj
+	del factor.lib
+	del factor.com
+	del factor.exe
+	del factor.dll
+	del factor.dll.lib
+
+.PHONY: all clean
+
+.SUFFIXES: .rs

basis/alarms/alarms-docs.factor

@@ -1,16 +1,37 @@
+USING: help.markup help.syntax calendar quotations system ;
 IN: alarms
-USING: help.markup help.syntax calendar quotations ;
 
 HELP: alarm
 { $class-description "An alarm. Can be passed to " { $link cancel-alarm } "." } ;
 
+HELP: current-alarm
+{ $description "A symbol that contains the currently executing alarm, availble only to the alarm quotation. One use for this symbol is if a repeated alarm wishes to cancel itself from executing in the future."
+}
+{ $examples
+    { $unchecked-example
+        """USING: alarms calendar io threads ;"""
+        """["""
+        """    "Hi, this should only get printed once..." print flush"""
+        """    current-alarm get cancel-alarm"""
+        """] 1 seconds every"""
+        ""
+    }
+} ;
+
 HELP: add-alarm
-{ $values { "quot" quotation } { "time" timestamp } { "frequency" { $maybe duration } } { "alarm" alarm } }
+{ $values { "quot" quotation } { "start" duration } { "interval" { $maybe "duration/f" } } { "alarm" alarm } }
-{ $description "Creates and registers an alarm. If " { $snippet "frequency" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency. The quotation will be called from the alarm thread." } ;
+{ $description "Creates and registers an alarm to start at " { $snippet "start" } " offset from the current time. If " { $snippet "interval" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency, with scheduling happening before the quotation is called in order to ensure that the next event will happen on time. The quotation will be called from a new thread spawned by the alarm thread. If a repeated alarm's quotation throws an exception, the alarm will not be rescheduled." } ;
 
 HELP: later
 { $values { "quot" quotation } { "duration" duration } { "alarm" alarm } }
-{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } " from now." } ;
+{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "duration" } " offset from now." }
+{ $examples
+    { $unchecked-example
+        "USING: alarms io calendar ;"
+        """[ "Break's over!" print flush ] 15 minutes drop"""
+        ""
+    }
+} ;
 
 HELP: cancel-alarm
 { $values { "alarm" alarm } }
@@ -20,16 +41,29 @@ HELP: every
 { $values
      { "quot" quotation } { "duration" duration }
      { "alarm" alarm } }
-{ $description "Creates and registers an alarm which calls the quotation repeatedly, using " { $snippet "dt" } " as the frequency." } ;
+{ $description "Creates and registers an alarm which calls the quotation repeatedly, using " { $snippet "dt" } " as the frequency. If the quotation throws an exception that is not caught inside it, the alarm scheduler will cancel the alarm and will not reschedule it again." }
+{ $examples
+    { $unchecked-example
+        "USING: alarms io calendar ;"
+        """[ "Hi Buddy." print flush ] 10 seconds every drop"""
+        ""
+    }
+} ;
 
 ARTICLE: "alarms" "Alarms"
-"The " { $vocab-link "alarms" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks without spawning a new thread."
+"The " { $vocab-link "alarms" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks without spawning a new thread. Alarms use " { $link nano-count } ", so they continue to work across system clock changes." $nl
-{ $subsections
+"The alarm class:"
-    alarm
+{ $subsections alarm }
-    add-alarm
+"Register a recurring alarm:"
-    later
+{ $subsections every }
-    cancel-alarm
+"Register a one-time alarm:"
-}
+{ $subsections later }
+"The currently executing alarm:"
+{ $subsections current-alarm }
+"Low-level interface to add alarms:"
+{ $subsections add-alarm }
+"Cancelling an alarm:"
+{ $subsections cancel-alarm }
 "Alarms do not persist across image saves. Saving and restoring an image has the effect of calling " { $link cancel-alarm } " on all " { $link alarm } " instances." ;
 
 ABOUT: "alarms"

basis/alarms/alarms.factor

@@ -1,48 +1,66 @@
 ! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs boxes calendar
+USING: accessors assocs boxes calendar combinators.short-circuit
-combinators.short-circuit fry heaps init kernel math.order
+continuations fry heaps init kernel math.order
-namespaces quotations threads ;
+namespaces quotations threads math system ;
 IN: alarms
 
 TUPLE: alarm
     { quot callable initial: [ ] }
-    { time timestamp }
+    { start integer }
     interval
     { entry box } ;
 
-<PRIVATE
-
 SYMBOL: alarms
 SYMBOL: alarm-thread
+SYMBOL: current-alarm
+
+: cancel-alarm ( alarm -- )
+    entry>> [ alarms get-global heap-delete ] if-box? ;
+
+<PRIVATE
 
 : notify-alarm-thread ( -- )
     alarm-thread get-global interrupt ;
 
-ERROR: bad-alarm-frequency frequency ;
+GENERIC: >nanoseconds ( obj -- duration/f )
-: check-alarm ( frequency/f -- frequency/f )
+M: f >nanoseconds ;
-    dup { [ duration? ] [ not ] } 1|| [ bad-alarm-frequency ] unless ;
+M: real >nanoseconds >integer ;
+M: duration >nanoseconds duration>nanoseconds >integer ;
 
-: <alarm> ( quot time frequency -- alarm )
+: <alarm> ( quot start interval -- alarm )
-    check-alarm <box> alarm boa ;
+    alarm new
+        swap >nanoseconds >>interval
+        swap >nanoseconds nano-count + >>start
+        swap >>quot
+        <box> >>entry ;
 
 : register-alarm ( alarm -- )
-    [ dup time>> alarms get-global heap-push* ]
+    [ dup start>> alarms get-global heap-push* ]
     [ entry>> >box ] bi
     notify-alarm-thread ;
 
-: alarm-expired? ( alarm now -- ? )
+: alarm-expired? ( alarm n -- ? )
-    [ time>> ] dip before=? ;
+    [ start>> ] dip <= ;
 
 : reschedule-alarm ( alarm -- )
-    dup '[ _ interval>> time+ now max ] change-time register-alarm ;
+    dup interval>> nano-count + >>start register-alarm ;
 
 : call-alarm ( alarm -- )
     [ entry>> box> drop ]
-    [ quot>> "Alarm execution" spawn drop ]
+    [ dup interval>> [ reschedule-alarm ] [ drop ] if ]
-    [ dup interval>> [ reschedule-alarm ] [ drop ] if ] tri ;
+    [
+        [ ] [ quot>> ] [ ] tri
+        '[
+            _ current-alarm
+            [
+                _ [ _ dup interval>> [ cancel-alarm ] [ drop ] if rethrow ]
+                recover
+            ] with-variable
+        ] "Alarm execution" spawn drop
+    ] tri ;
 
-: (trigger-alarms) ( alarms now -- )
+: (trigger-alarms) ( alarms n -- )
     over heap-empty? [
         2drop
     ] [
@@ -54,11 +72,10 @@ ERROR: bad-alarm-frequency frequency ;
     ] if ;
 
 : trigger-alarms ( alarms -- )
-    now (trigger-alarms) ;
+    nano-count (trigger-alarms) ;
 
-: next-alarm ( alarms -- timestamp/f )
+: next-alarm ( alarms -- nanos/f )
-    dup heap-empty?
+    dup heap-empty? [ drop f ] [ heap-peek drop start>> ] if ;
-    [ drop f ] [ heap-peek drop time>> ] if ;
 
 : alarm-thread-loop ( -- )
     alarms get-global
@@ -75,18 +92,13 @@ ERROR: bad-alarm-frequency frequency ;
     [ alarm-thread-loop t ] "Alarms" spawn-server
     alarm-thread set-global ;
 
-[ init-alarms ] "alarms" add-init-hook
+[ init-alarms ] "alarms" add-startup-hook
 
 PRIVATE>
 
-: add-alarm ( quot time frequency -- alarm )
+: add-alarm ( quot start interval -- alarm )
     <alarm> [ register-alarm ] keep ;
 
-: later ( quot duration -- alarm )
+: later ( quot duration -- alarm ) f add-alarm ;
-    hence f add-alarm ;
 
-: every ( quot duration -- alarm )
+: every ( quot duration -- alarm ) dup add-alarm ;
-    [ hence ] keep add-alarm ;
-
-: cancel-alarm ( alarm -- )
-    entry>> [ alarms get-global heap-delete ] if-box? ;

basis/alien/arrays/arrays.factor

@@ -20,6 +20,8 @@ M: array heap-size unclip [ array-length ] [ heap-size ] bi* * ;
 
 M: array c-type-align first c-type-align ;
 
+M: array c-type-align-first first c-type-align-first ;
+
 M: array c-type-stack-align? drop f ;
 
 M: array unbox-parameter drop void* unbox-parameter ;
@@ -55,6 +57,9 @@ M: string-type heap-size
 M: string-type c-type-align
     drop void* c-type-align ;
 
+M: string-type c-type-align-first
+    drop void* c-type-align-first ;
+
 M: string-type c-type-stack-align?
     drop void* c-type-stack-align? ;
 

basis/alien/c-types/c-types-docs.factor

@@ -66,12 +66,12 @@ HELP: unbox-return
 { $notes "This is an internal word used by the compiler when compiling callbacks." } ;
 
 HELP: define-deref
-{ $values { "name" "a word name" } }
+{ $values { "c-type" "a C type" } }
 { $description "Defines a word " { $snippet "*name" } " with stack effect " { $snippet "( c-ptr -- value )" } " for reading a value with C type " { $snippet "name" } " stored at an alien pointer." }
 { $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
 
 HELP: define-out
-{ $values { "name" "a word name" } }
+{ $values { "c-type" "a C type" } }
 { $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." } ;
 

basis/alien/c-types/c-types.factor

@@ -30,8 +30,9 @@ TUPLE: abstract-c-type
 { unboxer-quot callable }
 { getter callable }
 { setter callable }
-size
+{ size integer }
-align ;
+{ align integer }
+{ align-first integer } ;
 
 TUPLE: c-type < abstract-c-type
 boxer
@@ -104,10 +105,9 @@ M: word c-type
 
 GENERIC: c-struct? ( c-type -- ? )
 
-M: object c-struct?
+M: object c-struct? drop f ;
-    drop f ;
+
-M: c-type-name c-struct?
+M: c-type-name c-struct? dup void? [ drop f ] [ c-type c-struct? ] if ;
-    dup void? [ drop f ] [ c-type c-struct? ] if ;
 
 ! These words being foldable means that words need to be
 ! recompiled if a C type is redefined. Even so, folding the
@@ -172,6 +172,12 @@ M: abstract-c-type c-type-align align>> ;
 
 M: c-type-name c-type-align c-type c-type-align ;
 
+GENERIC: c-type-align-first ( name -- n )
+
+M: c-type-name c-type-align-first c-type c-type-align-first ;
+
+M: abstract-c-type c-type-align-first align-first>> ;
+
 GENERIC: c-type-stack-align? ( name -- ? )
 
 M: c-type c-type-stack-align? stack-align?>> ;
@@ -212,13 +218,13 @@ M: c-type-name unbox-return c-type unbox-return ;
 
 : little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
 
-GENERIC: heap-size ( name -- size ) foldable
+GENERIC: heap-size ( name -- size )
 
 M: c-type-name heap-size c-type heap-size ;
 
 M: abstract-c-type heap-size size>> ;
 
-GENERIC: stack-size ( name -- size ) foldable
+GENERIC: stack-size ( name -- size )
 
 M: c-type-name stack-size c-type stack-size ;
 
@@ -291,20 +297,17 @@ M: long-long-type box-parameter ( n c-type -- )
 M: long-long-type box-return ( c-type -- )
     f swap box-parameter ;
 
-: define-deref ( name -- )
+: define-deref ( c-type -- )
-    [ CHAR: * prefix "alien.c-types" create ] [ c-getter 0 prefix ] bi
+    [ name>> CHAR: * prefix "alien.c-types" create ] [ c-getter 0 prefix ] bi
     (( c-ptr -- value )) define-inline ;
 
-: define-out ( name -- )
+: define-out ( c-type -- )
-    [ "alien.c-types" constructor-word ]
+    [ name>> "alien.c-types" constructor-word ]
     [ dup c-setter '[ _ heap-size (byte-array) [ 0 @ ] keep ] ] bi
     (( value -- c-ptr )) define-inline ;
 
 : define-primitive-type ( c-type name -- )
-    [ typedef ]
+    [ typedef ] [ define-deref ] [ define-out ] tri ;
-    [ name>> define-deref ]
-    [ name>> define-out ]
-    tri ;
 
 : if-void ( c-type true false -- )
     pick void? [ drop nip call ] [ nip call ] if ; inline
@@ -324,6 +327,13 @@ SYMBOLS:
     ptrdiff_t intptr_t uintptr_t size_t
     char* uchar* ;
 
+: 8-byte-alignment ( c-type -- c-type )
+    {
+        { [ cpu ppc? os macosx? and ] [ 4 >>align 8 >>align-first ] }
+        { [ cpu x86.32? os windows? not and ] [ 4 >>align 4 >>align-first ] }
+        [ 8 >>align 8 >>align-first ]
+    } cond ;
+
 [
     <c-type>
         c-ptr >>class
@@ -332,8 +342,9 @@ SYMBOLS:
         [ [ >c-ptr ] 2dip set-alien-cell ] >>setter
         bootstrap-cell >>size
         bootstrap-cell >>align
+        bootstrap-cell >>align-first
         [ >c-ptr ] >>unboxer-quot
-        "box_alien" >>boxer
+        "allot_alien" >>boxer
         "alien_offset" >>unboxer
     \ void* define-primitive-type
 
@@ -343,8 +354,8 @@ SYMBOLS:
         [ alien-signed-8 ] >>getter
         [ set-alien-signed-8 ] >>setter
         8 >>size
-        cpu x86.32? os windows? not and 4 8 ? >>align
+        8-byte-alignment
-        "box_signed_8" >>boxer
+        "from_signed_8" >>boxer
         "to_signed_8" >>unboxer
     \ longlong define-primitive-type
 
@@ -354,8 +365,8 @@ SYMBOLS:
         [ alien-unsigned-8 ] >>getter
         [ set-alien-unsigned-8 ] >>setter
         8 >>size
-        cpu x86.32? os windows? not and 4 8 ? >>align
+        8-byte-alignment
-        "box_unsigned_8" >>boxer
+        "from_unsigned_8" >>boxer
         "to_unsigned_8" >>unboxer
     \ ulonglong define-primitive-type
 
@@ -366,7 +377,8 @@ SYMBOLS:
         [ set-alien-signed-cell ] >>setter
         bootstrap-cell >>size
         bootstrap-cell >>align
-        "box_signed_cell" >>boxer
+        bootstrap-cell >>align-first
+        "from_signed_cell" >>boxer
         "to_fixnum" >>unboxer
     \ long define-primitive-type
 
@@ -377,7 +389,8 @@ SYMBOLS:
         [ set-alien-unsigned-cell ] >>setter
         bootstrap-cell >>size
         bootstrap-cell >>align
-        "box_unsigned_cell" >>boxer
+        bootstrap-cell >>align-first
+        "from_unsigned_cell" >>boxer
         "to_cell" >>unboxer
     \ ulong define-primitive-type
 
@@ -388,7 +401,8 @@ SYMBOLS:
         [ set-alien-signed-4 ] >>setter
         4 >>size
         4 >>align
-        "box_signed_4" >>boxer
+        4 >>align-first
+        "from_signed_4" >>boxer
         "to_fixnum" >>unboxer
     \ int define-primitive-type
 
@@ -399,7 +413,8 @@ SYMBOLS:
         [ set-alien-unsigned-4 ] >>setter
         4 >>size
         4 >>align
-        "box_unsigned_4" >>boxer
+        4 >>align-first
+        "from_unsigned_4" >>boxer
         "to_cell" >>unboxer
     \ uint define-primitive-type
 
@@ -410,7 +425,8 @@ SYMBOLS:
         [ set-alien-signed-2 ] >>setter
         2 >>size
         2 >>align
-        "box_signed_2" >>boxer
+        2 >>align-first
+        "from_signed_2" >>boxer
         "to_fixnum" >>unboxer
     \ short define-primitive-type
 
@@ -421,7 +437,8 @@ SYMBOLS:
         [ set-alien-unsigned-2 ] >>setter
         2 >>size
         2 >>align
-        "box_unsigned_2" >>boxer
+        2 >>align-first
+        "from_unsigned_2" >>boxer
         "to_cell" >>unboxer
     \ ushort define-primitive-type
 
@@ -432,7 +449,8 @@ SYMBOLS:
         [ set-alien-signed-1 ] >>setter
         1 >>size
         1 >>align
-        "box_signed_1" >>boxer
+        1 >>align-first
+        "from_signed_1" >>boxer
         "to_fixnum" >>unboxer
     \ char define-primitive-type
 
@@ -443,7 +461,8 @@ SYMBOLS:
         [ set-alien-unsigned-1 ] >>setter
         1 >>size
         1 >>align
-        "box_unsigned_1" >>boxer
+        1 >>align-first
+        "from_unsigned_1" >>boxer
         "to_cell" >>unboxer
     \ uchar define-primitive-type
 
@@ -453,7 +472,8 @@ SYMBOLS:
             [ [ >c-bool ] 2dip set-alien-unsigned-4 ] >>setter
             4 >>size
             4 >>align
-            "box_boolean" >>boxer
+            4 >>align-first
+            "from_boolean" >>boxer
             "to_boolean" >>unboxer
     ] [
         <c-type>
@@ -461,10 +481,11 @@ SYMBOLS:
             [ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter
             1 >>size
             1 >>align
-            "box_boolean" >>boxer
+            1 >>align-first
+            "from_boolean" >>boxer
             "to_boolean" >>unboxer
-        \ bool define-primitive-type
     ] if
+    \ bool define-primitive-type
 
     <c-type>
         math:float >>class
@@ -473,7 +494,8 @@ SYMBOLS:
         [ [ >float ] 2dip set-alien-float ] >>setter
         4 >>size
         4 >>align
-        "box_float" >>boxer
+        4 >>align-first
+        "from_float" >>boxer
         "to_float" >>unboxer
         float-rep >>rep
         [ >float ] >>unboxer-quot
@@ -485,8 +507,8 @@ SYMBOLS:
         [ alien-double ] >>getter
         [ [ >float ] 2dip set-alien-double ] >>setter
         8 >>size
-        cpu x86.32? os windows? not and 4 8 ? >>align
+        8-byte-alignment
-        "box_double" >>boxer
+        "from_double" >>boxer
         "to_double" >>unboxer
         double-rep >>rep
         [ >float ] >>unboxer-quot
@@ -516,6 +538,9 @@ M: ulonglong-2-rep rep-component-type drop ulonglong ;
 M: float-4-rep rep-component-type drop float ;
 M: double-2-rep rep-component-type drop double ;
 
+: rep-length ( rep -- n )
+    16 swap rep-component-type heap-size /i ; foldable
+
 : (unsigned-interval) ( bytes -- from to ) [ 0 ] dip 8 * 2^ 1 - ; foldable
 : unsigned-interval ( c-type -- from to ) heap-size (unsigned-interval) ; foldable
 : (signed-interval) ( bytes -- from to ) 8 * 1 - 2^ [ neg ] [ 1 - ] bi ; foldable
@@ -528,4 +553,6 @@ M: double-2-rep rep-component-type drop double ;
         { [ dup { uchar ushort uint ulong ulonglong } member-eq? ] [ unsigned-interval ] }
     } cond ; foldable
 
-: c-type-clamp ( value c-type -- value' ) c-type-interval clamp ; inline
+: c-type-clamp ( value c-type -- value' )
+    dup { float double } member-eq?
+    [ drop ] [ c-type-interval clamp ] if ; inline

basis/alien/remote-control/remote-control.factor

@@ -19,8 +19,8 @@ IN: alien.remote-control
     dup optimized? [ execute ] [ drop f ] if ; inline
 
 : init-remote-control ( -- )
-    \ eval-callback ?callback 16 setenv
+    \ eval-callback ?callback 16 set-special-object
-    \ yield-callback ?callback 17 setenv
+    \ yield-callback ?callback 17 set-special-object
-    \ sleep-callback ?callback 18 setenv ;
+    \ sleep-callback ?callback 18 set-special-object ;
 
 MAIN: init-remote-control

basis/base64/base64.factor

@@ -13,7 +13,8 @@ ERROR: malformed-base64 ;
     read1 2dup swap member? [ drop read1-ignoring ] [ nip ] if ;
 
 : read-ignoring ( ignoring n -- str )
-    [ drop read1-ignoring ] with map harvest
+    [ drop read1-ignoring ] with { } map-integers
+    [ { f 0 } member? not ] filter
     [ f ] [ >string ] if-empty ;
 
 : ch>base64 ( ch -- ch )
@@ -42,7 +43,7 @@ SYMBOL: column
     [ write1-lines ] each ;
 
 : encode3 ( seq -- )
-    be> 4 <reversed> [
+    be> 4 iota <reversed> [
         -6 * shift HEX: 3f bitand ch>base64 write1-lines
     ] with each ; inline
 

basis/binary-search/binary-search-tests.factor

@@ -1,4 +1,4 @@
-USING: binary-search math.order vectors kernel tools.test ;
+USING: binary-search math.order sequences kernel tools.test ;
 IN: binary-search.tests
 
 [ f ] [ 3 { } [ <=> ] with search drop ] unit-test
@@ -7,7 +7,7 @@ IN: binary-search.tests
 [ 3 ] [ 4 { 1 2 3 4 5 6 } [ <=> ] with search drop ] unit-test
 [ 2 ] [ 3.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test
 [ 4 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test
-[ 10 ] [ 10 20 >vector [ <=> ] with search drop ] unit-test
+[ 10 ] [ 10 20 iota [ <=> ] with search drop ] unit-test
 
 [ t ] [ "hello" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test
 [ 3 ] [ "hey" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test

basis/bit-arrays/bit-arrays-tests.factor

@@ -40,7 +40,7 @@ IN: bit-arrays.tests
     100 [
         drop 100 [ 2 random zero? ] replicate
         dup >bit-array >array =
-    ] all?
+    ] all-integers?
 ] unit-test
 
 [ ?{ f } ] [

basis/bit-arrays/bit-arrays.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.c-types alien.data accessors math alien.accessors kernel
 kernel.private sequences sequences.private byte-arrays
@@ -25,7 +25,7 @@ TUPLE: bit-array
 
 : (set-bits) ( bit-array n -- )
     [ [ length bits>cells ] keep ] dip swap underlying>>
-    '[ 2 shift [ _ _ ] dip set-alien-unsigned-4 ] each ; inline
+    '[ 2 shift [ _ _ ] dip set-alien-unsigned-4 ] each-integer ; inline
 
 : clean-up ( bit-array -- )
     ! Zero bits after the end.
@@ -99,7 +99,7 @@ SYNTAX: ?{ \ } [ >bit-array ] parse-literal ;
     ] if ;
 
 : bit-array>integer ( bit-array -- n )
-    0 swap underlying>> dup length <reversed> [
+    0 swap underlying>> dup length iota <reversed> [
         alien-unsigned-1 swap 8 shift bitor
     ] with each ;
 

basis/bit-vectors/bit-vectors-tests.factor

@@ -4,7 +4,7 @@ IN: bit-vectors.tests
 [ 0 ] [ 123 <bit-vector> length ] unit-test
 
 : do-it ( seq -- )
-    1234 swap [ [ even? ] dip push ] curry each ;
+    1234 swap [ [ even? ] dip push ] curry each-integer ;
 
 [ t ] [
     3 <bit-vector> dup do-it

basis/bootstrap/bootstrap-error.factor

@@ -2,7 +2,8 @@ USING: continuations kernel io debugger vocabs words system namespaces ;
 
 :c
 :error
+
 "listener" vocab
 [ restarts. vocab-main execute ]
-[ die ] if*
+[ error get die ] if*
 1 exit

basis/bootstrap/compiler/compiler.factor

@@ -76,7 +76,7 @@ gc
     "." write flush
 
     {
-        + 2/ < <= > >= shift
+        + * 2/ < <= > >= shift
     } compile-unoptimized
 
     "." write flush

basis/bootstrap/finish-bootstrap.factor

@@ -3,7 +3,7 @@ namespaces eval kernel vocabs.loader io ;
 
 [
     boot
-    do-init-hooks
+    do-startup-hooks
     [
         (command-line) parse-command-line
         load-vocab-roots
@@ -14,4 +14,4 @@ namespaces eval kernel vocabs.loader io ;
         output-stream get [ stream-flush ] when*
         0 exit
     ] [ print-error 1 exit ] recover
-] set-boot-quot
+] set-startup-quot

basis/bootstrap/finish-staging.factor

@@ -1,11 +1,10 @@
-USING: init command-line system namespaces kernel vocabs.loader
+USING: init command-line system namespaces kernel vocabs.loader io ;
-io ;
 
 [
     boot
-    do-init-hooks
+    do-startup-hooks
     (command-line) parse-command-line
     "run" get run
     output-stream get [ stream-flush ] when*
     0 exit
-] set-boot-quot
+] set-startup-quot

basis/bootstrap/image/image.factor

@@ -1,6 +1,6 @@
-! Copyright (C) 2004, 2009 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien arrays byte-arrays generic hashtables
+USING: alien alien.strings arrays byte-arrays generic hashtables
 hashtables.private io io.binary io.files io.encodings.binary
 io.pathnames kernel kernel.private math namespaces make parser
 prettyprint sequences strings sbufs vectors words quotations
@@ -10,7 +10,7 @@ vocabs.loader source-files definitions debugger
 quotations.private combinators combinators.short-circuit
 math.order math.private accessors slots.private
 generic.single.private compiler.units compiler.constants fry
-bootstrap.image.syntax ;
+locals bootstrap.image.syntax generalizations ;
 IN: bootstrap.image
 
 : arch ( os cpu -- arch )
@@ -71,6 +71,9 @@ C: <eq-wrapper> eq-wrapper
 M: eq-wrapper equal?
     over eq-wrapper? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ;
 
+M: eq-wrapper hashcode*
+    nip obj>> identity-hashcode ;
+
 SYMBOL: objects
 
 : cache-eql-object ( obj quot -- value )
@@ -90,7 +93,7 @@ CONSTANT: image-version 4
 
 CONSTANT: data-base 1024
 
-CONSTANT: userenv-size 70
+CONSTANT: special-objects-size 70
 
 CONSTANT: header-size 10
 
@@ -104,31 +107,62 @@ SYMBOL: sub-primitives
 
 SYMBOL: jit-relocations
 
-: compute-offset ( rc -- offset )
+SYMBOL: jit-offset
-    [ building get length ] dip rc-absolute-cell = bootstrap-cell 4 ? - ;
+
+: compute-offset ( -- offset )
+    building get length jit-offset get + ;
 
 : jit-rel ( rc rt -- )
-    over compute-offset 3array jit-relocations get push-all ;
+    compute-offset 3array jit-relocations get push-all ;
+
+SYMBOL: jit-parameters
+
+: jit-parameter ( parameter -- )
+    jit-parameters get push ;
 
 SYMBOL: jit-literals
 
 : jit-literal ( literal -- )
     jit-literals get push ;
 
-: make-jit ( quot -- jit-literals jit-data )
+: jit-vm ( offset rc -- )
+    [ jit-parameter ] dip rt-vm jit-rel ;
+
+: jit-dlsym ( name library rc -- )
+    rt-dlsym jit-rel [ string>symbol jit-parameter ] bi@ ;
+
+:: jit-conditional ( test-quot false-quot -- )
+    [ 0 test-quot call ] B{ } make length :> len
+    building get length jit-offset get + len +
+    [ jit-offset set false-quot call ] B{ } make
+    [ length test-quot call ] [ % ] bi ; inline
+
+: make-jit ( quot -- jit-parameters jit-literals jit-code )
     [
+        0 jit-offset set
+        V{ } clone jit-parameters set
         V{ } clone jit-literals set
         V{ } clone jit-relocations set
         call( -- )
+        jit-parameters get >array
         jit-literals get >array
         jit-relocations get >array
     ] B{ } make prefix ;
 
 : jit-define ( quot name -- )
-    [ make-jit nip ] dip set ;
+    [ make-jit 2nip ] dip set ;
 
 : define-sub-primitive ( quot word -- )
-    [ make-jit 2array ] dip sub-primitives get set-at ;
+    [ make-jit 3array ] dip sub-primitives get set-at ;
+
+: define-combinator-primitive ( quot non-tail-quot tail-quot word -- )
+    [
+        [ make-jit ]
+        [ make-jit 2nip ]
+        [ make-jit 2nip ]
+        tri* 5 narray
+    ] dip
+    sub-primitives get set-at ;
 
 ! The image being constructed; a vector of word-size integers
 SYMBOL: image
@@ -142,57 +176,58 @@ SYMBOL: architecture
 RESET
 
 ! Boot quotation, set in stage1.factor
-USERENV: bootstrap-boot-quot 20
+SPECIAL-OBJECT: bootstrap-startup-quot 20
 
 ! Bootstrap global namesapce
-USERENV: bootstrap-global 21
+SPECIAL-OBJECT: bootstrap-global 21
 
 ! JIT parameters
-USERENV: jit-prolog 23
+SPECIAL-OBJECT: jit-prolog 23
-USERENV: jit-primitive-word 24
+SPECIAL-OBJECT: jit-primitive-word 24
-USERENV: jit-primitive 25
+SPECIAL-OBJECT: jit-primitive 25
-USERENV: jit-word-jump 26
+SPECIAL-OBJECT: jit-word-jump 26
-USERENV: jit-word-call 27
+SPECIAL-OBJECT: jit-word-call 27
-USERENV: jit-word-special 28
+SPECIAL-OBJECT: jit-if-word 28
-USERENV: jit-if-word 29
+SPECIAL-OBJECT: jit-if 29
-USERENV: jit-if 30
+SPECIAL-OBJECT: jit-epilog 30
-USERENV: jit-epilog 31
+SPECIAL-OBJECT: jit-return 31
-USERENV: jit-return 32
+SPECIAL-OBJECT: jit-profiling 32
-USERENV: jit-profiling 33
+SPECIAL-OBJECT: jit-push 33
-USERENV: jit-push-immediate 34
+SPECIAL-OBJECT: jit-dip-word 34
-USERENV: jit-dip-word 35
+SPECIAL-OBJECT: jit-dip 35
-USERENV: jit-dip 36
+SPECIAL-OBJECT: jit-2dip-word 36
-USERENV: jit-2dip-word 37
+SPECIAL-OBJECT: jit-2dip 37
-USERENV: jit-2dip 38
+SPECIAL-OBJECT: jit-3dip-word 38
-USERENV: jit-3dip-word 39
+SPECIAL-OBJECT: jit-3dip 39
-USERENV: jit-3dip 40
+SPECIAL-OBJECT: jit-execute 40
-USERENV: jit-execute-word 41
+SPECIAL-OBJECT: jit-declare-word 41
-USERENV: jit-execute-jump 42
-USERENV: jit-execute-call 43
-USERENV: jit-declare-word 44
 
-USERENV: callback-stub 45
+SPECIAL-OBJECT: c-to-factor-word 42
+SPECIAL-OBJECT: lazy-jit-compile-word 43
+SPECIAL-OBJECT: unwind-native-frames-word 44
+
+SPECIAL-OBJECT: callback-stub 48
 
 ! PIC stubs
-USERENV: pic-load 47
+SPECIAL-OBJECT: pic-load 49
-USERENV: pic-tag 48
+SPECIAL-OBJECT: pic-tag 50
-USERENV: pic-tuple 49
+SPECIAL-OBJECT: pic-tuple 51
-USERENV: pic-check-tag 50
+SPECIAL-OBJECT: pic-check-tag 52
-USERENV: pic-check-tuple 51
+SPECIAL-OBJECT: pic-check-tuple 53
-USERENV: pic-hit 52
+SPECIAL-OBJECT: pic-hit 54
-USERENV: pic-miss-word 53
+SPECIAL-OBJECT: pic-miss-word 55
-USERENV: pic-miss-tail-word 54
+SPECIAL-OBJECT: pic-miss-tail-word 56
 
 ! Megamorphic dispatch
-USERENV: mega-lookup 57
+SPECIAL-OBJECT: mega-lookup 57
-USERENV: mega-lookup-word 58
+SPECIAL-OBJECT: mega-lookup-word 58
-USERENV: mega-miss-word 59
+SPECIAL-OBJECT: mega-miss-word 59
 
 ! Default definition for undefined words
-USERENV: undefined-quot 60
+SPECIAL-OBJECT: undefined-quot 60
 
-: userenv-offset ( symbol -- n )
+: special-object-offset ( symbol -- n )
-    userenvs get at header-size + ;
+    special-objects get at header-size + ;
 
 : emit ( cell -- ) image get push ;
 
@@ -208,7 +243,7 @@ USERENV: undefined-quot 60
 : fixup ( value offset -- ) image get set-nth ;
 
 : heap-size ( -- size )
-    image get length header-size - userenv-size -
+    image get length header-size - special-objects-size -
     bootstrap-cells ;
 
 : here ( -- size ) heap-size data-base + ;
@@ -224,9 +259,11 @@ USERENV: undefined-quot 60
 
 : emit-fixnum ( n -- ) tag-fixnum emit ;
 
+: emit-header ( n -- ) tag-header emit ;
+
 : emit-object ( class quot -- addr )
     [ type-number ] dip over here-as
-    [ swap tag-fixnum emit call align-here ] dip ;
+    [ swap emit-header call align-here ] dip ;
     inline
 
 ! Write an object to the image.
@@ -234,7 +271,7 @@ GENERIC: ' ( obj -- ptr )
 
 ! Image header
 
-: emit-header ( -- )
+: emit-image-header ( -- )
     image-magic emit
     image-version emit
     data-base emit ! relocation base at end of header
@@ -245,10 +282,10 @@ GENERIC: ' ( obj -- ptr )
     0 emit ! pointer to bignum 0
     0 emit ! pointer to bignum 1
     0 emit ! pointer to bignum -1
-    userenv-size [ f ' emit ] times ;
+    special-objects-size [ f ' emit ] times ;
 
-: emit-userenv ( symbol -- )
+: emit-special-object ( symbol -- )
-    [ get ' ] [ userenv-offset ] bi fixup ;
+    [ get ' ] [ special-object-offset ] bi fixup ;
 
 ! Bignums
 
@@ -501,16 +538,18 @@ M: quotation '
     \ dip jit-dip-word set
     \ 2dip jit-2dip-word set
     \ 3dip jit-3dip-word set
-    \ (execute) jit-execute-word set
+    \ inline-cache-miss pic-miss-word set
-    \ inline-cache-miss \ pic-miss-word set
+    \ inline-cache-miss-tail pic-miss-tail-word set
-    \ inline-cache-miss-tail \ pic-miss-tail-word set
+    \ mega-cache-lookup mega-lookup-word set
-    \ mega-cache-lookup \ mega-lookup-word set
+    \ mega-cache-miss mega-miss-word set
-    \ mega-cache-miss \ mega-miss-word set
     \ declare jit-declare-word set
+    \ c-to-factor c-to-factor-word set
+    \ lazy-jit-compile lazy-jit-compile-word set
+    \ unwind-native-frames unwind-native-frames-word set
     [ undefined ] undefined-quot set ;
 
-: emit-userenvs ( -- )
+: emit-special-objects ( -- )
-    userenvs get keys [ emit-userenv ] each ;
+    special-objects get keys [ emit-special-object ] each ;
 
 : fixup-header ( -- )
     heap-size data-heap-size-offset fixup ;
@@ -518,7 +557,7 @@ M: quotation '
 : build-image ( -- image )
     800000 <vector> image set
     20000 <hashtable> objects set
-    emit-header t, 0, 1, -1,
+    emit-image-header t, 0, 1, -1,
     "Building generic words..." print flush
     remake-generics
     "Serializing words..." print flush
@@ -527,8 +566,8 @@ M: quotation '
     emit-jit-data
     "Serializing global namespace..." print flush
     emit-global
-    "Serializing user environment..." print flush
+    "Serializing special object table..." print flush
-    emit-userenvs
+    emit-special-objects
     "Performing word fixups..." print flush
     fixup-words
     "Performing header fixups..." print flush

basis/bootstrap/image/syntax/syntax.factor

@@ -1,14 +1,14 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: parser kernel namespaces assocs words.symbol ;
 IN: bootstrap.image.syntax
 
-SYMBOL: userenvs
+SYMBOL: special-objects
 
-SYNTAX: RESET H{ } clone userenvs set-global ;
+SYNTAX: RESET H{ } clone special-objects set-global ;
 
-SYNTAX: USERENV:
+SYNTAX: SPECIAL-OBJECT:
     CREATE-WORD scan-word
-    [ swap userenvs get set-at ]
+    [ swap special-objects get set-at ]
     [ drop define-symbol ]
     2bi ;

basis/bootstrap/stage2.factor

@@ -35,8 +35,8 @@ SYMBOL: bootstrap-time
 : count-words ( pred -- )
     all-words swap count number>string write ; inline
 
-: print-time ( ms -- )
+: print-time ( us -- )
-    1000 /i
+    1,000,000,000 /i
     60 /mod swap
     number>string write
     " minutes and " write number>string write " seconds." print ;
@@ -56,9 +56,10 @@ SYMBOL: bootstrap-time
     error-continuation set-global
     error set-global ; inline
 
+
 [
     ! We time bootstrap
-    millis
+    nano-count
 
     default-image-name "output-image" set-global
 
@@ -83,14 +84,14 @@ SYMBOL: bootstrap-time
 
     load-components
 
-    millis over - core-bootstrap-time set-global
+    nano-count over - core-bootstrap-time set-global
 
     run-bootstrap-init
 
     f error set-global
     f error-continuation set-global
 
-    millis swap - bootstrap-time set-global
+    nano-count swap - bootstrap-time set-global
     print-report
 
     "deploy-vocab" get [

basis/cairo/cairo.factor

@@ -16,7 +16,7 @@ ERROR: cairo-error message ;
 
 : check-surface ( surface -- ) cairo_surface_status (check-cairo) ;
 
-: width>stride ( width -- stride ) "uint" heap-size * ; inline
+: width>stride ( width -- stride ) uint heap-size * ; inline
 
 : <image-surface> ( data dim -- surface )
     [ CAIRO_FORMAT_ARGB32 ] dip first2 over width>stride

basis/calendar/calendar-docs.factor

@@ -32,7 +32,7 @@ HELP: month-names
 { $warning "Do not use this array for looking up a month name directly. Use month-name instead." } ;
 
 HELP: month-name
-{ $values { "n" integer } { "string" string } }
+{ $values { "obj" { $or integer timestamp } } { "string" string } }
 { $description "Looks up the month name and returns it as a string.  January has an index of 1 instead of zero." } ;
 
 HELP: month-abbreviations
@@ -46,11 +46,11 @@ HELP: month-abbreviation
 
 
 HELP: day-names
-{ $values { "array" array } }
+{ $values { "value" array } }
 { $description "Returns an array with the English names of the days of the week." } ;
 
 HELP: day-name
-{ $values { "n" integer } { "string" string } }
+{ $values { "obj" { $or integer timestamp } } { "string" string } }
 { $description "Looks up the day name and returns it as a string." } ;
 
 HELP: day-abbreviations2
@@ -355,7 +355,7 @@ HELP: before
 
 HELP: <zero>
 { $values { "timestamp" timestamp } }
-{ $description "Outputs a zero timestamp that consists of zeros for every slot.  Used to see if timestamps are valid." } ;
+{ $description "Returns a zero timestamp that consists of zeros for every slot.  Used to see if timestamps are valid." } ;
 
 HELP: valid-timestamp?
 { $values { "timestamp" timestamp } { "?" "a boolean" } }
@@ -363,7 +363,7 @@ HELP: valid-timestamp?
 
 HELP: unix-1970
 { $values { "timestamp" timestamp } }
-{ $description "Outputs the beginning of UNIX time, or midnight, January 1, 1970." } ;
+{ $description "Returns the beginning of UNIX time, or midnight, January 1, 1970." } ;
 
 HELP: micros>timestamp
 { $values { "x" number } { "timestamp" timestamp } }
@@ -377,13 +377,13 @@ HELP: micros>timestamp
 
 HELP: gmt
 { $values { "timestamp" timestamp } }
-{ $description "Outputs the time right now, but in the GMT timezone." } ;
+{ $description "Returns the time right now, but in the GMT timezone." } ;
 
 { gmt now } related-words
 
 HELP: now
 { $values { "timestamp" timestamp } }
-{ $description "Outputs the time right now in your computer's timezone." }
+{ $description "Returns the time right now in your computer's timezone." }
 { $examples
     { $unchecked-example "USING: calendar prettyprint ;"
         "now ."
@@ -490,23 +490,23 @@ HELP: saturday
 
 HELP: midnight
 { $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
-{ $description "Returns a timestamp that represents today at midnight, or the beginning of the day." } ;
+{ $description "Returns a new timestamp that represents today at midnight, or the beginning of the day." } ;
 
 HELP: noon
 { $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
-{ $description "Returns a timestamp that represents today at noon, or the middle of the day." } ;
+{ $description "Returns a new timestamp that represents today at noon, or the middle of the day." } ;
 
 HELP: beginning-of-month
 { $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
-{ $description "Outputs a timestamp with the day set to one." } ;
+{ $description "Returns a new timestamp with the day set to one." } ;
 
 HELP: beginning-of-week
 { $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
-{ $description "Outputs a timestamp where the day of the week is Sunday." } ;
+{ $description "Returns a new timestamp where the day of the week is Sunday." } ;
 
 HELP: beginning-of-year
-{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
+{ $values { "object" object } { "new-timestamp" timestamp } }
-{ $description "Outputs a timestamp with the month and day set to one, or January 1 of the input timestamp." } ;
+{ $description "Returns a new timestamp with the month and day set to one, or January 1 of the input timestamp, given a year or a timestamp." } ;
 
 HELP: time-since-midnight
 { $values { "timestamp" timestamp } { "duration" duration } }

basis/calendar/calendar-tests.factor

@@ -1,5 +1,6 @@
 USING: arrays calendar kernel math sequences tools.test
-continuations system math.order threads accessors ;
+continuations system math.order threads accessors
+random ;
 IN: calendar.tests
 
 [ f ] [ 2004 12 32 0   0  0 instant <timestamp> valid-timestamp? ] unit-test
@@ -139,7 +140,7 @@ IN: calendar.tests
 [ +gt+ ] [ 2005 1 1 12 30 0 instant <timestamp>
         2004 1 1 13 30 0 instant <timestamp> <=> ] unit-test
 
-[ t ] [ now timestamp>micros micros - 1000000 < ] unit-test
+[ t ] [ now timestamp>micros system-micros - 1000000 < ] unit-test
 [ t ] [ 0 micros>timestamp unix-1970 = ] unit-test
 [ t ] [ 123456789000000 [ micros>timestamp timestamp>micros ] keep = ] unit-test
 [ t ] [ 123456789123456000 [ micros>timestamp timestamp>micros ] keep = ] unit-test
@@ -170,3 +171,8 @@ IN: calendar.tests
 [ f ] [ now dup midnight eq? ] unit-test
 [ f ] [ now dup easter eq? ] unit-test
 [ f ] [ now dup beginning-of-year eq? ] unit-test
+
+[ t ] [ 1325376000 unix-time>timestamp 2012 <year-gmt> = ] unit-test
+[ t ] [ 1356998399 unix-time>timestamp 2013 <year-gmt> 1 seconds time- = ] unit-test
+
+[ t ] [ 1500000000 random [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test

basis/calendar/calendar.factor

@@ -17,6 +17,8 @@ TUPLE: duration
 
 C: <duration> duration
 
+: instant ( -- duration ) 0 0 0 0 0 0 <duration> ;
+
 TUPLE: timestamp
     { year integer }
     { month integer }
@@ -34,6 +36,15 @@ C: <timestamp> timestamp
 : <date> ( year month day -- timestamp )
     0 0 0 gmt-offset-duration <timestamp> ;
 
+: <date-gmt> ( year month day -- timestamp )
+    0 0 0 instant <timestamp> ;
+
+: <year> ( year -- timestamp )
+    1 1 <date> ;
+
+: <year-gmt> ( year -- timestamp )
+    1 1 <date-gmt> ;
+
 ERROR: not-a-month ;
 M: not-a-month summary
     drop "Months are indexed starting at 1" ;
@@ -51,8 +62,16 @@ CONSTANT: month-names
         "July" "August" "September" "October" "November" "December"
     }
 
-: month-name ( n -- string )
+<PRIVATE
-    check-month 1 - month-names nth ;
+
+: (month-name) ( n -- string ) 1 - month-names nth ;
+
+PRIVATE>
+
+GENERIC: month-name ( obj -- string )
+
+M: integer month-name check-month 1 - month-names nth ;
+M: timestamp month-name month>> 1 - month-names nth ;
 
 CONSTANT: month-abbreviations
     {
@@ -65,12 +84,8 @@ CONSTANT: month-abbreviations
 
 CONSTANT: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 }
 
-: day-names ( -- array )
+CONSTANT: day-names
-    {
+    { "Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" }
-        "Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"
-    } ;
-
-: day-name ( n -- string ) day-names nth ;
 
 CONSTANT: day-abbreviations2
     { "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" }
@@ -128,8 +143,7 @@ GENERIC: easter ( obj -- obj' )
     32 2 e * + 2 i * + h - k - 7 mod :> l
     a 11 h * + 22 l * + 451 /i :> m
 
-    h l + 7 m * - 114 + 31 /mod 1 + :> ( month day )
+    h l + 7 m * - 114 + 31 /mod 1 + ;
-    month day ;
 
 M: integer easter ( year -- timestamp )
     dup easter-month-day <date> ;
@@ -145,7 +159,6 @@ M: timestamp easter ( timestamp -- timestamp )
 : >time< ( timestamp -- hour minute second )
     [ hour>> ] [ minute>> ] [ second>> ] tri ;
 
-: instant ( -- duration ) 0 0 0 0 0 0 <duration> ;
 : years ( x -- duration ) instant clone swap >>year ;
 : months ( x -- duration ) instant clone swap >>month ;
 : days ( x -- duration ) instant clone swap >>day ;
@@ -157,6 +170,18 @@ M: timestamp easter ( timestamp -- timestamp )
 : microseconds ( x -- duration ) 1000000 / seconds ;
 : nanoseconds ( x -- duration ) 1000000000 / seconds ;
 
+GENERIC: year ( obj -- n )
+M: integer year ;
+M: timestamp year year>> ;
+
+GENERIC: month ( obj -- n )
+M: integer month ;
+M: timestamp month month>> ;
+
+GENERIC: day ( obj -- n )
+M: integer day ;
+M: timestamp day day>> ;
+
 GENERIC: leap-year? ( obj -- ? )
 
 M: integer leap-year? ( year -- ? )
@@ -305,6 +330,9 @@ GENERIC: time- ( time1 time2 -- time3 )
 M: timestamp <=> ( ts1 ts2 -- n )
     [ >gmt tuple-slots ] compare ;
 
+: same-day? ( ts1 ts2 -- ? )
+    [ >gmt >date< <date> ] bi@ = ;
+
 : (time-) ( timestamp timestamp -- n )
     [ >gmt ] bi@
     [ [ >date< julian-day-number ] bi@ - 86400 * ] 2keep
@@ -357,7 +385,7 @@ M: duration time-
 
 : gmt ( -- timestamp )
     #! GMT time, right now
-    unix-1970 micros microseconds time+ ;
+    unix-1970 system-micros microseconds time+ ;
 
 : now ( -- timestamp ) gmt >local-time ;
 : hence ( duration -- timestamp ) now swap time+ ;
@@ -387,6 +415,10 @@ M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
 : day-of-week ( timestamp -- n )
     >date< zeller-congruence ;
 
+GENERIC: day-name ( obj -- string )
+M: integer day-name day-names nth ;
+M: timestamp day-name day-of-week day-names nth ;
+
 :: (day-of-year) ( year month day -- n )
     day-counts month head-slice sum day +
     year leap-year? [
@@ -398,22 +430,6 @@ M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
 : day-of-year ( timestamp -- n )
     >date< (day-of-year) ;
 
-<PRIVATE
-: day-offset ( timestamp m -- timestamp n )
-    over day-of-week - ; inline
-
-: day-this-week ( timestamp n -- timestamp )
-    day-offset days time+ ;
-PRIVATE>
-
-: sunday ( timestamp -- new-timestamp ) 0 day-this-week ;
-: monday ( timestamp -- new-timestamp ) 1 day-this-week ;
-: tuesday ( timestamp -- new-timestamp ) 2 day-this-week ;
-: wednesday ( timestamp -- new-timestamp ) 3 day-this-week ;
-: thursday ( timestamp -- new-timestamp ) 4 day-this-week ;
-: friday ( timestamp -- new-timestamp ) 5 day-this-week ;
-: saturday ( timestamp -- new-timestamp ) 6 day-this-week ;
-
 : midnight ( timestamp -- new-timestamp )
     clone 0 >>hour 0 >>minute 0 >>second ; inline
 
@@ -423,11 +439,108 @@ PRIVATE>
 : beginning-of-month ( timestamp -- new-timestamp )
     midnight 1 >>day ;
 
+: end-of-month ( timestamp -- new-timestamp )
+    [ midnight ] [ days-in-month ] bi >>day ;
+
+<PRIVATE
+
+: day-offset ( timestamp m -- new-timestamp n )
+    over day-of-week - ; inline
+
+: day-this-week ( timestamp n -- new-timestamp )
+    day-offset days time+ ;
+
+:: nth-day-this-month ( timestamp n day -- new-timestamp )
+    timestamp beginning-of-month day day-this-week
+    dup timestamp [ month>> ] bi@ = [ 1 weeks time+ ] unless
+    n 1 - [ weeks time+ ] unless-zero ;
+
+: last-day-this-month ( timestamp day -- new-timestamp )
+    [ 1 months time+ 1 ] dip nth-day-this-month 1 weeks time- ;
+
+PRIVATE>
+
+GENERIC: january ( obj -- timestamp )
+GENERIC: february ( obj -- timestamp )
+GENERIC: march ( obj -- timestamp )
+GENERIC: april ( obj -- timestamp )
+GENERIC: may ( obj -- timestamp )
+GENERIC: june ( obj -- timestamp )
+GENERIC: july ( obj -- timestamp )
+GENERIC: august ( obj -- timestamp )
+GENERIC: september ( obj -- timestamp )
+GENERIC: october ( obj -- timestamp )
+GENERIC: november ( obj -- timestamp )
+GENERIC: december ( obj -- timestamp )
+
+M: integer january 1 1 <date> ;
+M: integer february 2 1 <date> ;
+M: integer march 3 1 <date> ;
+M: integer april 4 1 <date> ;
+M: integer may 5 1 <date> ;
+M: integer june 6 1 <date> ;
+M: integer july 7 1 <date> ;
+M: integer august 8 1 <date> ;
+M: integer september 9 1 <date> ;
+M: integer october 10 1 <date> ;
+M: integer november 11 1 <date> ;
+M: integer december 12 1 <date> ;
+
+M: timestamp january clone 1 >>month ;
+M: timestamp february clone 2 >>month ;
+M: timestamp march clone 3 >>month ;
+M: timestamp april clone 4 >>month ;
+M: timestamp may clone 5 >>month ;
+M: timestamp june clone 6 >>month ;
+M: timestamp july clone 7 >>month ;
+M: timestamp august clone 8 >>month ;
+M: timestamp september clone 9 >>month ;
+M: timestamp october clone 10 >>month ;
+M: timestamp november clone 11 >>month ;
+M: timestamp december clone 12 >>month ;
+
+: sunday ( timestamp -- new-timestamp ) 0 day-this-week ;
+: monday ( timestamp -- new-timestamp ) 1 day-this-week ;
+: tuesday ( timestamp -- new-timestamp ) 2 day-this-week ;
+: wednesday ( timestamp -- new-timestamp ) 3 day-this-week ;
+: thursday ( timestamp -- new-timestamp ) 4 day-this-week ;
+: friday ( timestamp -- new-timestamp ) 5 day-this-week ;
+: saturday ( timestamp -- new-timestamp ) 6 day-this-week ;
+
+: sunday? ( timestamp -- ? ) day-of-week 0 = ;
+: monday? ( timestamp -- ? ) day-of-week 1 = ;
+: tuesday? ( timestamp -- ? ) day-of-week 2 = ;
+: wednesday? ( timestamp -- ? ) day-of-week 3 = ;
+: thursday? ( timestamp -- ? ) day-of-week 4 = ;
+: friday? ( timestamp -- ? ) day-of-week 5 = ;
+: saturday? ( timestamp -- ? ) day-of-week 6 = ;
+
+: sunday-of-month ( timestamp n -- new-timestamp ) 0 nth-day-this-month ;
+: monday-of-month ( timestamp n -- new-timestamp ) 1 nth-day-this-month ;
+: tuesday-of-month ( timestamp n -- new-timestamp ) 2 nth-day-this-month ;
+: wednesday-of-month ( timestamp n -- new-timestamp ) 3 nth-day-this-month ;
+: thursday-of-month ( timestamp n -- new-timestamp ) 4 nth-day-this-month ;
+: friday-of-month ( timestamp n -- new-timestamp ) 5 nth-day-this-month ;
+: saturday-of-month ( timestamp n -- new-timestamp ) 6 nth-day-this-month ;
+
+: last-sunday-of-month ( timestamp -- new-timestamp ) 0 last-day-this-month ;
+: last-monday-of-month ( timestamp -- new-timestamp ) 1 last-day-this-month ;
+: last-tuesday-of-month ( timestamp -- new-timestamp ) 2 last-day-this-month ;
+: last-wednesday-of-month ( timestamp -- new-timestamp ) 3 last-day-this-month ;
+: last-thursday-of-month ( timestamp -- new-timestamp ) 4 last-day-this-month ;
+: last-friday-of-month ( timestamp -- new-timestamp ) 5 last-day-this-month ;
+: last-saturday-of-month ( timestamp -- new-timestamp ) 6 last-day-this-month ;
+
 : beginning-of-week ( timestamp -- new-timestamp )
     midnight sunday ;
 
-: beginning-of-year ( timestamp -- new-timestamp )
+GENERIC: beginning-of-year ( object -- new-timestamp )
-    beginning-of-month 1 >>month ;
+M: timestamp beginning-of-year beginning-of-month 1 >>month ;
+M: integer beginning-of-year <year> ;
+
+GENERIC: end-of-year ( object -- new-timestamp )
+M: timestamp end-of-year 12 >>month 31 >>day ;
+M: integer end-of-year 12 31 <date> ;
 
 : time-since-midnight ( timestamp -- duration )
     dup midnight time- ;
@@ -435,9 +548,14 @@ PRIVATE>
 : since-1970 ( duration -- timestamp )
     unix-1970 time+ >local-time ;
 
-M: timestamp sleep-until timestamp>micros sleep-until ;
+: timestamp>unix-time ( timestamp -- seconds )
+    unix-1970 time- second>> ;
 
-M: duration sleep hence sleep-until ;
+: unix-time>timestamp ( seconds -- timestamp )
+    seconds unix-1970 time+ ;
+
+M: duration sleep
+    duration>nanoseconds >integer nano-count + sleep-until ;
 
 {
     { [ os unix? ] [ "calendar.unix" ] }

basis/calendar/format/format.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math math.order math.parser math.functions kernel
 sequences io accessors arrays io.streams.string splitting
@@ -70,7 +70,7 @@ M: array month. ( pair -- )
     [
         [ 1 + day. ] keep
         1 + + 7 mod zero? [ nl ] [ bl ] if
-    ] with each nl ;
+    ] with each-integer nl ;
 
 M: timestamp month. ( timestamp -- )
     [ year>> ] [ month>> ] bi 2array month. ;
@@ -78,7 +78,7 @@ M: timestamp month. ( timestamp -- )
 GENERIC: year. ( obj -- )
 
 M: integer year. ( n -- )
-    12 [ 1 + 2array month. nl ] with each ;
+    12 [ 1 + 2array month. nl ] with each-integer ;
 
 M: timestamp year. ( timestamp -- )
     year>> year. ;

basis/calendar/model/model.factor

@@ -16,4 +16,4 @@ SYMBOL: time
     ] "Time model update" spawn drop ;
 
 f <model> time set-global
-[ time-thread ] "calendar.model" add-init-hook
+[ time-thread ] "calendar.model" add-startup-hook

basis/calendar/unix/unix.factor

@@ -14,6 +14,9 @@ IN: calendar.unix
 : timespec>seconds ( timespec -- seconds )
     [ sec>> seconds ] [ nsec>> nanoseconds ] bi time+ ;
 
+: timespec>nanoseconds ( timespec -- seconds )
+    [ sec>> 1000000000 * ] [ nsec>> ] bi + ;
+
 : timespec>unix-time ( timespec -- timestamp )
     timespec>seconds since-1970 ;
 

basis/channels/remote/remote.factor

@@ -69,4 +69,4 @@ M: remote-channel from ( remote-channel -- value )
 [
     H{ } clone \ remote-channels set-global
     start-channel-node
-] "channel-registry" add-init-hook
+] "channel-registry" add-startup-hook

basis/checksums/sha/sha.factor

@@ -301,7 +301,7 @@ GENERIC: pad-initial-bytes ( string sha2 -- padded-string )
         M cloned-H sha2 T1-256
         cloned-H T2-256
         cloned-H update-H
-    ] each
+    ] each-integer
     sha2 [ cloned-H [ w+ ] 2map ] change-H drop ; inline
 
 M: sha2-short checksum-block
@@ -391,7 +391,7 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array )
         b H nth-unsafe 30 bitroll-32 c H set-nth-unsafe
         a H nth-unsafe b H set-nth-unsafe
         a H set-nth-unsafe
-    ] each
+    ] each-integer
     state [ H [ w+ ] 2map ] change-H drop ; inline
 
 M:: sha1-state checksum-block ( bytes state -- )

basis/circular/circular-docs.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: help.markup help.syntax io.streams.string sequences
-math kernel ;
+math kernel quotations ;
 IN: circular
 
 HELP: <circular-string>
@@ -33,12 +33,12 @@ HELP: circular
 HELP: growing-circular
 { $description "A circular sequence that is growable." } ;
 
-HELP: push-circular
+HELP: circular-push
 { $values
      { "elt" object } { "circular" circular } }
 { $description "Pushes an element to a " { $link circular } " object." } ;
 
-HELP: push-growing-circular
+HELP: growing-circular-push
 { $values
      { "elt" object } { "circular" circular } }
 { $description "Pushes an element onto a " { $link growing-circular } " object." } ;
@@ -48,6 +48,13 @@ HELP: rotate-circular
     { "circular" circular } }
 { $description "Advances the start index of a circular object by one." } ;
 
+HELP: circular-while
+{ $values
+    { "circular" circular }
+    { "quot" quotation }
+}
+{ $description "Calls " { $snippet "quot" } " on each element of the sequence until each call yields " { $link f } " in succession." } ;
+
 ARTICLE: "circular" "Circular sequences"
 "The " { $vocab-link "circular" } " vocabulary implements the " { $link "sequence-protocol" } " to allow an arbitrary start index and wrap-around indexing." $nl
 "Creating a new circular object:"
@@ -63,8 +70,10 @@ ARTICLE: "circular" "Circular sequences"
 }
 "Pushing new elements:"
 { $subsections
-    push-circular
+    circular-push
-    push-growing-circular
+    growing-circular-push
-} ;
+}
+"Iterating over a circular until a stop condition:"
+{ $subsections circular-while } ;
 
 ABOUT: "circular"

basis/circular/circular-tests.factor

@@ -23,7 +23,7 @@ IN: circular.tests
 [ "boo" ] [ "foo" <circular> CHAR: b 3 pick set-nth-unsafe >string ] unit-test
 [ "ornact" ] [ "factor" <circular> 4 over change-circular-start CHAR: n 2 pick set-nth >string ] unit-test
 
-[ "bcd" ] [ 3 <circular-string> "abcd" [ over push-circular ] each >string ] unit-test
+[ "bcd" ] [ 3 <circular-string> "abcd" [ over circular-push ] each >string ] unit-test
 
 [ { 0 0 } ] [ { 0 0 } <circular> -1 over change-circular-start >array ] unit-test
 
@@ -34,11 +34,11 @@ IN: circular.tests
 [ { } ] [ 3 <growing-circular> >array ] unit-test
 [ { 1 2 } ] [
     3 <growing-circular>
-    [ 1 swap push-growing-circular ] keep
+    [ 1 swap growing-circular-push ] keep
-    [ 2 swap push-growing-circular ] keep >array
+    [ 2 swap growing-circular-push ] keep >array
 ] unit-test
 [ { 3 4 5 } ] [
     3 <growing-circular> dup { 1 2 3 4 5 } [
-        swap push-growing-circular
+        swap growing-circular-push
     ] with each >array
 ] unit-test

basis/circular/circular.factor

@@ -1,57 +1,79 @@
 ! Copyright (C) 2005, 2006 Alex Chapman, Daniel Ehrenberg
 ! See http;//factorcode.org/license.txt for BSD license
 USING: kernel sequences math sequences.private strings
-accessors ;
+accessors locals fry ;
 IN: circular
 
-! a circular sequence wraps another sequence, but begins at an
+TUPLE: circular { seq read-only } { start integer } ;
-! arbitrary element in the underlying sequence.
-TUPLE: circular seq start ;
 
 : <circular> ( seq -- circular )
-    0 circular boa ;
+    0 circular boa ; inline
 
 <PRIVATE
+
 : circular-wrap ( n circular -- n circular )
     [ start>> + ] keep
     [ seq>> length rem ] keep ; inline
+
 PRIVATE>
 
-M: circular length seq>> length ;
+M: circular length seq>> length ; inline
 
-M: circular virtual@ circular-wrap seq>> ;
+M: circular virtual@ circular-wrap seq>> ; inline
 
-M: circular virtual-seq seq>> ;
+M: circular virtual-exemplar seq>> ; inline
 
 : change-circular-start ( n circular -- )
     #! change start to (start + n) mod length
-    circular-wrap (>>start) ;
+    circular-wrap (>>start) ; inline
 
 : rotate-circular ( circular -- )
-    [ 1 ] dip change-circular-start ;
+    [ 1 ] dip change-circular-start ; inline
 
-: push-circular ( elt circular -- )
+: circular-push ( elt circular -- )
     [ set-first ] [ rotate-circular ] bi ;
 
 : <circular-string> ( n -- circular )
-    0 <string> <circular> ;
+    0 <string> <circular> ; inline
 
 INSTANCE: circular virtual-sequence
 
-TUPLE: growing-circular < circular length ;
+TUPLE: growing-circular < circular { length integer } ;
 
-M: growing-circular length length>> ;
+M: growing-circular length length>> ; inline
 
 <PRIVATE
 
 : full? ( circular -- ? )
-    [ length ] [ seq>> length ] bi = ;
+    [ length ] [ seq>> length ] bi = ; inline
 
 PRIVATE>
 
-: push-growing-circular ( elt circular -- )
+: growing-circular-push ( elt circular -- )
-    dup full? [ push-circular ]
+    dup full? [ circular-push ]
     [ [ 1 + ] change-length set-last ] if ;
 
 : <growing-circular> ( capacity -- growing-circular )
-    { } new-sequence 0 0 growing-circular boa ;
+    { } new-sequence 0 0 growing-circular boa ; inline
+
+TUPLE: circular-iterator
+    { circular read-only } { n integer } { last-start integer } ;
+
+: <circular-iterator> ( circular -- obj )
+    0 0 circular-iterator boa ; inline
+
+<PRIVATE
+
+: (circular-while) ( iterator quot: ( obj -- ? ) -- )
+    [ [ [ n>> ] [ circular>> ] bi nth ] dip call ] 2keep
+    rot [ [ dup n>> >>last-start ] dip ] when
+    over [ n>> ] [ [ last-start>> ] [ circular>> length ] bi + 1 - ] bi = [
+        2drop
+    ] [
+        [ [ 1 + ] change-n ] dip (circular-while)
+    ] if ; inline recursive
+
+PRIVATE>
+
+: circular-while ( circular quot: ( obj -- ? ) -- )
+    [ clone ] dip [ <circular-iterator> ] dip (circular-while) ; inline

basis/classes/struct/bit-accessors/bit-accessors-tests.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2009 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
-USING: classes.struct.bit-accessors tools.test effects kernel random stack-checker ;
+USING: classes.struct.bit-accessors tools.test effects kernel
+sequences random stack-checker ;
 IN: classes.struct.bit-accessors.test
 
 [ t ] [ 20 random 20 random bit-reader infer (( alien -- n )) effect= ] unit-test

basis/classes/struct/struct-tests.factor

@@ -365,3 +365,18 @@ STRUCT: bit-field-test
 [ -2 ] [ bit-field-test <struct> 2 >>b b>> ] unit-test
 [ 1 ] [ bit-field-test <struct> 257 >>c c>> ] unit-test
 [ 3 ] [ bit-field-test heap-size ] unit-test
+
+cpu ppc? [
+    STRUCT: ppc-align-test-1
+        { x longlong }
+        { y int } ;
+
+    [ 16 ] [ ppc-align-test-1 heap-size ] unit-test
+
+    STRUCT: ppc-align-test-2
+        { y int }
+        { x longlong } ;
+
+    [ 12 ] [ ppc-align-test-2 heap-size ] unit-test
+    [ 4 ] [ "x" ppc-align-test-2 offset-of ] unit-test
+] when

basis/classes/struct/struct.factor

@@ -189,9 +189,6 @@ M: struct-c-type c-struct? drop t ;
     \ cleave [ ] 2sequence
     \ output>array [ ] 2sequence ;
 
-: define-inline-method ( class generic quot -- )
-    [ create-method-in ] dip [ define ] [ drop make-inline ] 2bi ;
-
 : (define-struct-slot-values-method) ( class -- )
     [ \ struct-slot-values ] [ struct-slot-values-quot ] bi
     define-inline-method ;
@@ -211,27 +208,32 @@ M: struct-c-type c-struct? drop t ;
         slots >>fields
         size >>size
         align >>align
+        align >>align-first
         class (unboxer-quot) >>unboxer-quot
         class (boxer-quot) >>boxer-quot ;
 
-GENERIC: align-offset ( offset class -- offset' )
+GENERIC: compute-slot-offset ( offset class -- offset' )
 
-M: struct-slot-spec align-offset
+: c-type-align-at ( class offset -- n )
-    [ type>> c-type-align 8 * align ] keep
+    0 = [ c-type-align-first ] [ c-type-align ] if ;
+
+M: struct-slot-spec compute-slot-offset
+    [ type>> over c-type-align-at 8 * align ] keep
     [ [ 8 /i ] dip (>>offset) ] [ type>> heap-size 8 * + ] 2bi ;
 
-M: struct-bit-slot-spec align-offset
+M: struct-bit-slot-spec compute-slot-offset
     [ (>>offset) ] [ bits>> + ] 2bi ;
 
-: struct-offsets ( slots -- size )
+: compute-struct-offsets ( slots -- size )
-    0 [ align-offset ] reduce 8 align 8 /i ;
+    0 [ compute-slot-offset ] reduce 8 align 8 /i ;
 
-: union-struct-offsets ( slots -- size )
+: compute-union-offsets ( slots -- size )
     1 [ 0 >>offset type>> heap-size max ] reduce ;
 
-: struct-align ( slots -- align )
+: struct-alignment ( slots -- align )
     [ struct-bit-slot-spec? not ] filter
-    1 [ type>> c-type-align max ] reduce ;
+    1 [ [ type>> ] [ offset>> ] bi c-type-align-at max ] reduce ;
+
 PRIVATE>
 
 M: struct byte-length class "struct-size" word-prop ; foldable
@@ -243,10 +245,8 @@ GENERIC: binary-zero? ( value -- ? )
 
 M: object binary-zero? drop f ;
 M: f binary-zero? drop t ;
-M: number binary-zero? zero? ;
+M: number binary-zero? 0 = ;
-M: struct binary-zero?
+M: struct binary-zero? >c-ptr [ 0 = ] all? ;
-    [ byte-length iota ] [ >c-ptr ] bi
-    [ <displaced-alien> *uchar zero? ] curry all? ;
 
 : struct-needs-prototype? ( class -- ? )
     struct-slots [ initial>> binary-zero? ] all? not ;
@@ -278,8 +278,9 @@ M: struct binary-zero?
     slots empty? [ struct-must-have-slots ] when
     class redefine-struct-tuple-class
     slots make-slots dup check-struct-slots :> slot-specs
-    slot-specs struct-align :> alignment
+    slot-specs offsets-quot call :> unaligned-size
-    slot-specs offsets-quot call alignment align :> size
+    slot-specs struct-alignment :> alignment
+    unaligned-size alignment align :> size
 
     class  slot-specs  size  alignment  c-type-for-class :> c-type
 
@@ -291,10 +292,10 @@ M: struct binary-zero?
 PRIVATE>
 
 : define-struct-class ( class slots -- )
-    [ struct-offsets ] (define-struct-class) ;
+    [ compute-struct-offsets ] (define-struct-class) ;
 
 : define-union-struct-class ( class slots -- )
-    [ union-struct-offsets ] (define-struct-class) ;
+    [ compute-union-offsets ] (define-struct-class) ;
 
 M: struct-class reset-class
     [ call-next-method ] [ name>> c-types get delete-at ] bi ;

basis/cocoa/application/application.factor

@@ -49,7 +49,7 @@ TUPLE: objc-error alien reason ;
 M: objc-error summary ( error -- )
     drop "Objective C exception" ;
 
-[ [ objc-error ] 19 setenv ] "cocoa.application" add-init-hook
+[ [ objc-error ] 19 set-special-object ] "cocoa.application" add-startup-hook
 
 : running.app? ( -- ? )
     #! Test if we're running a .app.

basis/cocoa/cocoa.factor

@@ -27,7 +27,7 @@ SYMBOL: frameworks
 
 frameworks [ V{ } clone ] initialize
 
-[ frameworks get [ load-framework ] each ] "cocoa" add-init-hook
+[ frameworks get [ load-framework ] each ] "cocoa" add-startup-hook
 
 SYNTAX: FRAMEWORK: scan [ load-framework ] [ frameworks get push ] bi ;
 

basis/cocoa/messages/messages.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2006, 2009 Slava Pestov.
+! Copyright (C) 2006, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien alien.c-types alien.strings arrays assocs
 classes.struct continuations combinators compiler compiler.alien
@@ -76,13 +76,13 @@ MACRO: (send) ( selector super? -- quot )
 : super-send ( receiver args... selector -- return... ) t (send) ; inline
 
 ! Runtime introspection
-SYMBOL: class-init-hooks
+SYMBOL: class-startup-hooks
 
-class-init-hooks [ H{ } clone ] initialize
+class-startup-hooks [ H{ } clone ] initialize
 
 : (objc-class) ( name word -- class )
     2dup execute dup [ 2nip ] [
-        drop over class-init-hooks get at [ call( -- ) ] when*
+        drop over class-startup-hooks get at [ call( -- ) ] when*
         2dup execute dup [ 2nip ] [
             2drop "No such class: " prepend throw
         ] if
@@ -202,7 +202,7 @@ ERROR: no-objc-type name ;
     (free) ;
 
 : method-arg-types ( method -- args )
-    dup method_getNumberOfArguments
+    dup method_getNumberOfArguments iota
     [ method-arg-type ] with map ;
 
 : method-return-type ( method -- ctype )
@@ -229,7 +229,7 @@ ERROR: no-objc-type name ;
 : class-exists? ( string -- class ) objc_getClass >boolean ;
 
 : define-objc-class-word ( quot name -- )
-    [ class-init-hooks get set-at ]
+    [ class-startup-hooks get set-at ]
     [
         [ "cocoa.classes" create ] [ '[ _ objc-class ] ] bi
         (( -- class )) define-declared

basis/columns/columns-tests.factor

@@ -7,3 +7,5 @@ IN: columns.tests
 [ { 1 4 7 } ] [ "seq" get 0 <column> >array ] unit-test
 [ ] [ "seq" get 1 <column> [ sq ] map! drop ] unit-test
 [ { 4 25 64 } ] [ "seq" get 1 <column> >array ] unit-test
+
+[ { { 1 3 } { 2 4 } } ] [ { { 1 2 } { 3 4 } } <flipped> [ >array ] map ] unit-test

basis/columns/columns.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2008 Slava Pestov, Daniel Ehrenberg.
+! Copyright (C) 2005, 2010 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: sequences kernel accessors ;
 IN: columns
@@ -8,11 +8,11 @@ TUPLE: column seq col ;
 
 C: <column> column
 
-M: column virtual-seq seq>> ;
+M: column virtual-exemplar seq>> ;
 M: column virtual@ [ col>> swap ] [ seq>> ] bi nth bounds-check ;
 M: column length seq>> length ;
 
 INSTANCE: column virtual-sequence
 
 : <flipped> ( seq -- seq' )
-    dup empty? [ dup first length [ <column> ] with map ] unless ;
+    dup empty? [ dup first length [ <column> ] with { } map-integers ] unless ;

basis/combinators/smart/smart-tests.factor

@@ -47,3 +47,9 @@ IN: combinators.smart.tests
 [ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test
 
 [ 14 ] [ [ 1 2 3 ] [ sq ] [ + ] map-reduce-outputs ] unit-test
+
+{ 2 3 } [ [ + ] preserving ] must-infer-as
+
+{ 2 0 } [ [ + ] nullary ] must-infer-as
+
+{ 2 2 } [ [ [ + ] nullary ] preserving ] must-infer-as

basis/combinators/smart/smart.factor

@@ -5,46 +5,49 @@ stack-checker math sequences ;
 IN: combinators.smart
 
 MACRO: drop-outputs ( quot -- quot' )
-    dup infer out>> '[ @ _ ndrop ] ;
+    dup outputs '[ @ _ ndrop ] ;
 
 MACRO: keep-inputs ( quot -- quot' )
-    dup infer in>> '[ _ _ nkeep ] ;
+    dup inputs '[ _ _ nkeep ] ;
 
 MACRO: output>sequence ( quot exemplar -- newquot )
-    [ dup infer out>> ] dip
+    [ dup outputs ] dip
     '[ @ _ _ nsequence ] ;
 
 MACRO: output>array ( quot -- newquot )
     '[ _ { } output>sequence ] ;
 
 MACRO: input<sequence ( quot -- newquot )
-    [ infer in>> ] keep
+    [ inputs ] keep
     '[ _ firstn @ ] ;
 
 MACRO: input<sequence-unsafe ( quot -- newquot )
-    [ infer in>> ] keep
+    [ inputs ] keep
     '[ _ firstn-unsafe @ ] ;
 
 MACRO: reduce-outputs ( quot operation -- newquot )
-    [ dup infer out>> 1 [-] ] dip n*quot compose ;
+    [ dup outputs 1 [-] ] dip n*quot compose ;
 
 MACRO: sum-outputs ( quot -- n )
     '[ _ [ + ] reduce-outputs ] ;
 
 MACRO: map-reduce-outputs ( quot mapper reducer -- newquot )
-    [ dup infer out>> ] 2dip
+    [ dup outputs ] 2dip
     [ swap '[ _ _ napply ] ]
     [ [ 1 [-] ] dip n*quot ] bi-curry* bi
     '[ @ @ @ ] ;
 
 MACRO: append-outputs-as ( quot exemplar -- newquot )
-    [ dup infer out>> ] dip '[ @ _ _ nappend-as ] ;
+    [ dup outputs ] dip '[ @ _ _ nappend-as ] ;
 
 MACRO: append-outputs ( quot -- seq )
     '[ _ { } append-outputs-as ] ;
 
 MACRO: preserving ( quot -- )
-    [ infer in>> length ] keep '[ _ ndup @ ] ;
+    [ inputs ] keep '[ _ ndup @ ] ;
+
+MACRO: nullary ( quot -- quot' )
+    dup outputs '[ @ _ ndrop ] ;
 
 MACRO: smart-if ( pred true false -- )
     '[ _ preserving _ _ if ] ; inline

basis/command-line/command-line.factor

@@ -8,7 +8,8 @@ IN: command-line
 SYMBOL: script
 SYMBOL: command-line
 
-: (command-line) ( -- args ) 10 getenv sift [ alien>native-string ] map ;
+: (command-line) ( -- args )
+    10 special-object sift [ alien>native-string ] map ;
 
 : rc-path ( name -- path )
     os windows? [ "." prepend ] unless
@@ -69,4 +70,4 @@ SYMBOL: main-vocab-hook
 : ignore-cli-args? ( -- ? )
     os macosx? "run" get "ui" = and ;
 
-[ default-cli-args ] "command-line" add-init-hook
+[ default-cli-args ] "command-line" add-startup-hook

basis/compiler/cfg/build-stack-frame/build-stack-frame.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces accessors math.order assocs kernel sequences
 combinators make classes words cpu.architecture layouts
@@ -17,13 +17,13 @@ GENERIC: compute-stack-frame* ( insn -- )
 UNION: stack-frame-insn
     ##alien-invoke
     ##alien-indirect
+    ##alien-assembly
     ##alien-callback ;
 
 M: stack-frame-insn compute-stack-frame*
     stack-frame>> request-stack-frame ;
 
-M: ##call compute-stack-frame*
+M: ##call compute-stack-frame* drop frame-required? on ;
-    word>> sub-primitive>> [ frame-required? on ] unless ;
 
 M: ##gc compute-stack-frame*
     frame-required? on

basis/compiler/cfg/builder/builder.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2009 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs combinators hashtables kernel
 math fry namespaces make sequences words byte-arrays
@@ -45,6 +45,12 @@ SYMBOL: loops
         end-stack-analysis
     ] with-scope ; inline
 
+: with-dummy-cfg-builder ( node quot -- )
+    [
+        [ V{ } clone procedures ] 2dip
+        '[ _ t t [ _ call( node -- ) ] with-cfg-builder ] with-variable
+    ] { } make drop ;
+
 GENERIC: emit-node ( node -- )
 
 : emit-nodes ( nodes -- )
@@ -230,13 +236,16 @@ M: #alien-invoke emit-node
 M: #alien-indirect emit-node
     [ ##alien-indirect ] emit-alien-node ;
 
+M: #alien-assembly emit-node
+    [ ##alien-assembly ] emit-alien-node ;
+
 M: #alien-callback emit-node
     dup params>> xt>> dup
     [
         ##prologue
-        dup [ ##alien-callback ] emit-alien-node
+        [ ##alien-callback ] emit-alien-node
         ##epilogue
-        params>> ##callback-return
+        ##return
     ] with-cfg-builder ;
 
 ! No-op nodes

basis/compiler/cfg/cfg.factor

@@ -10,14 +10,14 @@ number
 { successors vector }
 { predecessors vector } ;
 
-M: basic-block hashcode* nip id>> ;
-
 : <basic-block> ( -- bb )
     basic-block new
+        \ basic-block counter >>id
         V{ } clone >>instructions
         V{ } clone >>successors
-        V{ } clone >>predecessors
+        V{ } clone >>predecessors ;
-        \ basic-block counter >>id ;
+
+M: basic-block hashcode* nip id>> ;
 
 TUPLE: cfg { entry basic-block } word label
 spill-area-size reps

basis/compiler/cfg/checker/checker.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel combinators.short-circuit accessors math sequences
 sets assocs compiler.cfg.instructions compiler.cfg.rpo
@@ -14,7 +14,7 @@ ERROR: bad-kill-block bb ;
     dup instructions>> dup penultimate ##epilogue? [
         {
             [ length 2 = ]
-            [ last { [ ##return? ] [ ##callback-return? ] [ ##jump? ] } 1|| ]
+            [ last { [ ##return? ] [ ##jump? ] } 1|| ]
         } 1&&
     ] [ last ##branch? ] if
     [ drop ] [ bad-kill-block ] if ;

basis/compiler/cfg/instructions/instructions.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs accessors arrays kernel sequences namespaces words
 math math.order layouts classes.algebra classes.union
@@ -382,6 +382,16 @@ def: dst
 use: src1 src2
 literal: rep ;
 
+PURE-INSN: ##mul-high-vector
+def: dst
+use: src1 src2
+literal: rep ;
+
+PURE-INSN: ##mul-horizontal-add-vector
+def: dst
+use: src1 src2
+literal: rep ;
+
 PURE-INSN: ##saturated-mul-vector
 def: dst
 use: src1 src2
@@ -402,19 +412,29 @@ def: dst
 use: src1 src2
 literal: rep ;
 
+PURE-INSN: ##avg-vector
+def: dst
+use: src1 src2
+literal: rep ;
+
 PURE-INSN: ##dot-vector
 def: dst/scalar-rep
 use: src1 src2
 literal: rep ;
 
+PURE-INSN: ##sad-vector
+def: dst
+use: src1 src2
+literal: rep ;
+
 PURE-INSN: ##horizontal-add-vector
-def: dst/scalar-rep
+def: dst
-use: src
+use: src1 src2
 literal: rep ;
 
 PURE-INSN: ##horizontal-sub-vector
-def: dst/scalar-rep
+def: dst
-use: src
+use: src1 src2
 literal: rep ;
 
 PURE-INSN: ##horizontal-shl-vector-imm
@@ -651,11 +671,11 @@ literal: params stack-frame ;
 INSN: ##alien-indirect
 literal: params stack-frame ;
 
-INSN: ##alien-callback
+INSN: ##alien-assembly
 literal: params stack-frame ;
 
-INSN: ##callback-return
+INSN: ##alien-callback
-literal: params ;
+literal: params stack-frame ;
 
 ! Instructions used by CFG IR only.
 INSN: ##prologue ;
@@ -728,8 +748,7 @@ temp: temp1/int-rep temp2/int-rep
 literal: size data-values tagged-values uninitialized-locs ;
 
 INSN: ##save-context
-temp: temp1/int-rep temp2/int-rep
+temp: temp1/int-rep temp2/int-rep ;
-literal: callback-allowed? ;
 
 ! Instructions used by machine IR only.
 INSN: _prologue

basis/compiler/cfg/instructions/syntax/syntax.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: classes.tuple classes.tuple.parser kernel words
 make fry sequences parser accessors effects namespaces
@@ -61,14 +61,14 @@ TUPLE: insn-slot-spec type name rep ;
     "pure-insn" "compiler.cfg.instructions" lookup ;
 
 : insn-effect ( word -- effect )
-    boa-effect in>> but-last f <effect> ;
+    boa-effect in>> but-last { } <effect> ;
 
 : define-insn-tuple ( class superclass specs -- )
     [ name>> ] map "insn#" suffix define-tuple-class ;
 
 : define-insn-ctor ( class specs -- )
     [ dup '[ _ ] [ f ] [ boa , ] surround ] dip
-    [ name>> ] map f <effect> define-declared ;
+    [ name>> ] map { } <effect> define-declared ;
 
 : define-insn ( class superclass specs -- )
     parse-insn-slot-specs {

basis/compiler/cfg/intrinsics/allot/allot.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math math.order sequences accessors arrays
 byte-arrays layouts classes.tuple.private fry locals
@@ -34,7 +34,7 @@ IN: compiler.cfg.intrinsics.allot
     [ [ ^^load-literal ] dip 1 ] dip type-number ##set-slot-imm ;
 
 :: store-initial-element ( len reg elt class -- )
-    len [ [ elt reg ] dip 2 + class type-number ##set-slot-imm ] each ;
+    len [ [ elt reg ] dip 2 + class type-number ##set-slot-imm ] each-integer ;
 
 : expand-<array>? ( obj -- ? )
     dup integer? [ 0 8 between? ] [ drop f ] if ;

basis/compiler/cfg/intrinsics/intrinsics.factor

@@ -7,7 +7,6 @@ compiler.cfg.intrinsics.alien
 compiler.cfg.intrinsics.allot
 compiler.cfg.intrinsics.fixnum
 compiler.cfg.intrinsics.float
-compiler.cfg.intrinsics.simd
 compiler.cfg.intrinsics.slots
 compiler.cfg.intrinsics.misc
 compiler.cfg.comparisons ;
@@ -23,7 +22,6 @@ QUALIFIED: classes.tuple.private
 QUALIFIED: math.private
 QUALIFIED: math.integers.private
 QUALIFIED: math.floats.private
-QUALIFIED: math.vectors.simd.intrinsics
 QUALIFIED: math.libm
 IN: compiler.cfg.intrinsics
 
@@ -32,7 +30,8 @@ IN: compiler.cfg.intrinsics
 
 {
     { kernel.private:tag [ drop emit-tag ] }
-    { kernel.private:getenv [ emit-getenv ] }
+    { kernel.private:special-object [ emit-special-object ] }
+    { kernel.private:(identity-hashcode) [ drop emit-identity-hashcode ] }
     { math.private:both-fixnums? [ drop emit-both-fixnums? ] }
     { math.private:fixnum+ [ drop emit-fixnum+ ] }
     { math.private:fixnum- [ drop emit-fixnum- ] }
@@ -151,64 +150,5 @@ IN: compiler.cfg.intrinsics
         { math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] }
     } enable-intrinsics ;
 
-: enable-simd ( -- )
-    {
-        { math.vectors.simd.intrinsics:assert-positive [ drop ] }
-        { math.vectors.simd.intrinsics:(simd-v+) [ [ ^^add-vector ] emit-binary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-vs+) [ [ ^^saturated-add-vector ] emit-binary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-v+-) [ [ ^^add-sub-vector ] emit-binary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-v-) [ [ ^^sub-vector ] emit-binary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-vs-) [ [ ^^saturated-sub-vector ] emit-binary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-vneg) [ [ generate-neg-vector ] emit-unary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-v*) [ [ ^^mul-vector ] emit-binary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-vs*) [ [ ^^saturated-mul-vector ] emit-binary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-v/) [ [ ^^div-vector ] emit-binary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-vmin) [ [ generate-min-vector ] emit-binary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-vmax) [ [ generate-max-vector ] emit-binary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-v.) [ [ ^^dot-vector ] emit-binary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-vabs) [ [ generate-abs-vector ] emit-unary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-vsqrt) [ [ ^^sqrt-vector ] emit-unary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-vbitand) [ [ ^^and-vector ] emit-binary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-vbitandn) [ [ ^^andn-vector ] emit-binary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-vbitor) [ [ ^^or-vector ] emit-binary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-vbitxor) [ [ ^^xor-vector ] emit-binary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-vbitnot) [ [ generate-not-vector ] emit-unary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-vand) [ [ ^^and-vector ] emit-binary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-vandn) [ [ ^^andn-vector ] emit-binary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-vor) [ [ ^^or-vector ] emit-binary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-vxor) [ [ ^^xor-vector ] emit-binary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-vnot) [ [ generate-not-vector ] emit-unary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-v<=) [ [ cc<= generate-compare-vector ] emit-binary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-v<) [ [ cc< generate-compare-vector ] emit-binary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-v=) [ [ cc= generate-compare-vector ] emit-binary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-v>) [ [ cc> generate-compare-vector ] emit-binary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-v>=) [ [ cc>= generate-compare-vector ] emit-binary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-vunordered?) [ [ cc/<>= generate-compare-vector ] emit-binary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-vany?) [ [ vcc-any ^^test-vector ] emit-unary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-vall?) [ [ vcc-all ^^test-vector ] emit-unary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-vnone?) [ [ vcc-none ^^test-vector ] emit-unary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-vlshift) [ [ ^^shl-vector-imm ] [ ^^shl-vector ] emit-shift-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-vrshift) [ [ ^^shr-vector-imm ] [ ^^shr-vector ] emit-shift-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-hlshift) [ [ ^^horizontal-shl-vector-imm ] emit-shift-vector-imm-op ] }
-        { math.vectors.simd.intrinsics:(simd-hrshift) [ [ ^^horizontal-shr-vector-imm ] emit-shift-vector-imm-op ] }
-        { math.vectors.simd.intrinsics:(simd-with) [ [ ^^with-vector ] emit-unary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-gather-2) [ emit-gather-vector-2 ] }
-        { math.vectors.simd.intrinsics:(simd-gather-4) [ emit-gather-vector-4 ] }
-        { math.vectors.simd.intrinsics:(simd-vshuffle-elements) [ emit-shuffle-vector ] }
-        { math.vectors.simd.intrinsics:(simd-vshuffle-bytes) [ emit-shuffle-vector-var ] }
-        { math.vectors.simd.intrinsics:(simd-(vmerge-head)) [ [ ^^merge-vector-head ] emit-binary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-(vmerge-tail)) [ [ ^^merge-vector-tail ] emit-binary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-(v>float)) [ [ ^^integer>float-vector ] emit-unary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-(v>integer)) [ [ ^^float>integer-vector ] emit-unary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-(vpack-signed)) [ [ ^^signed-pack-vector ] emit-binary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-(vpack-unsigned)) [ [ ^^unsigned-pack-vector ] emit-binary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-(vunpack-head)) [ [ generate-unpack-vector-head ] emit-unary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-(vunpack-tail)) [ [ generate-unpack-vector-tail ] emit-unary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-select) [ emit-select-vector ] }
-        { math.vectors.simd.intrinsics:(simd-sum) [ [ ^^horizontal-add-vector ] emit-unary-vector-op ] }
-        { math.vectors.simd.intrinsics:alien-vector [ emit-alien-vector ] }
-        { math.vectors.simd.intrinsics:set-alien-vector [ emit-set-alien-vector ] }
-    } enable-intrinsics ;
-
 : emit-intrinsic ( node word -- )
     "intrinsic" word-prop call( node -- ) ;

basis/compiler/cfg/intrinsics/misc/misc.factor

@@ -1,16 +1,22 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces layouts sequences kernel
+USING: namespaces layouts sequences kernel math accessors
-accessors compiler.tree.propagation.info
+compiler.tree.propagation.info compiler.cfg.stacks
-compiler.cfg.stacks compiler.cfg.hats
+compiler.cfg.hats compiler.cfg.instructions
-compiler.cfg.instructions compiler.cfg.utilities ;
+compiler.cfg.utilities ;
 IN: compiler.cfg.intrinsics.misc
 
 : emit-tag ( -- )
     ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
 
-: emit-getenv ( node -- )
+: emit-special-object ( node -- )
-    "userenv" ^^vm-field-ptr
+    "special-objects" ^^vm-field-ptr
     swap node-input-infos first literal>>
     [ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot ^^slot ] if*
     ds-push ;
+
+: emit-identity-hashcode ( -- )
+    ds-pop tag-mask get bitnot ^^load-immediate ^^and 0 0 ^^slot-imm
+    hashcode-shift ^^shr-imm
+    ^^tag-fixnum
+    ds-push ;

basis/compiler/cfg/intrinsics/simd/backend/backend.factor

@@ -0,0 +1,206 @@
+! (c)2009 Joe Groff bsd license
+USING: accessors arrays assocs classes combinators
+combinators.short-circuit compiler.cfg.builder.blocks
+compiler.cfg.registers compiler.cfg.stacks
+compiler.cfg.stacks.local compiler.tree.propagation.info
+cpu.architecture effects fry generalizations
+kernel locals macros math namespaces quotations sequences
+splitting stack-checker words ;
+IN: compiler.cfg.intrinsics.simd.backend
+
+! Selection of implementation based on available CPU instructions
+
+: can-has? ( quot -- ? )
+    [ t \ can-has? ] dip '[ @ drop \ can-has? get ] with-variable ; inline
+
+: can-has-rep? ( rep reps -- )
+    member? \ can-has? [ and ] change ; inline
+
+GENERIC: create-can-has ( word -- word' )
+
+PREDICATE: hat-word < word
+    {
+        [ name>> { [ "^" head? ] [ "##" head? ] } 1|| ]
+        [ vocabulary>> { "compiler.cfg.intrinsics.simd" "compiler.cfg.hats" } member? ]
+    } 1&& ;
+
+PREDICATE: vector-op-word < hat-word
+    name>> "-vector" swap subseq? ;
+
+: reps-word ( word -- word' )
+    name>> "^^" ?head drop "##" ?head drop
+    "%" "-reps" surround "cpu.architecture" lookup ;
+
+SYMBOL: blub
+
+:: can-has-^^-quot ( word def effect -- quot )
+    effect in>> { "rep" } split1 [ length ] bi@ 1 +
+    word reps-word 1quotation
+    effect out>> length blub <array> >quotation
+    '[ [ _ ndrop ] _ ndip @ can-has-rep? @ ] ;
+
+:: can-has-^-quot ( word def effect -- quot )
+    def create-can-has first ;
+
+: map-concat-like ( seq quot -- seq' )
+    '[ _ map ] [ concat-as ] bi ; inline
+
+M: object create-can-has 1quotation ;
+
+M: array create-can-has
+    [ create-can-has ] map-concat-like 1quotation ;
+M: callable create-can-has
+    [ create-can-has ] map-concat-like 1quotation ;
+
+: (can-has-word) ( word -- word' )
+    name>> "can-has-" prepend "compiler.cfg.intrinsics.simd.backend" lookup ;
+
+: (can-has-quot) ( word -- quot )
+    [ ] [ def>> ] [ stack-effect ] tri {
+        { [ pick name>> "^^" head? ] [ can-has-^^-quot ] }
+        { [ pick name>> "##" head? ] [ can-has-^^-quot ] }
+        { [ pick name>> "^"  head? ] [ can-has-^-quot  ] }
+    } cond ;
+
+: (can-has-nop-quot) ( word -- quot )
+    stack-effect in>> length '[ _ ndrop blub ] ;
+
+DEFER: can-has-words
+
+M: word create-can-has
+    can-has-words ?at drop 1quotation ;
+
+M: hat-word create-can-has
+    (can-has-nop-quot) ;
+
+M: vector-op-word create-can-has
+    dup (can-has-word) [ 1quotation ] [ (can-has-quot) ] ?if ;
+
+GENERIC# >can-has-cond 2 ( quot #pick #dup -- quotpair )
+M:: callable >can-has-cond ( quot #pick #dup -- quotpair )
+    #dup quot create-can-has '[ _ ndup @ can-has? ] quot 2array ;
+
+M:: pair >can-has-cond ( pair #pick #dup -- quotpair )
+    pair first2 :> ( class quot )
+    #pick class #dup quot create-can-has
+    '[ _ npick _ instance? [ _ ndup @ can-has? ] dip and ]
+    quot 2array ;
+
+MACRO: v-vector-op ( trials -- )
+    [ 1 2 >can-has-cond ] map '[ _ cond ] ;
+MACRO: vl-vector-op ( trials -- )
+    [ 1 3 >can-has-cond ] map '[ _ cond ] ;
+MACRO: vv-vector-op ( trials -- )
+    [ 1 3 >can-has-cond ] map '[ _ cond ] ;
+MACRO: vv-cc-vector-op ( trials -- )
+    [ 2 4 >can-has-cond ] map '[ _ cond ] ;
+MACRO: vvvv-vector-op ( trials -- )
+    [ 1 5 >can-has-cond ] map '[ _ cond ] ;
+
+! Special-case conditional instructions
+
+: can-has-^(compare-vector) ( src1 src2 rep cc -- dst )
+    [ 2drop ] 2dip %compare-vector-reps member?
+    \ can-has? [ and ] change
+    blub ;
+
+: can-has-^^test-vector ( src rep vcc -- dst )
+    [ drop ] 2dip drop %test-vector-reps member?
+    \ can-has? [ and ] change
+    blub ;
+
+MACRO: can-has-case ( cases -- )
+    dup first second inputs 1 +
+    '[ _ ndrop f ] suffix '[ _ case ] ;
+
+GENERIC# >can-has-trial 1 ( obj #pick -- quot )
+
+M: callable >can-has-trial
+    drop '[ _ can-has? ] ;
+M: pair >can-has-trial
+    swap first2 dup inputs
+    '[ _ npick _ instance? [ _ can-has? ] [ _ ndrop blub ] if ] ; 
+
+MACRO: can-has-vector-op ( trials #pick #dup -- )
+    [ '[ _ >can-has-trial ] map ] dip '[ _ _ n|| \ can-has? [ and ] change blub ] ;
+
+: can-has-v-vector-op ( trials -- ? )
+    1 2 can-has-vector-op ; inline
+: can-has-vv-vector-op ( trials -- ? )
+    1 3 can-has-vector-op ; inline
+: can-has-vv-cc-vector-op ( trials -- ? )
+    2 4 can-has-vector-op ; inline
+: can-has-vvvv-vector-op ( trials -- ? )
+    1 5 can-has-vector-op ; inline
+
+CONSTANT: can-has-words
+    H{
+        { case can-has-case }
+        { v-vector-op     can-has-v-vector-op  }
+        { vl-vector-op    can-has-vv-vector-op }
+        { vv-vector-op    can-has-vv-vector-op }
+        { vv-cc-vector-op can-has-vv-cc-vector-op }
+        { vvvv-vector-op  can-has-vvvv-vector-op }
+    }
+
+! Intrinsic code emission
+
+MACRO: check-elements ( quots -- )
+    [ length '[ _ firstn ] ]
+    [ '[ _ spread ] ]
+    [ length 1 - \ and <repetition> [ ] like ]
+    tri 3append ;
+
+ERROR: bad-simd-intrinsic node ;
+
+MACRO: if-literals-match ( quots -- )
+    [ length ] [ ] [ length ] tri
+    ! n quots n
+    '[
+        ! node quot
+        [
+            dup node-input-infos
+            _ tail-slice* [ literal>> ] map
+            dup _ check-elements
+        ] dip
+        swap [
+            ! node literals quot
+            [ _ firstn ] dip call
+            drop
+        ] [ 2drop bad-simd-intrinsic ] if
+    ] ;
+
+CONSTANT: [unary]       [ ds-drop  ds-pop ]
+CONSTANT: [unary/param] [ [ -2 inc-d ds-pop ] dip ]
+CONSTANT: [binary]      [ ds-drop 2inputs ]
+CONSTANT: [quaternary]
+    [
+        ds-drop 
+        D 3 peek-loc
+        D 2 peek-loc
+        D 1 peek-loc
+        D 0 peek-loc
+        -4 inc-d
+    ]
+
+:: [emit-vector-op] ( trials params-quot op-quot literal-preds -- quot )
+    params-quot trials op-quot literal-preds 
+    '[ [ _ dip _ @ ds-push ] _ if-literals-match ] ;
+
+MACRO: emit-v-vector-op ( trials -- )
+    [unary] [ v-vector-op ] { [ representation? ] } [emit-vector-op] ;
+MACRO: emit-vl-vector-op ( trials literal-pred -- )
+    [ [unary/param] [ vl-vector-op ] { [ representation? ] } ] dip prefix [emit-vector-op] ;
+MACRO: emit-vv-vector-op ( trials -- )
+    [binary] [ vv-vector-op ] { [ representation? ] } [emit-vector-op] ;
+MACRO: emit-vvvv-vector-op ( trials -- )
+    [quaternary] [ vvvv-vector-op ] { [ representation? ] } [emit-vector-op] ;
+
+MACRO:: emit-vv-or-vl-vector-op ( var-trials imm-trials literal-pred -- )
+    literal-pred imm-trials literal-pred var-trials
+    '[
+        dup node-input-infos 2 tail-slice* first literal>> @
+        [ _ _ emit-vl-vector-op ]
+        [ _   emit-vv-vector-op ] if 
+    ] ;
+

basis/compiler/cfg/intrinsics/simd/simd-tests.factor

@@ -0,0 +1,536 @@
+! (c)2009 Joe Groff bsd license
+USING: arrays assocs biassocs byte-arrays byte-arrays.hex
+classes compiler.cfg compiler.cfg.comparisons compiler.cfg.instructions
+compiler.cfg.intrinsics.simd compiler.cfg.intrinsics.simd.backend
+compiler.cfg.registers compiler.cfg.stacks.height
+compiler.cfg.stacks.local compiler.tree compiler.tree.propagation.info
+cpu.architecture fry hashtables kernel locals make namespaces sequences
+system tools.test words ;
+IN: compiler.cfg.intrinsics.simd.tests
+
+:: test-node ( rep -- node ) 
+    T{ #call
+        { in-d  { 1 2 3 4 } }
+        { out-d { 5 } }
+        { info H{
+            { 1 T{ value-info { class byte-array } } }
+            { 2 T{ value-info { class byte-array } } }
+            { 3 T{ value-info { class byte-array } } }
+            { 4 T{ value-info { class word } { literal? t } { literal rep } } }
+            { 5 T{ value-info { class byte-array } } }
+        } }
+    } ;
+
+:: test-node-literal ( lit rep -- node )
+    lit class :> lit-class
+    T{ #call
+        { in-d  { 1 2 3 4 } }
+        { out-d { 5 } }
+        { info H{
+            { 1 T{ value-info { class byte-array } } }
+            { 2 T{ value-info { class byte-array } } }
+            { 3 T{ value-info { class lit-class } { literal? t } { literal lit } } }
+            { 4 T{ value-info { class word } { literal? t } { literal rep } } }
+            { 5 T{ value-info { class byte-array } } }
+        } }
+    } ;
+
+: test-node-nonliteral-rep ( -- node )
+    T{ #call
+        { in-d  { 1 2 3 4 } }
+        { out-d { 5 } }
+        { info H{
+            { 1 T{ value-info { class byte-array } } }
+            { 2 T{ value-info { class byte-array } } }
+            { 3 T{ value-info { class byte-array } } }
+            { 4 T{ value-info { class object } } }
+            { 5 T{ value-info { class byte-array } } }
+        } }
+    } ;
+
+: test-compiler-env ( -- x )
+    H{ } clone
+        T{ basic-block { id 0 } }
+            [ \ basic-block pick set-at ]
+            [ 0 swap associate \ ds-heights pick set-at ]
+            [ 0 swap associate \ rs-heights pick set-at ] tri
+        T{ current-height { d 0 } { r 0 } { emit-d 0 } { emit-r 0 } } \ current-height pick set-at
+        H{ } clone \ local-peek-set pick set-at
+        H{ } clone \ replace-mapping pick set-at
+        H{ } <biassoc> \ locs>vregs pick set-at
+        H{ } clone \ peek-sets pick set-at
+        H{ } clone \ replace-sets pick set-at
+        H{ } clone \ kill-sets pick set-at ;
+
+: make-classes ( quot -- seq )
+    { } make [ class ] map ; inline
+
+: test-emit ( cpu rep quot -- node )
+    [
+        [ new \ cpu ] 2dip '[
+            test-compiler-env [ _ test-node @ ] bind
+        ] with-variable
+    ] make-classes ; inline
+
+: test-emit-literal ( cpu lit rep quot -- node )
+    [
+        [ new \ cpu ] 3dip '[
+            test-compiler-env [ _ _ test-node-literal @ ] bind
+        ] with-variable
+    ] make-classes ; inline
+
+: test-emit-nonliteral-rep ( cpu quot -- node )
+    [
+        [ new \ cpu ] dip '[
+            test-compiler-env [ test-node-nonliteral-rep @ ] bind
+        ] with-variable
+    ] make-classes ; inline
+
+CONSTANT: signed-reps
+    { char-16-rep short-8-rep int-4-rep longlong-2-rep float-4-rep double-2-rep }
+CONSTANT: all-reps
+    {
+        char-16-rep short-8-rep int-4-rep longlong-2-rep float-4-rep double-2-rep
+        uchar-16-rep ushort-8-rep uint-4-rep ulonglong-2-rep
+    }
+
+TUPLE: scalar-cpu ;
+
+TUPLE: simple-ops-cpu ;
+M: simple-ops-cpu %zero-vector-reps  all-reps ;
+M: simple-ops-cpu %fill-vector-reps  all-reps ;
+M: simple-ops-cpu %add-vector-reps   all-reps ;
+M: simple-ops-cpu %sub-vector-reps   all-reps ;
+M: simple-ops-cpu %mul-vector-reps   all-reps ;
+M: simple-ops-cpu %div-vector-reps   all-reps ;
+M: simple-ops-cpu %andn-vector-reps  all-reps ;
+M: simple-ops-cpu %and-vector-reps   all-reps ;
+M: simple-ops-cpu %or-vector-reps    all-reps ;
+M: simple-ops-cpu %xor-vector-reps   all-reps ;
+M: simple-ops-cpu %merge-vector-reps all-reps ;
+M: simple-ops-cpu %sqrt-vector-reps  all-reps ;
+M: simple-ops-cpu %test-vector-reps  all-reps ;
+M: simple-ops-cpu %signed-pack-vector-reps   all-reps ;
+M: simple-ops-cpu %unsigned-pack-vector-reps all-reps ;
+M: simple-ops-cpu %gather-vector-2-reps { longlong-2-rep ulonglong-2-rep double-2-rep } ;
+M: simple-ops-cpu %gather-vector-4-reps { int-4-rep uint-4-rep float-4-rep } ;
+M: simple-ops-cpu %alien-vector-reps all-reps ;
+
+! v+
+[ { ##add-vector } ]
+[ simple-ops-cpu float-4-rep [ emit-simd-v+ ] test-emit ]
+unit-test
+
+! v-
+[ { ##sub-vector } ]
+[ simple-ops-cpu float-4-rep [ emit-simd-v- ] test-emit ]
+unit-test
+
+! vneg
+[ { ##load-constant ##sub-vector } ]
+[ simple-ops-cpu float-4-rep [ emit-simd-vneg ] test-emit ]
+unit-test
+
+[ { ##zero-vector ##sub-vector } ]
+[ simple-ops-cpu int-4-rep [ emit-simd-vneg ] test-emit ]
+unit-test
+
+! v*
+[ { ##mul-vector } ]
+[ simple-ops-cpu float-4-rep [ emit-simd-v* ] test-emit ]
+unit-test
+
+! v/
+[ { ##div-vector } ]
+[ simple-ops-cpu float-4-rep [ emit-simd-v/ ] test-emit ]
+unit-test
+
+TUPLE: addsub-cpu < simple-ops-cpu ;
+M: addsub-cpu %add-sub-vector-reps { int-4-rep float-4-rep } ;
+
+! v+-
+[ { ##add-sub-vector } ]
+[ addsub-cpu float-4-rep [ emit-simd-v+- ] test-emit ]
+unit-test
+
+[ { ##load-constant ##xor-vector ##add-vector } ]
+[ simple-ops-cpu float-4-rep [ emit-simd-v+- ] test-emit ]
+unit-test
+
+[ { ##load-constant ##xor-vector ##sub-vector ##add-vector } ]
+[ simple-ops-cpu int-4-rep [ emit-simd-v+- ] test-emit ]
+unit-test
+
+TUPLE: saturating-cpu < simple-ops-cpu ;
+M: saturating-cpu %saturated-add-vector-reps { int-4-rep } ;
+M: saturating-cpu %saturated-sub-vector-reps { int-4-rep } ;
+M: saturating-cpu %saturated-mul-vector-reps { int-4-rep } ;
+
+! vs+
+[ { ##add-vector } ]
+[ simple-ops-cpu float-4-rep [ emit-simd-vs+ ] test-emit ]
+unit-test
+
+[ { ##add-vector } ]
+[ saturating-cpu float-4-rep [ emit-simd-vs+ ] test-emit ]
+unit-test
+
+[ { ##saturated-add-vector } ]
+[ saturating-cpu int-4-rep [ emit-simd-vs+ ] test-emit ]
+unit-test
+
+! vs-
+[ { ##sub-vector } ]
+[ simple-ops-cpu float-4-rep [ emit-simd-vs- ] test-emit ]
+unit-test
+
+[ { ##sub-vector } ]
+[ saturating-cpu float-4-rep [ emit-simd-vs- ] test-emit ]
+unit-test
+
+[ { ##saturated-sub-vector } ]
+[ saturating-cpu int-4-rep [ emit-simd-vs- ] test-emit ]
+unit-test
+
+! vs*
+[ { ##mul-vector } ]
+[ simple-ops-cpu float-4-rep [ emit-simd-vs* ] test-emit ]
+unit-test
+
+[ { ##mul-vector } ]
+[ saturating-cpu float-4-rep [ emit-simd-vs* ] test-emit ]
+unit-test
+
+[ { ##saturated-mul-vector } ]
+[ saturating-cpu int-4-rep [ emit-simd-vs* ] test-emit ]
+unit-test
+
+TUPLE: minmax-cpu < simple-ops-cpu ;
+M: minmax-cpu %min-vector-reps signed-reps ;
+M: minmax-cpu %max-vector-reps signed-reps ;
+M: minmax-cpu %compare-vector-reps { cc= cc/= } member? [ signed-reps ] [ { } ] if ;
+M: minmax-cpu %compare-vector-ccs nip f 2array 1array f ;
+
+TUPLE: compare-cpu < simple-ops-cpu ;
+M: compare-cpu %compare-vector-reps drop signed-reps ;
+M: compare-cpu %compare-vector-ccs nip f 2array 1array f ;
+
+! vmin
+[ { ##min-vector } ]
+[ minmax-cpu float-4-rep [ emit-simd-vmin ] test-emit ]
+unit-test
+
+[ { ##compare-vector ##and-vector ##andn-vector ##or-vector } ]
+[ compare-cpu float-4-rep [ emit-simd-vmin ] test-emit ]
+unit-test
+
+! vmax
+[ { ##max-vector } ]
+[ minmax-cpu float-4-rep [ emit-simd-vmax ] test-emit ]
+unit-test
+
+[ { ##compare-vector ##and-vector ##andn-vector ##or-vector } ]
+[ compare-cpu float-4-rep [ emit-simd-vmax ] test-emit ]
+unit-test
+
+TUPLE: dot-cpu < simple-ops-cpu ;
+M: dot-cpu %dot-vector-reps { float-4-rep } ;
+
+TUPLE: horizontal-cpu < simple-ops-cpu ;
+M: horizontal-cpu %horizontal-add-vector-reps signed-reps ;
+M: horizontal-cpu %unpack-vector-head-reps signed-reps ;
+M: horizontal-cpu %unpack-vector-tail-reps signed-reps ;
+
+! v.
+[ { ##dot-vector } ]
+[ dot-cpu float-4-rep [ emit-simd-v. ] test-emit ]
+unit-test
+
+[ { ##mul-vector ##horizontal-add-vector ##horizontal-add-vector ##vector>scalar } ]
+[ horizontal-cpu float-4-rep [ emit-simd-v. ] test-emit ]
+unit-test
+
+[ {
+    ##mul-vector
+    ##merge-vector-head ##merge-vector-tail ##add-vector 
+    ##merge-vector-head ##merge-vector-tail ##add-vector 
+    ##vector>scalar
+} ]
+[ simple-ops-cpu float-4-rep [ emit-simd-v. ] test-emit ]
+unit-test
+
+! vsqrt
+[ { ##sqrt-vector } ]
+[ simple-ops-cpu float-4-rep [ emit-simd-vsqrt ] test-emit ]
+unit-test
+
+! sum
+[ { ##horizontal-add-vector ##vector>scalar } ]
+[ horizontal-cpu double-2-rep [ emit-simd-sum ] test-emit ]
+unit-test
+
+[ { ##horizontal-add-vector ##horizontal-add-vector ##vector>scalar } ]
+[ horizontal-cpu float-4-rep [ emit-simd-sum ] test-emit ]
+unit-test
+
+[ {
+    ##unpack-vector-head ##unpack-vector-tail ##add-vector
+    ##horizontal-add-vector ##horizontal-add-vector
+    ##vector>scalar
+} ]
+[ horizontal-cpu short-8-rep [ emit-simd-sum ] test-emit ]
+unit-test
+
+[ {
+    ##unpack-vector-head ##unpack-vector-tail ##add-vector
+    ##horizontal-add-vector ##horizontal-add-vector ##horizontal-add-vector
+    ##vector>scalar
+} ]
+[ horizontal-cpu char-16-rep [ emit-simd-sum ] test-emit ]
+unit-test
+
+TUPLE: abs-cpu < simple-ops-cpu ;
+M: abs-cpu %abs-vector-reps signed-reps ;
+
+! vabs
+[ { } ]
+[ simple-ops-cpu uint-4-rep [ emit-simd-vabs ] test-emit ]
+unit-test
+
+[ { ##abs-vector } ]
+[ abs-cpu float-4-rep [ emit-simd-vabs ] test-emit ]
+unit-test
+
+[ { ##load-constant ##andn-vector } ]
+[ simple-ops-cpu float-4-rep [ emit-simd-vabs ] test-emit ]
+unit-test
+
+[ { ##zero-vector ##sub-vector ##compare-vector ##and-vector ##andn-vector ##or-vector } ]
+[ compare-cpu int-4-rep [ emit-simd-vabs ] test-emit ]
+unit-test
+
+! vand
+[ { ##and-vector } ]
+[ simple-ops-cpu float-4-rep [ emit-simd-vand ] test-emit ]
+unit-test
+
+! vandn
+[ { ##andn-vector } ]
+[ simple-ops-cpu float-4-rep [ emit-simd-vandn ] test-emit ]
+unit-test
+
+! vor
+[ { ##or-vector } ]
+[ simple-ops-cpu float-4-rep [ emit-simd-vor ] test-emit ]
+unit-test
+
+! vxor
+[ { ##xor-vector } ]
+[ simple-ops-cpu float-4-rep [ emit-simd-vxor ] test-emit ]
+unit-test
+
+TUPLE: not-cpu < simple-ops-cpu ;
+M: not-cpu %not-vector-reps signed-reps ;
+
+! vnot
+[ { ##not-vector } ]
+[ not-cpu float-4-rep [ emit-simd-vnot ] test-emit ]
+unit-test
+
+[ { ##fill-vector ##xor-vector } ]
+[ simple-ops-cpu float-4-rep [ emit-simd-vnot ] test-emit ]
+unit-test
+
+TUPLE: shift-cpu < simple-ops-cpu ;
+M: shift-cpu %shl-vector-reps signed-reps ;
+M: shift-cpu %shr-vector-reps signed-reps ;
+
+TUPLE: shift-imm-cpu < simple-ops-cpu ;
+M: shift-imm-cpu %shl-vector-imm-reps signed-reps ;
+M: shift-imm-cpu %shr-vector-imm-reps signed-reps ;
+
+TUPLE: horizontal-shift-cpu < simple-ops-cpu ;
+M: horizontal-shift-cpu %horizontal-shl-vector-imm-reps signed-reps ;
+M: horizontal-shift-cpu %horizontal-shr-vector-imm-reps signed-reps ;
+
+! vlshift
+[ { ##shl-vector-imm } ]
+[ shift-imm-cpu 2 int-4-rep [ emit-simd-vlshift ] test-emit-literal ]
+unit-test
+
+[ { ##shl-vector } ]
+[ shift-cpu int-4-rep [ emit-simd-vlshift ] test-emit ]
+unit-test
+
+! vrshift
+[ { ##shr-vector-imm } ]
+[ shift-imm-cpu 2 int-4-rep [ emit-simd-vrshift ] test-emit-literal ]
+unit-test
+
+[ { ##shr-vector } ]
+[ shift-cpu int-4-rep [ emit-simd-vrshift ] test-emit ]
+unit-test
+
+! hlshift
+[ { ##horizontal-shl-vector-imm } ]
+[ horizontal-shift-cpu 2 int-4-rep [ emit-simd-hlshift ] test-emit-literal ]
+unit-test
+
+! hrshift
+[ { ##horizontal-shr-vector-imm } ]
+[ horizontal-shift-cpu 2 int-4-rep [ emit-simd-hrshift ] test-emit-literal ]
+unit-test
+
+TUPLE: shuffle-imm-cpu < simple-ops-cpu ;
+M: shuffle-imm-cpu %shuffle-vector-imm-reps signed-reps ;
+
+TUPLE: shuffle-cpu < simple-ops-cpu ;
+M: shuffle-cpu %shuffle-vector-reps signed-reps ;
+
+! vshuffle-elements
+[ { ##load-constant ##shuffle-vector } ]
+[ shuffle-cpu { 0 1 2 3 } int-4-rep [ emit-simd-vshuffle-elements ] test-emit-literal ]
+unit-test
+
+[ { ##shuffle-vector-imm } ]
+[ shuffle-imm-cpu { 0 1 2 3 } int-4-rep [ emit-simd-vshuffle-elements ] test-emit-literal ]
+unit-test
+
+! vshuffle-bytes
+[ { ##shuffle-vector } ]
+[ shuffle-cpu int-4-rep [ emit-simd-vshuffle-bytes ] test-emit ]
+unit-test
+
+! vmerge-head
+[ { ##merge-vector-head } ]
+[ simple-ops-cpu float-4-rep [ emit-simd-vmerge-head ] test-emit ]
+unit-test
+
+! vmerge-tail
+[ { ##merge-vector-tail } ]
+[ simple-ops-cpu float-4-rep [ emit-simd-vmerge-tail ] test-emit ]
+unit-test
+
+! v<= etc.
+[ { ##compare-vector } ]
+[ compare-cpu int-4-rep [ emit-simd-v<= ] test-emit ]
+unit-test
+
+[ { ##min-vector ##compare-vector } ]
+[ minmax-cpu int-4-rep [ emit-simd-v<= ] test-emit ]
+unit-test
+
+[ { ##load-constant ##xor-vector ##xor-vector ##compare-vector } ]
+[ compare-cpu uint-4-rep [ emit-simd-v<= ] test-emit ]
+unit-test
+
+! vany? etc.
+[ { ##test-vector } ]
+[ simple-ops-cpu int-4-rep [ emit-simd-vany? ] test-emit ]
+unit-test
+
+TUPLE: convert-cpu < simple-ops-cpu ;
+M: convert-cpu %integer>float-vector-reps { int-4-rep } ;
+M: convert-cpu %float>integer-vector-reps { float-4-rep } ;
+
+! v>float
+[ { } ]
+[ convert-cpu float-4-rep [ emit-simd-v>float ] test-emit ]
+unit-test
+
+[ { ##integer>float-vector } ]
+[ convert-cpu int-4-rep [ emit-simd-v>float ] test-emit ]
+unit-test
+
+! v>integer
+[ { } ]
+[ convert-cpu int-4-rep [ emit-simd-v>integer ] test-emit ]
+unit-test
+
+[ { ##float>integer-vector } ]
+[ convert-cpu float-4-rep [ emit-simd-v>integer ] test-emit ]
+unit-test
+
+! vpack-signed
+[ { ##signed-pack-vector } ]
+[ simple-ops-cpu int-4-rep [ emit-simd-vpack-signed ] test-emit ]
+unit-test
+
+! vpack-unsigned
+[ { ##unsigned-pack-vector } ]
+[ simple-ops-cpu int-4-rep [ emit-simd-vpack-unsigned ] test-emit ]
+unit-test
+
+TUPLE: unpack-head-cpu < simple-ops-cpu ;
+M: unpack-head-cpu %unpack-vector-head-reps all-reps ;
+TUPLE: unpack-cpu < unpack-head-cpu ;
+M: unpack-cpu %unpack-vector-tail-reps all-reps ;
+
+! vunpack-head
+[ { ##unpack-vector-head } ]
+[ unpack-head-cpu int-4-rep [ emit-simd-vunpack-head ] test-emit ]
+unit-test
+
+[ { ##zero-vector ##merge-vector-head } ]
+[ simple-ops-cpu uint-4-rep [ emit-simd-vunpack-head ] test-emit ]
+unit-test
+
+[ { ##merge-vector-head ##shr-vector-imm } ]
+[ shift-imm-cpu int-4-rep [ emit-simd-vunpack-head ] test-emit ]
+unit-test
+
+[ { ##zero-vector ##compare-vector ##merge-vector-head } ]
+[ compare-cpu int-4-rep [ emit-simd-vunpack-head ] test-emit ]
+unit-test
+
+! vunpack-tail
+[ { ##unpack-vector-tail } ]
+[ unpack-cpu int-4-rep [ emit-simd-vunpack-tail ] test-emit ]
+unit-test
+
+[ { ##tail>head-vector ##unpack-vector-head } ]
+[ unpack-head-cpu int-4-rep [ emit-simd-vunpack-tail ] test-emit ]
+unit-test
+
+[ { ##zero-vector ##merge-vector-tail } ]
+[ simple-ops-cpu uint-4-rep [ emit-simd-vunpack-tail ] test-emit ]
+unit-test
+
+[ { ##merge-vector-tail ##shr-vector-imm } ]
+[ shift-imm-cpu int-4-rep [ emit-simd-vunpack-tail ] test-emit ]
+unit-test
+
+[ { ##zero-vector ##compare-vector ##merge-vector-tail } ]
+[ compare-cpu int-4-rep [ emit-simd-vunpack-tail ] test-emit ]
+unit-test
+
+! with
+[ { ##scalar>vector ##shuffle-vector-imm } ]
+[ shuffle-imm-cpu float-4-rep [ emit-simd-with ] test-emit ]
+unit-test
+
+! gather-2
+[ { ##gather-vector-2 } ]
+[ simple-ops-cpu double-2-rep [ emit-simd-gather-2 ] test-emit ]
+unit-test
+
+! gather-4
+[ { ##gather-vector-4 } ]
+[ simple-ops-cpu float-4-rep [ emit-simd-gather-4 ] test-emit ]
+unit-test
+
+! select
+[ { ##shuffle-vector-imm ##vector>scalar } ]
+[ shuffle-imm-cpu 1 float-4-rep [ emit-simd-select ] test-emit-literal ]
+unit-test
+
+! test with nonliteral/invalid reps
+[ simple-ops-cpu [ emit-simd-v+ ] test-emit-nonliteral-rep ]
+[ bad-simd-intrinsic? ] must-fail-with
+
+[ simple-ops-cpu f [ emit-simd-v+ ] test-emit ]
+[ bad-simd-intrinsic? ] must-fail-with
+
+[ simple-ops-cpu 3 [ emit-simd-v+ ] test-emit ]
+[ bad-simd-intrinsic? ] must-fail-with
+

basis/compiler/cfg/intrinsics/simd/simd.factor

@@ -1,189 +1,26 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009 Slava Pestov, Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien byte-arrays fry classes.algebra
+USING: accessors alien alien.c-types byte-arrays fry
-cpu.architecture kernel math sequences math.vectors
+classes.algebra cpu.architecture kernel layouts math sequences
-math.vectors.simd.intrinsics macros generalizations combinators
+math.vectors math.vectors.simd.intrinsics
-combinators.short-circuit arrays locals
+macros generalizations combinators combinators.short-circuit
-compiler.tree.propagation.info compiler.cfg.builder.blocks
+arrays locals compiler.tree.propagation.info
+compiler.cfg.builder.blocks
 compiler.cfg.comparisons
 compiler.cfg.stacks compiler.cfg.stacks.local compiler.cfg.hats
 compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.intrinsics
 compiler.cfg.intrinsics.alien
+compiler.cfg.intrinsics.simd.backend
 specialized-arrays ;
-FROM: alien.c-types => heap-size uchar ushort uint ulonglong float double ;
+FROM: alien.c-types => heap-size char short int longlong float double ;
-SPECIALIZED-ARRAYS: uchar ushort uint ulonglong float double ;
+SPECIALIZED-ARRAYS: char uchar short ushort int uint longlong ulonglong float double ;
 IN: compiler.cfg.intrinsics.simd
 
-MACRO: check-elements ( quots -- )
+! compound vector ops
-    [ length '[ _ firstn ] ]
-    [ '[ _ spread ] ]
-    [ length 1 - \ and <repetition> [ ] like ]
-    tri 3append ;
-
-MACRO: if-literals-match ( quots -- )
-    [ length ] [ ] [ length ] tri
-    ! n quots n
-    '[
-        ! node quot
-        [
-            dup node-input-infos
-            _ tail-slice* [ literal>> ] map
-            dup _ check-elements
-        ] dip
-        swap [
-            ! node literals quot
-            [ _ firstn ] dip call
-            drop
-        ] [ 2drop emit-primitive ] if
-    ] ;
-
-: emit-vector-op ( node quot: ( rep -- ) -- )
-    { [ representation? ] } if-literals-match ; inline
-
-: [binary] ( quot -- quot' )
-    '[ [ ds-drop 2inputs ] dip @ ds-push ] ; inline
-
-: emit-binary-vector-op ( node quot -- )
-    [binary] emit-vector-op ; inline
-
-: [unary] ( quot -- quot' )
-    '[ [ ds-drop ds-pop ] dip @ ds-push ] ; inline
-
-: emit-unary-vector-op ( node quot -- )
-    [unary] emit-vector-op ; inline
-
-: [unary/param] ( quot -- quot' )
-    '[ [ -2 inc-d ds-pop ] 2dip @ ds-push ] ; inline
-
-: emit-shift-vector-imm-op ( node quot -- )
-    [unary/param]
-    { [ integer? ] [ representation? ] } if-literals-match ; inline
-
-:: emit-shift-vector-op ( node imm-quot var-quot -- )
-    node node-input-infos 2 tail-slice* first literal>> integer?
-    [ node imm-quot emit-shift-vector-imm-op ]
-    [ node var-quot emit-binary-vector-op ] if ; inline
-
-: emit-gather-vector-2 ( node -- )
-    [ ^^gather-vector-2 ] emit-binary-vector-op ;
-
-: emit-gather-vector-4 ( node -- )
-    [
-        ds-drop
-        [
-            D 3 peek-loc
-            D 2 peek-loc
-            D 1 peek-loc
-            D 0 peek-loc
-            -4 inc-d
-        ] dip
-        ^^gather-vector-4
-        ds-push
-    ] emit-vector-op ;
-
-: shuffle? ( obj -- ? ) { [ array? ] [ [ integer? ] all? ] } 1&& ;
-
-: >variable-shuffle ( shuffle rep -- shuffle' )
-    rep-component-type heap-size
-    [ dup <repetition> >byte-array ]
-    [ iota >byte-array ] bi
-    '[ _ n*v _ v+ ] map concat ;
-
-: generate-shuffle-vector-imm ( src shuffle rep -- dst )
-    dup %shuffle-vector-imm-reps member?
-    [ ^^shuffle-vector-imm ]
-    [
-        [ >variable-shuffle ^^load-constant ] keep
-        ^^shuffle-vector
-    ] if ;
-
-: emit-shuffle-vector-imm ( node -- )
-    ! Pad the permutation with zeroes if it's too short, since we
-    ! can't throw an error at this point.
-    [ [ rep-components 0 pad-tail ] keep generate-shuffle-vector-imm ] [unary/param]
-    { [ shuffle? ] [ representation? ] } if-literals-match ;
-
-: emit-shuffle-vector-var ( node -- )
-    [ ^^shuffle-vector ] [binary]
-    { [ %shuffle-vector-reps member? ] } if-literals-match ;
-
-: emit-shuffle-vector ( node -- )
-    dup node-input-infos {
-        [ length 3 = ]
-        [ first  class>> byte-array class<= ]
-        [ second class>> byte-array class<= ]
-        [ third  literal>> representation?  ]
-    } 1&& [ emit-shuffle-vector-var ] [ emit-shuffle-vector-imm ] if ;
-
-: ^^broadcast-vector ( src n rep -- dst )
-    [ rep-components swap <array> ] keep
-    generate-shuffle-vector-imm ;
-
-: emit-broadcast-vector ( node -- )
-    [ ^^broadcast-vector ] [unary/param]
-    { [ integer? ] [ representation? ] } if-literals-match ;
-
-: ^^with-vector ( src rep -- dst )
-    [ ^^scalar>vector ] keep [ 0 ] dip ^^broadcast-vector ;
-
-: ^^select-vector ( src n rep -- dst )
-    [ ^^broadcast-vector ] keep ^^vector>scalar ;
-
-: emit-select-vector ( node -- )
-    [ ^^select-vector ] [unary/param]
-    { [ integer? ] [ representation? ] } if-literals-match ; inline
-
-: emit-alien-vector-op ( node quot: ( rep -- ) -- )
-    { [ %alien-vector-reps member? ] } if-literals-match ; inline
-
-: emit-alien-vector ( node -- )
-    dup [
-        '[
-            ds-drop prepare-alien-getter
-            _ ^^alien-vector ds-push
-        ]
-        [ inline-alien-getter? ] inline-alien
-    ] with emit-alien-vector-op ;
-
-: emit-set-alien-vector ( node -- )
-    dup [
-        '[
-            ds-drop prepare-alien-setter ds-pop
-            _ ##set-alien-vector
-        ]
-        [ byte-array inline-alien-setter? ]
-        inline-alien
-    ] with emit-alien-vector-op ;
-
-: generate-not-vector ( src rep -- dst )
-    dup %not-vector-reps member?
-    [ ^^not-vector ]
-    [ [ ^^fill-vector ] [ ^^xor-vector ] bi ] if ;
-
-:: ((generate-compare-vector)) ( src1 src2 rep {cc,swap} -- dst )
-    {cc,swap} first2 :> ( cc swap? )
-    swap?
-    [ src2 src1 rep cc ^^compare-vector ]
-    [ src1 src2 rep cc ^^compare-vector ] if ;
-
-:: (generate-compare-vector) ( src1 src2 rep orig-cc -- dst )
-    rep orig-cc %compare-vector-ccs :> ( ccs not? )
-
-    ccs empty?
-    [ rep not? [ ^^fill-vector ] [ ^^zero-vector ] if ]
-    [
-        ccs unclip :> ( rest-ccs first-cc )
-        src1 src2 rep first-cc ((generate-compare-vector)) :> first-dst
-
-        rest-ccs first-dst
-        [ [ src1 src2 rep ] dip ((generate-compare-vector)) rep ^^or-vector ]
-        reduce
-
-        not? [ rep generate-not-vector ] when
-    ] if ;
 
 : sign-bit-mask ( rep -- byte-array )
-    unsign-rep {
+    signed-rep {
         { char-16-rep [ uchar-array{
             HEX: 80 HEX: 80 HEX: 80 HEX: 80
             HEX: 80 HEX: 80 HEX: 80 HEX: 80
@@ -204,150 +41,628 @@ MACRO: if-literals-match ( quots -- )
         } underlying>> ] }
     } case ;
 
-:: (generate-minmax-compare-vector) ( src1 src2 rep orig-cc -- dst )
+: ^load-neg-zero-vector ( rep -- dst )
-    orig-cc order-cc {
-        { cc<  [ src1 src2 rep ^^max-vector src1 rep cc/= (generate-compare-vector) ] }
-        { cc<= [ src1 src2 rep ^^min-vector src1 rep cc=  (generate-compare-vector) ] }
-        { cc>  [ src1 src2 rep ^^min-vector src1 rep cc/= (generate-compare-vector) ] }
-        { cc>= [ src1 src2 rep ^^max-vector src1 rep cc=  (generate-compare-vector) ] }
-    } case ;
-
-:: generate-compare-vector ( src1 src2 rep orig-cc -- dst )
     {
-        {
-            [ rep orig-cc %compare-vector-reps member? ]
-            [ src1 src2 rep orig-cc (generate-compare-vector) ]
-        }
-        {
-            [ rep %min-vector-reps member? ]
-            [ src1 src2 rep orig-cc (generate-minmax-compare-vector) ]
-        }
-        {
-            [ rep unsign-rep orig-cc %compare-vector-reps member? ]
-            [ 
-                rep sign-bit-mask ^^load-constant :> sign-bits
-                src1 sign-bits rep ^^xor-vector
-                src2 sign-bits rep ^^xor-vector
-                rep unsign-rep orig-cc (generate-compare-vector)
-            ]
-        }
-    } cond ;
-
-:: generate-unpack-vector-head ( src rep -- dst )
-    {
-        {
-            [ rep %unpack-vector-head-reps member? ]
-            [ src rep ^^unpack-vector-head ]
-        }
-        {
-            [ rep unsigned-int-vector-rep? ]
-            [
-                rep ^^zero-vector :> zero
-                src zero rep ^^merge-vector-head
-            ]
-        }
-        {
-            [ rep widen-vector-rep %shr-vector-imm-reps member? ]
-            [
-                src src rep ^^merge-vector-head
-                rep rep-component-type
-                heap-size 8 * rep widen-vector-rep ^^shr-vector-imm
-            ]
-        }
-        [
-            rep ^^zero-vector :> zero
-            zero src rep cc> ^^compare-vector :> sign
-            src sign rep ^^merge-vector-head
-        ] 
-    } cond ;
-
-:: generate-unpack-vector-tail ( src rep -- dst )
-    {
-        {
-            [ rep %unpack-vector-tail-reps member? ]
-            [ src rep ^^unpack-vector-tail ]
-        }
-        {
-            [ rep %unpack-vector-head-reps member? ]
-            [
-                src rep ^^tail>head-vector :> tail
-                tail rep ^^unpack-vector-head
-            ]
-        }
-        {
-            [ rep unsigned-int-vector-rep? ]
-            [
-                rep ^^zero-vector :> zero
-                src zero rep ^^merge-vector-tail
-            ]
-        }
-        {
-            [ rep widen-vector-rep %shr-vector-imm-reps member? ]
-            [
-                src src rep ^^merge-vector-tail
-                rep rep-component-type
-                heap-size 8 * rep widen-vector-rep ^^shr-vector-imm
-            ]
-        }
-        [
-            rep ^^zero-vector :> zero
-            zero src rep cc> ^^compare-vector :> sign
-            src sign rep ^^merge-vector-tail
-        ] 
-    } cond ;
-
-:: generate-load-neg-zero-vector ( rep -- dst )
-    rep {
         { float-4-rep [ float-array{ -0.0 -0.0 -0.0 -0.0 } underlying>> ^^load-constant ] }
         { double-2-rep [ double-array{ -0.0 -0.0 } underlying>> ^^load-constant ] }
-        [ drop rep ^^zero-vector ]
     } case ;
 
-:: generate-neg-vector ( src rep -- dst )
+: ^load-add-sub-vector ( rep -- dst )
-    rep generate-load-neg-zero-vector
+    signed-rep {
-    src rep ^^sub-vector ;
+        { float-4-rep    [ float-array{ -0.0  0.0 -0.0  0.0 } underlying>> ^^load-constant ] }
+        { double-2-rep   [ double-array{ -0.0  0.0 } underlying>> ^^load-constant ] }
+        { char-16-rep    [ char-array{ -1 0 -1 0 -1 0 -1 0 -1 0 -1 0 -1 0 -1 0 } underlying>> ^^load-constant ] }
+        { short-8-rep    [ short-array{ -1 0 -1 0 -1 0 -1 0 } underlying>> ^^load-constant ] }
+        { int-4-rep      [ int-array{ -1 0 -1 0 } underlying>> ^^load-constant ] }
+        { longlong-2-rep [ longlong-array{ -1 0 } underlying>> ^^load-constant ] }
+    } case ;
 
-:: generate-blend-vector ( mask true false rep -- dst )
+: ^load-half-vector ( rep -- dst )
-    mask true rep ^^and-vector
+    {
+        { float-4-rep  [ float-array{  0.5 0.5 0.5 0.5 } underlying>> ^^load-constant ] }
+        { double-2-rep [ double-array{ 0.5 0.5 }         underlying>> ^^load-constant ] }
+    } case ;
+
+: >variable-shuffle ( shuffle rep -- shuffle' )
+    rep-component-type heap-size
+    [ dup <repetition> >byte-array ]
+    [ iota >byte-array ] bi
+    '[ _ n*v _ v+ ] map concat ;
+
+: ^load-immediate-shuffle ( shuffle rep -- dst )
+    >variable-shuffle ^^load-constant ;
+
+:: ^blend-vector ( mask true false rep -- dst )
+    true mask rep ^^and-vector
     mask false rep ^^andn-vector
     rep ^^or-vector ;
 
-:: generate-abs-vector ( src rep -- dst )
+: ^not-vector ( src rep -- dst )
     {
-        {
+        [ ^^not-vector ]
-            [ rep unsigned-int-vector-rep? ]
+        [ [ ^^fill-vector ] [ ^^xor-vector ] bi ]
-            [ src ]
+    } v-vector-op ;
-        }
+
-        {
+:: ^((compare-vector)) ( src1 src2 rep {cc,swap} -- dst )
-            [ rep %abs-vector-reps member? ]
+    {cc,swap} first2 :> ( cc swap? )
-            [ src rep ^^abs-vector ]
+    swap?
-        }
+    [ src2 src1 rep cc ^^compare-vector ]
-        {
+    [ src1 src2 rep cc ^^compare-vector ] if ;
-            [ rep float-vector-rep? ]
+
+:: ^(compare-vector) ( src1 src2 rep orig-cc -- dst )
+    rep orig-cc %compare-vector-ccs :> ( ccs not? )
+
+    ccs empty?
+    [ rep not? [ ^^fill-vector ] [ ^^zero-vector ] if ]
     [
-                rep generate-load-neg-zero-vector
+        ccs unclip :> ( rest-ccs first-cc )
-                src rep ^^andn-vector
+        src1 src2 rep first-cc ^((compare-vector)) :> first-dst
+
+        rest-ccs first-dst
+        [ [ src1 src2 rep ] dip ^((compare-vector)) rep ^^or-vector ]
+        reduce
+
+        not? [ rep ^not-vector ] when
+    ] if ;
+
+:: ^minmax-compare-vector ( src1 src2 rep cc -- dst )
+    cc order-cc {
+        { cc<  [ src1 src2 rep ^^max-vector src1 rep cc/= ^(compare-vector) ] }
+        { cc<= [ src1 src2 rep ^^min-vector src1 rep cc=  ^(compare-vector) ] }
+        { cc>  [ src1 src2 rep ^^min-vector src1 rep cc/= ^(compare-vector) ] }
+        { cc>= [ src1 src2 rep ^^max-vector src1 rep cc=  ^(compare-vector) ] }
+    } case ;
+
+: ^compare-vector ( src1 src2 rep cc -- dst )
+    {
+        [ ^(compare-vector) ]
+        [ ^minmax-compare-vector ]
+        { unsigned-int-vector-rep [| src1 src2 rep cc |
+            rep sign-bit-mask ^^load-constant :> sign-bits
+            src1 sign-bits rep ^^xor-vector
+            src2 sign-bits rep ^^xor-vector
+            rep signed-rep cc ^(compare-vector)
+        ] }
+    } vv-cc-vector-op ;
+
+: ^unpack-vector-head ( src rep -- dst )
+    {
+        [ ^^unpack-vector-head ]
+        { unsigned-int-vector-rep [ [ ^^zero-vector ] [ ^^merge-vector-head ] bi ] }
+        { signed-int-vector-rep [| src rep |
+            src src rep ^^merge-vector-head :> merged
+            rep rep-component-type heap-size 8 * :> bits
+            merged bits rep widen-vector-rep ^^shr-vector-imm
+        ] }
+        { signed-int-vector-rep [| src rep |
+            rep ^^zero-vector :> zero
+            zero src rep cc> ^compare-vector :> sign
+            src sign rep ^^merge-vector-head
+        ] }
+    } v-vector-op ;
+
+: ^unpack-vector-tail ( src rep -- dst )
+    {
+        [ ^^unpack-vector-tail ]
+        [ [ ^^tail>head-vector ] [ ^^unpack-vector-head ] bi ]
+        { unsigned-int-vector-rep [ [ ^^zero-vector ] [ ^^merge-vector-tail ] bi ] }
+        { signed-int-vector-rep [| src rep |
+            src src rep ^^merge-vector-tail :> merged
+            rep rep-component-type heap-size 8 * :> bits
+            merged bits rep widen-vector-rep ^^shr-vector-imm
+        ] }
+        { signed-int-vector-rep [| src rep |
+            rep ^^zero-vector :> zero
+            zero src rep cc> ^compare-vector :> sign
+            src sign rep ^^merge-vector-tail
+        ] }
+    } v-vector-op ;
+
+PREDICATE: fixnum-vector-rep < int-vector-rep
+    rep-component-type heap-size cell < ;
+
+: ^(sum-vector-2) ( src rep -- dst )
+    {
+        [ dupd ^^horizontal-add-vector ]
+        [| src rep | 
+            src src rep ^^merge-vector-head :> head
+            src src rep ^^merge-vector-tail :> tail
+            head tail rep ^^add-vector
         ]
-        }
+    } v-vector-op ;
+
+: ^(sum-vector-4) ( src rep -- dst )
+    {
         [
+            [ dupd ^^horizontal-add-vector ]
+            [ dupd ^^horizontal-add-vector ] bi
+        ]
+        [| src rep | 
+            src src rep ^^merge-vector-head :> head
+            src src rep ^^merge-vector-tail :> tail
+            head tail rep ^^add-vector :> src'
+
+            rep widen-vector-rep :> rep'
+            src' src' rep' ^^merge-vector-head :> head'
+            src' src' rep' ^^merge-vector-tail :> tail'
+            head' tail' rep ^^add-vector
+        ]
+    } v-vector-op ;
+
+: ^(sum-vector-8) ( src rep -- dst )
+    {
+        [
+            [ dupd ^^horizontal-add-vector ]
+            [ dupd ^^horizontal-add-vector ]
+            [ dupd ^^horizontal-add-vector ] tri
+        ]
+        [| src rep | 
+            src src rep ^^merge-vector-head :> head
+            src src rep ^^merge-vector-tail :> tail
+            head tail rep ^^add-vector :> src'
+
+            rep widen-vector-rep :> rep'
+            src' src' rep' ^^merge-vector-head :> head'
+            src' src' rep' ^^merge-vector-tail :> tail'
+            head' tail' rep ^^add-vector :> src''
+
+            rep' widen-vector-rep :> rep''
+            src'' src'' rep'' ^^merge-vector-head :> head''
+            src'' src'' rep'' ^^merge-vector-tail :> tail''
+            head'' tail'' rep ^^add-vector
+        ]
+    } v-vector-op ;
+
+: ^(sum-vector-16) ( src rep -- dst )
+    {
+        [
+            {
+                [ dupd ^^horizontal-add-vector ]
+                [ dupd ^^horizontal-add-vector ]
+                [ dupd ^^horizontal-add-vector ]
+                [ dupd ^^horizontal-add-vector ]
+            } cleave
+        ]
+        [| src rep | 
+            src src rep ^^merge-vector-head :> head
+            src src rep ^^merge-vector-tail :> tail
+            head tail rep ^^add-vector :> src'
+
+            rep widen-vector-rep :> rep'
+            src' src' rep' ^^merge-vector-head :> head'
+            src' src' rep' ^^merge-vector-tail :> tail'
+            head' tail' rep ^^add-vector :> src''
+
+            rep' widen-vector-rep :> rep''
+            src'' src'' rep'' ^^merge-vector-head :> head''
+            src'' src'' rep'' ^^merge-vector-tail :> tail''
+            head'' tail'' rep ^^add-vector :> src'''
+
+            rep'' widen-vector-rep :> rep'''
+            src''' src''' rep''' ^^merge-vector-head :> head'''
+            src''' src''' rep''' ^^merge-vector-tail :> tail'''
+            head''' tail''' rep ^^add-vector
+        ]
+    } v-vector-op ;
+
+: ^(sum-vector) ( src rep -- dst )
+    [
+        dup rep-length {
+            {  2 [ ^(sum-vector-2) ] }
+            {  4 [ ^(sum-vector-4) ] }
+            {  8 [ ^(sum-vector-8) ] }
+            { 16 [ ^(sum-vector-16) ] }
+        } case
+    ] [ ^^vector>scalar ] bi ;
+
+: ^sum-vector ( src rep -- dst )
+    {
+        { float-vector-rep [ ^(sum-vector) ] }
+        { fixnum-vector-rep [| src rep |
+            src rep ^unpack-vector-head :> head
+            src rep ^unpack-vector-tail :> tail
+            rep widen-vector-rep :> wide-rep
+            head tail wide-rep ^^add-vector wide-rep
+            ^(sum-vector)
+        ] }
+    } v-vector-op ;
+
+: shuffle? ( obj -- ? ) { [ array? ] [ [ integer? ] all? ] } 1&& ;
+
+: ^shuffle-vector-imm ( src1 shuffle rep -- dst )
+    [ rep-length 0 pad-tail ] keep {
+        [ ^^shuffle-vector-imm ]
+        [ [ ^load-immediate-shuffle ] [ ^^shuffle-vector ] bi ]
+    } vl-vector-op ;
+
+: ^broadcast-vector ( src n rep -- dst )
+    [ rep-length swap <array> ] keep
+    ^shuffle-vector-imm ;
+
+: ^with-vector ( src rep -- dst )
+    [ ^^scalar>vector ] keep [ 0 ] dip ^broadcast-vector ;
+
+: ^select-vector ( src n rep -- dst )
+    [ ^broadcast-vector ] keep ^^vector>scalar ;
+
+! intrinsic emitters
+
+: emit-simd-v+ ( node -- )
+    {
+        [ ^^add-vector ]
+    } emit-vv-vector-op ;
+
+: emit-simd-v- ( node -- )
+    {
+        [ ^^sub-vector ]
+    } emit-vv-vector-op ;
+
+: emit-simd-vneg ( node -- )
+    {
+        { float-vector-rep [ [ ^load-neg-zero-vector swap ] [ ^^sub-vector ] bi ] }
+        { int-vector-rep   [ [ ^^zero-vector         swap ] [ ^^sub-vector ] bi ] }
+    } emit-v-vector-op ;
+
+: emit-simd-v+- ( node -- )
+    {
+        [ ^^add-sub-vector ]
+        { float-vector-rep [| src1 src2 rep |
+            rep ^load-add-sub-vector :> signs
+            src2 signs rep ^^xor-vector :> src2'
+            src1 src2' rep ^^add-vector
+        ] }
+        { int-vector-rep   [| src1 src2 rep |
+            rep ^load-add-sub-vector :> signs
+            src2  signs rep ^^xor-vector :> src2'
+            src2' signs rep ^^sub-vector :> src2''
+            src1 src2'' rep ^^add-vector
+        ] }
+    } emit-vv-vector-op ;
+
+: emit-simd-vs+ ( node -- )
+    {
+        { float-vector-rep [ ^^add-vector ] }
+        { int-vector-rep [ ^^saturated-add-vector ] }
+    } emit-vv-vector-op ;
+
+: emit-simd-vs- ( node -- )
+    {
+        { float-vector-rep [ ^^sub-vector ] }
+        { int-vector-rep [ ^^saturated-sub-vector ] }
+    } emit-vv-vector-op ;
+
+: emit-simd-vs* ( node -- )
+    {
+        { float-vector-rep [ ^^mul-vector ] }
+        { int-vector-rep [ ^^saturated-mul-vector ] }
+    } emit-vv-vector-op ;
+
+: emit-simd-v* ( node -- )
+    {
+        [ ^^mul-vector ]
+    } emit-vv-vector-op ;
+
+: emit-simd-v*high ( node -- )
+    {
+        [ ^^mul-high-vector ]
+    } emit-vv-vector-op ;
+
+: emit-simd-v*hs+ ( node -- )
+    {
+        [ ^^mul-horizontal-add-vector ]
+    } emit-vv-vector-op ;
+
+: emit-simd-v/ ( node -- )
+    {
+        [ ^^div-vector ]
+    } emit-vv-vector-op ;
+
+: emit-simd-vmin ( node -- )
+    {
+        [ ^^min-vector ]
+        [
+            [ cc< ^compare-vector ]
+            [ ^blend-vector ] 3bi
+        ]
+    } emit-vv-vector-op ;
+
+: emit-simd-vmax ( node -- )
+    {
+        [ ^^max-vector ]
+        [
+            [ cc> ^compare-vector ]
+            [ ^blend-vector ] 3bi
+        ]
+    } emit-vv-vector-op ;
+
+: emit-simd-vavg ( node -- )
+    {
+        [ ^^avg-vector ]
+        { float-vector-rep [| src1 src2 rep |
+            src1 src2 rep ^^add-vector
+            rep ^load-half-vector rep ^^mul-vector
+        ] }
+    } emit-vv-vector-op ;
+
+: emit-simd-v. ( node -- )
+    {
+        [ ^^dot-vector ]
+        { float-vector-rep [ [ ^^mul-vector ] [ ^sum-vector ] bi ] }
+    } emit-vv-vector-op ;
+
+: emit-simd-vsad ( node -- )
+    {
+        [
+            [ ^^sad-vector dup { 2 3 0 1 } int-4-rep ^^shuffle-vector-imm int-4-rep ^^add-vector ]
+            [ widen-vector-rep ^^vector>scalar ] bi
+        ]
+    } emit-vv-vector-op ;
+
+: emit-simd-vsqrt ( node -- )
+    {
+        [ ^^sqrt-vector ]
+    } emit-v-vector-op ;
+
+: emit-simd-sum ( node -- )
+    {
+        [ ^sum-vector ]
+    } emit-v-vector-op ;
+
+: emit-simd-vabs ( node -- )
+    {
+        { unsigned-int-vector-rep [ drop ] }
+        [ ^^abs-vector ]
+        { float-vector-rep [ [ ^load-neg-zero-vector ] [ swapd ^^andn-vector ] bi ] }
+        { int-vector-rep [| src rep |
             rep ^^zero-vector :> zero
             zero src rep ^^sub-vector :> -src
-            zero src rep cc> ^^compare-vector :> sign 
+            zero src rep cc> ^compare-vector :> sign
-            sign -src src rep generate-blend-vector
+            sign -src src rep ^blend-vector
+        ] }
+    } emit-v-vector-op ;
+
+: emit-simd-vand ( node -- )
+    {
+        [ ^^and-vector ]
+    } emit-vv-vector-op ;
+
+: emit-simd-vandn ( node -- )
+    {
+        [ ^^andn-vector ]
+    } emit-vv-vector-op ;
+
+: emit-simd-vor ( node -- )
+    {
+        [ ^^or-vector ]
+    } emit-vv-vector-op ;
+
+: emit-simd-vxor ( node -- )
+    {
+        [ ^^xor-vector ]
+    } emit-vv-vector-op ;
+
+: emit-simd-vnot ( node -- )
+    {
+        [ ^not-vector ]
+    } emit-v-vector-op ;
+
+: emit-simd-vlshift ( node -- )
+    {
+        [ ^^shl-vector ]
+    } {
+        [ ^^shl-vector-imm ]
+    } [ integer? ] emit-vv-or-vl-vector-op ;
+
+: emit-simd-vrshift ( node -- )
+    {
+        [ ^^shr-vector ]
+    } {
+        [ ^^shr-vector-imm ]
+    } [ integer? ] emit-vv-or-vl-vector-op ;
+
+: emit-simd-hlshift ( node -- )
+    {
+        [ ^^horizontal-shl-vector-imm ]
+    } [ integer? ] emit-vl-vector-op ;
+
+: emit-simd-hrshift ( node -- )
+    {
+        [ ^^horizontal-shr-vector-imm ]
+    } [ integer? ] emit-vl-vector-op ;
+
+: emit-simd-vshuffle-elements ( node -- )
+    {
+        [ ^shuffle-vector-imm ]
+    } [ shuffle? ] emit-vl-vector-op ;
+
+: emit-simd-vshuffle-bytes ( node -- )
+    {
+        [ ^^shuffle-vector ]
+    } emit-vv-vector-op ;
+
+: emit-simd-vmerge-head ( node -- )
+    {
+        [ ^^merge-vector-head ]
+    } emit-vv-vector-op ;
+
+: emit-simd-vmerge-tail ( node -- )
+    {
+        [ ^^merge-vector-tail ]
+    } emit-vv-vector-op ;
+
+: emit-simd-v<= ( node -- )
+    {
+        [ cc<= ^compare-vector ]
+    } emit-vv-vector-op ;
+: emit-simd-v< ( node -- )
+    {
+        [ cc< ^compare-vector ]
+    } emit-vv-vector-op ;
+: emit-simd-v= ( node -- )
+    {
+        [ cc=  ^compare-vector ]
+    } emit-vv-vector-op ;
+: emit-simd-v> ( node -- )
+    {
+        [ cc>  ^compare-vector ]
+    } emit-vv-vector-op ;
+: emit-simd-v>= ( node -- )
+    {
+        [ cc>= ^compare-vector ]
+    } emit-vv-vector-op ;
+: emit-simd-vunordered? ( node -- )
+    {
+        [ cc/<>= ^compare-vector ]
+    } emit-vv-vector-op ;
+
+: emit-simd-vany? ( node -- )
+    {
+        [ vcc-any ^^test-vector ]
+    } emit-v-vector-op ;
+: emit-simd-vall? ( node -- )
+    {
+        [ vcc-all ^^test-vector ]
+    } emit-v-vector-op ;
+: emit-simd-vnone? ( node -- )
+    {
+        [ vcc-none ^^test-vector ]
+    } emit-v-vector-op ;
+
+: emit-simd-v>float ( node -- )
+    {
+        { float-vector-rep [ drop ] }
+        { int-vector-rep [ ^^integer>float-vector ] }
+    } emit-v-vector-op ;
+
+: emit-simd-v>integer ( node -- )
+    {
+        { float-vector-rep [ ^^float>integer-vector ] }
+        { int-vector-rep [ drop ] }
+    } emit-v-vector-op ;
+
+: emit-simd-vpack-signed ( node -- )
+    {
+        [ ^^signed-pack-vector ]
+    } emit-vv-vector-op ;
+
+: emit-simd-vpack-unsigned ( node -- )
+    {
+        [ ^^unsigned-pack-vector ]
+    } emit-vv-vector-op ;
+
+: emit-simd-vunpack-head ( node -- )
+    {
+        [ ^unpack-vector-head ]
+    } emit-v-vector-op ;
+
+: emit-simd-vunpack-tail ( node -- )
+    {
+        [ ^unpack-vector-tail ]
+    } emit-v-vector-op ;
+
+: emit-simd-with ( node -- )
+    {
+        { fixnum-vector-rep [ ^with-vector ] }
+        { float-vector-rep  [ ^with-vector ] }
+    } emit-v-vector-op ;
+
+: emit-simd-gather-2 ( node -- )
+    {
+        { fixnum-vector-rep [ ^^gather-vector-2 ] }
+        { float-vector-rep  [ ^^gather-vector-2 ] }
+    } emit-vv-vector-op ;
+
+: emit-simd-gather-4 ( node -- )
+    {
+        { fixnum-vector-rep [ ^^gather-vector-4 ] }
+        { float-vector-rep  [ ^^gather-vector-4 ] }
+    } emit-vvvv-vector-op ;
+
+: emit-simd-select ( node -- )
+    {
+        { fixnum-vector-rep [ ^select-vector ] }
+        { float-vector-rep  [ ^select-vector ] }
+    } [ integer? ] emit-vl-vector-op ;
+
+: emit-alien-vector ( node -- )
+    dup [
+        '[
+            ds-drop prepare-alien-getter
+            _ ^^alien-vector ds-push
         ]
-    } cond ;
+        [ inline-alien-getter? ] inline-alien
+    ] with { [ %alien-vector-reps member? ] } if-literals-match ;
 
-: generate-min-vector ( src1 src2 rep -- dst )
+: emit-set-alien-vector ( node -- )
-    dup %min-vector-reps member?
+    dup [
-    [ ^^min-vector ] [
+        '[
-        [ cc< generate-compare-vector ]
+            ds-drop prepare-alien-setter ds-pop
-        [ generate-blend-vector ] 3bi
+            _ ##set-alien-vector
-    ] if ;
+        ]
+        [ byte-array inline-alien-setter? ]
+        inline-alien
+    ] with { [ %alien-vector-reps member? ] } if-literals-match ;
 
-: generate-max-vector ( src1 src2 rep -- dst )
+: enable-simd ( -- )
-    dup %max-vector-reps member?
+    {
-    [ ^^max-vector ] [
+        { (simd-v+)                [ emit-simd-v+                  ] }
-        [ cc> generate-compare-vector ]
+        { (simd-v-)                [ emit-simd-v-                  ] }
-        [ generate-blend-vector ] 3bi
+        { (simd-vneg)              [ emit-simd-vneg                ] }
-    ] if ;
+        { (simd-v+-)               [ emit-simd-v+-                 ] }
+        { (simd-vs+)               [ emit-simd-vs+                 ] }
+        { (simd-vs-)               [ emit-simd-vs-                 ] }
+        { (simd-vs*)               [ emit-simd-vs*                 ] }
+        { (simd-v*)                [ emit-simd-v*                  ] }
+        { (simd-v*high)            [ emit-simd-v*high              ] }
+        { (simd-v*hs+)             [ emit-simd-v*hs+               ] }
+        { (simd-v/)                [ emit-simd-v/                  ] }
+        { (simd-vmin)              [ emit-simd-vmin                ] }
+        { (simd-vmax)              [ emit-simd-vmax                ] }
+        { (simd-vavg)              [ emit-simd-vavg                ] }
+        { (simd-v.)                [ emit-simd-v.                  ] }
+        { (simd-vsad)              [ emit-simd-vsad                ] }
+        { (simd-vsqrt)             [ emit-simd-vsqrt               ] }
+        { (simd-sum)               [ emit-simd-sum                 ] }
+        { (simd-vabs)              [ emit-simd-vabs                ] }
+        { (simd-vbitand)           [ emit-simd-vand                ] }
+        { (simd-vbitandn)          [ emit-simd-vandn               ] }
+        { (simd-vbitor)            [ emit-simd-vor                 ] }
+        { (simd-vbitxor)           [ emit-simd-vxor                ] }
+        { (simd-vbitnot)           [ emit-simd-vnot                ] }
+        { (simd-vand)              [ emit-simd-vand                ] }
+        { (simd-vandn)             [ emit-simd-vandn               ] }
+        { (simd-vor)               [ emit-simd-vor                 ] }
+        { (simd-vxor)              [ emit-simd-vxor                ] }
+        { (simd-vnot)              [ emit-simd-vnot                ] }
+        { (simd-vlshift)           [ emit-simd-vlshift             ] }
+        { (simd-vrshift)           [ emit-simd-vrshift             ] }
+        { (simd-hlshift)           [ emit-simd-hlshift             ] }
+        { (simd-hrshift)           [ emit-simd-hrshift             ] }
+        { (simd-vshuffle-elements) [ emit-simd-vshuffle-elements   ] }
+        { (simd-vshuffle-bytes)    [ emit-simd-vshuffle-bytes      ] }
+        { (simd-vmerge-head)       [ emit-simd-vmerge-head         ] }
+        { (simd-vmerge-tail)       [ emit-simd-vmerge-tail         ] }
+        { (simd-v<=)               [ emit-simd-v<=                 ] }
+        { (simd-v<)                [ emit-simd-v<                  ] }
+        { (simd-v=)                [ emit-simd-v=                  ] }
+        { (simd-v>)                [ emit-simd-v>                  ] }
+        { (simd-v>=)               [ emit-simd-v>=                 ] }
+        { (simd-vunordered?)       [ emit-simd-vunordered?         ] }
+        { (simd-vany?)             [ emit-simd-vany?               ] }
+        { (simd-vall?)             [ emit-simd-vall?               ] }
+        { (simd-vnone?)            [ emit-simd-vnone?              ] }
+        { (simd-v>float)           [ emit-simd-v>float             ] }
+        { (simd-v>integer)         [ emit-simd-v>integer           ] }
+        { (simd-vpack-signed)      [ emit-simd-vpack-signed        ] }
+        { (simd-vpack-unsigned)    [ emit-simd-vpack-unsigned      ] }
+        { (simd-vunpack-head)      [ emit-simd-vunpack-head        ] }
+        { (simd-vunpack-tail)      [ emit-simd-vunpack-tail        ] }
+        { (simd-with)              [ emit-simd-with                ] }
+        { (simd-gather-2)          [ emit-simd-gather-2            ] }
+        { (simd-gather-4)          [ emit-simd-gather-4            ] }
+        { (simd-select)            [ emit-simd-select              ] }
+        { alien-vector             [ emit-alien-vector             ] }
+        { set-alien-vector         [ emit-set-alien-vector         ] }
+    } enable-intrinsics ;
 
+enable-simd

basis/compiler/cfg/intrinsics/slots/slots.factor

@@ -1,14 +1,17 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: layouts namespaces kernel accessors sequences math
-classes.algebra locals combinators cpu.architecture
+classes.algebra classes.builtin locals combinators
-compiler.tree.propagation.info compiler.cfg.stacks
+cpu.architecture compiler.tree.propagation.info
-compiler.cfg.hats compiler.cfg.registers
+compiler.cfg.stacks compiler.cfg.hats compiler.cfg.registers
 compiler.cfg.instructions compiler.cfg.utilities
 compiler.cfg.builder.blocks compiler.constants ;
 IN: compiler.cfg.intrinsics.slots
 
-: value-tag ( info -- n ) class>> class-type ; inline
+: class-tag ( class -- tag/f )
+    builtins get [ class<= ] with find drop ;
+
+: value-tag ( info -- n ) class>> class-tag ;
 
 : ^^tag-offset>slot ( slot tag -- vreg' )
     [ ^^offset>slot ] dip ^^sub-imm ;

basis/compiler/cfg/save-contexts/save-contexts-tests.factor

@@ -15,7 +15,7 @@ V{
 
 [
     V{
-        T{ ##save-context f 1 2 f }
+        T{ ##save-context f 1 2 }
         T{ ##unary-float-function f 2 3 "sqrt" }
         T{ ##branch }
     }

basis/compiler/cfg/save-contexts/save-contexts.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors combinators.short-circuit
 compiler.cfg.instructions compiler.cfg.registers
@@ -14,14 +14,7 @@ IN: compiler.cfg.save-contexts
             [ ##binary-float-function? ]
             [ ##alien-invoke? ]
             [ ##alien-indirect? ]
-        } 1||
+            [ ##alien-assembly? ]
-    ] any? ;
-
-: needs-callback-context? ( insns -- ? )
-    [
-        {
-            [ ##alien-invoke? ]
-            [ ##alien-indirect? ]
         } 1||
     ] any? ;
 
@@ -29,7 +22,6 @@ IN: compiler.cfg.save-contexts
     dup instructions>> dup needs-save-context? [
         int-rep next-vreg-rep
         int-rep next-vreg-rep
-        pick needs-callback-context?
         \ ##save-context new-insn prefix
         >>instructions drop
     ] [ 2drop ] if ;

basis/compiler/cfg/stacks/stacks.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math sequences kernel namespaces accessors biassocs compiler.cfg
 compiler.cfg.instructions compiler.cfg.registers compiler.cfg.hats
@@ -33,7 +33,7 @@ IN: compiler.cfg.stacks
 : ds-load ( n -- vregs )
     dup 0 =
     [ drop f ]
-    [ [ <reversed> [ <ds-loc> peek-loc ] map ] [ neg inc-d ] bi ] if ;
+    [ [ iota <reversed> [ <ds-loc> peek-loc ] map ] [ neg inc-d ] bi ] if ;
 
 : ds-store ( vregs -- )
     [

basis/compiler/cfg/stacks/uninitialized/uninitialized.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences byte-arrays namespaces accessors classes math
 math.order fry arrays combinators compiler.cfg.registers
@@ -55,7 +55,7 @@ M: insn visit-insn drop ;
     2dup [ length ] bi@ max '[ _ 1 pad-tail ] bi@ [ bitand ] 2map ;
 
 : (uninitialized-locs) ( seq quot -- seq' )
-    [ dup length [ drop 0 = ] pusher [ 2each ] dip ] dip map ; inline
+    [ [ drop 0 = ] pusher [ each-index ] dip ] dip map ; inline
 
 PRIVATE>
 

basis/compiler/cfg/value-numbering/expressions/expressions.factor

@@ -27,6 +27,9 @@ C: <reference> reference-expr
 M: reference-expr equal?
     over reference-expr? [ [ value>> ] bi@ eq? ] [ 2drop f ] if ;
 
+M: reference-expr hashcode*
+    nip value>> identity-hashcode ;
+
 : constant>vn ( constant -- vn ) <constant> expr>vn ; inline
 
 GENERIC: >expr ( insn -- expr )

basis/compiler/cfg/value-numbering/rewrite/rewrite.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors combinators combinators.short-circuit arrays
 fry kernel layouts math namespaces sequences cpu.architecture
-math.bitwise math.order math.vectors.simd.intrinsics classes
+math.bitwise math.order classes
 vectors locals make alien.c-types io.binary grouping
 compiler.cfg
 compiler.cfg.registers
@@ -42,6 +42,14 @@ M: insn rewrite drop f ;
     ] [ drop f ] if ; inline
 
 : general-compare-expr? ( insn -- ? )
+    {
+        [ compare-expr? ]
+        [ compare-imm-expr? ]
+        [ compare-float-unordered-expr? ]
+        [ compare-float-ordered-expr? ]
+    } 1|| ;
+
+: general-or-vector-compare-expr? ( insn -- ? )
     {
         [ compare-expr? ]
         [ compare-imm-expr? ]
@@ -52,7 +60,7 @@ M: insn rewrite drop f ;
 
 : rewrite-boolean-comparison? ( insn -- ? )
     dup ##branch-t? [
-        src1>> vreg>expr general-compare-expr?
+        src1>> vreg>expr general-or-vector-compare-expr?
     ] [ drop f ] if ; inline
  
 : >compare-expr< ( expr -- in1 in2 cc )
@@ -463,100 +471,9 @@ M: ##alien-signed-2 rewrite rewrite-alien-addressing ;
 M: ##alien-signed-4 rewrite rewrite-alien-addressing ;
 M: ##alien-float rewrite rewrite-alien-addressing ;
 M: ##alien-double rewrite rewrite-alien-addressing ;
-M: ##alien-vector rewrite rewrite-alien-addressing ;
 M: ##set-alien-integer-1 rewrite rewrite-alien-addressing ;
 M: ##set-alien-integer-2 rewrite rewrite-alien-addressing ;
 M: ##set-alien-integer-4 rewrite rewrite-alien-addressing ;
 M: ##set-alien-float rewrite rewrite-alien-addressing ;
 M: ##set-alien-double rewrite rewrite-alien-addressing ;
-M: ##set-alien-vector rewrite rewrite-alien-addressing ;
 
-! Some lame constant folding for SIMD intrinsics. Eventually this
-! should be redone completely.
-
-: rewrite-shuffle-vector-imm ( insn expr -- insn' )
-    2dup [ rep>> ] bi@ eq? [
-        [ [ dst>> ] [ src>> vn>vreg ] bi* ]
-        [ [ shuffle>> ] bi@ nths ]
-        [ drop rep>> ]
-        2tri \ ##shuffle-vector-imm new-insn
-    ] [ 2drop f ] if ;
-
-: (fold-shuffle-vector-imm) ( shuffle bytes -- bytes' )
-    2dup length swap length /i group nths concat ;
-
-: fold-shuffle-vector-imm ( insn expr -- insn' )
-    [ [ dst>> ] [ shuffle>> ] bi ] dip value>>
-    (fold-shuffle-vector-imm) \ ##load-constant new-insn ;
-
-M: ##shuffle-vector-imm rewrite
-    dup src>> vreg>expr {
-        { [ dup shuffle-vector-imm-expr? ] [ rewrite-shuffle-vector-imm ] }
-        { [ dup reference-expr? ] [ fold-shuffle-vector-imm ] }
-        { [ dup constant-expr? ] [ fold-shuffle-vector-imm ] }
-        [ 2drop f ]
-    } cond ;
-
-: (fold-scalar>vector) ( insn bytes -- insn' )
-    [ [ dst>> ] [ rep>> rep-components ] bi ] dip <repetition> concat
-    \ ##load-constant new-insn ;
-
-: fold-scalar>vector ( insn expr -- insn' )
-    value>> over rep>> {
-        { float-4-rep [ float>bits 4 >le (fold-scalar>vector) ] }
-        { double-2-rep [ double>bits 8 >le (fold-scalar>vector) ] }
-        [ [ untag-fixnum ] dip rep-component-type heap-size >le (fold-scalar>vector) ]
-    } case ;
-
-M: ##scalar>vector rewrite
-    dup src>> vreg>expr dup constant-expr?
-    [ fold-scalar>vector ] [ 2drop f ] if ;
-
-M: ##xor-vector rewrite
-    dup [ src1>> vreg>vn ] [ src2>> vreg>vn ] bi eq?
-    [ [ dst>> ] [ rep>> ] bi \ ##zero-vector new-insn ] [ drop f ] if ;
-
-: vector-not? ( expr -- ? )
-    {
-        [ not-vector-expr? ]
-        [ {
-            [ xor-vector-expr? ]
-            [ [ src1>> ] [ src2>> ] bi [ vn>expr fill-vector-expr? ] either? ]
-        } 1&& ]
-    } 1|| ;
-
-GENERIC: vector-not-src ( expr -- vreg )
-M: not-vector-expr vector-not-src src>> vn>vreg ;
-M: xor-vector-expr vector-not-src
-    dup src1>> vn>expr fill-vector-expr? [ src2>> ] [ src1>> ] if vn>vreg ;
-
-M: ##and-vector rewrite 
-    {
-        { [ dup src1>> vreg>expr vector-not? ] [
-            {
-                [ dst>> ]
-                [ src1>> vreg>expr vector-not-src ]
-                [ src2>> ]
-                [ rep>> ]
-            } cleave \ ##andn-vector new-insn
-        ] }
-        { [ dup src2>> vreg>expr vector-not? ] [
-            {
-                [ dst>> ]
-                [ src2>> vreg>expr vector-not-src ]
-                [ src1>> ]
-                [ rep>> ]
-            } cleave \ ##andn-vector new-insn
-        ] }
-        [ drop f ]
-    } cond ;
-
-M: ##andn-vector rewrite
-    dup src1>> vreg>expr vector-not? [
-        {
-            [ dst>> ]
-            [ src1>> vreg>expr vector-not-src ]
-            [ src2>> ]
-            [ rep>> ]
-        } cleave \ ##and-vector new-insn
-    ] [ drop f ] if ;

basis/compiler/cfg/value-numbering/simd/simd.factor

@@ -0,0 +1,120 @@
+! Copyright (C) 2008, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators combinators.short-circuit arrays
+fry kernel layouts math namespaces sequences cpu.architecture
+math.bitwise math.order classes
+vectors locals make alien.c-types io.binary grouping
+math.vectors.simd.intrinsics
+compiler.cfg
+compiler.cfg.registers
+compiler.cfg.comparisons
+compiler.cfg.instructions
+compiler.cfg.value-numbering.expressions
+compiler.cfg.value-numbering.graph
+compiler.cfg.value-numbering.rewrite
+compiler.cfg.value-numbering.simplify ;
+IN: compiler.cfg.value-numbering.simd
+
+M: ##alien-vector rewrite rewrite-alien-addressing ;
+M: ##set-alien-vector rewrite rewrite-alien-addressing ;
+
+! Some lame constant folding for SIMD intrinsics. Eventually this
+! should be redone completely.
+
+: rewrite-shuffle-vector-imm ( insn expr -- insn' )
+    2dup [ rep>> ] bi@ eq? [
+        [ [ dst>> ] [ src>> vn>vreg ] bi* ]
+        [ [ shuffle>> ] bi@ nths ]
+        [ drop rep>> ]
+        2tri \ ##shuffle-vector-imm new-insn
+    ] [ 2drop f ] if ;
+
+: (fold-shuffle-vector-imm) ( shuffle bytes -- bytes' )
+    2dup length swap length /i group nths concat ;
+
+: fold-shuffle-vector-imm ( insn expr -- insn' )
+    [ [ dst>> ] [ shuffle>> ] bi ] dip value>>
+    (fold-shuffle-vector-imm) \ ##load-constant new-insn ;
+
+M: ##shuffle-vector-imm rewrite
+    dup src>> vreg>expr {
+        { [ dup shuffle-vector-imm-expr? ] [ rewrite-shuffle-vector-imm ] }
+        { [ dup reference-expr? ] [ fold-shuffle-vector-imm ] }
+        { [ dup constant-expr? ] [ fold-shuffle-vector-imm ] }
+        [ 2drop f ]
+    } cond ;
+
+: (fold-scalar>vector) ( insn bytes -- insn' )
+    [ [ dst>> ] [ rep>> rep-length ] bi ] dip <repetition> concat
+    \ ##load-constant new-insn ;
+
+: fold-scalar>vector ( insn expr -- insn' )
+    value>> over rep>> {
+        { float-4-rep [ float>bits 4 >le (fold-scalar>vector) ] }
+        { double-2-rep [ double>bits 8 >le (fold-scalar>vector) ] }
+        [ [ untag-fixnum ] dip rep-component-type heap-size >le (fold-scalar>vector) ]
+    } case ;
+
+M: ##scalar>vector rewrite
+    dup src>> vreg>expr dup constant-expr?
+    [ fold-scalar>vector ] [ 2drop f ] if ;
+
+M: ##xor-vector rewrite
+    dup [ src1>> vreg>vn ] [ src2>> vreg>vn ] bi eq?
+    [ [ dst>> ] [ rep>> ] bi \ ##zero-vector new-insn ] [ drop f ] if ;
+
+: vector-not? ( expr -- ? )
+    {
+        [ not-vector-expr? ]
+        [ {
+            [ xor-vector-expr? ]
+            [ [ src1>> ] [ src2>> ] bi [ vn>expr fill-vector-expr? ] either? ]
+        } 1&& ]
+    } 1|| ;
+
+GENERIC: vector-not-src ( expr -- vreg )
+M: not-vector-expr vector-not-src src>> vn>vreg ;
+M: xor-vector-expr vector-not-src
+    dup src1>> vn>expr fill-vector-expr? [ src2>> ] [ src1>> ] if vn>vreg ;
+
+M: ##and-vector rewrite 
+    {
+        { [ dup src1>> vreg>expr vector-not? ] [
+            {
+                [ dst>> ]
+                [ src1>> vreg>expr vector-not-src ]
+                [ src2>> ]
+                [ rep>> ]
+            } cleave \ ##andn-vector new-insn
+        ] }
+        { [ dup src2>> vreg>expr vector-not? ] [
+            {
+                [ dst>> ]
+                [ src2>> vreg>expr vector-not-src ]
+                [ src1>> ]
+                [ rep>> ]
+            } cleave \ ##andn-vector new-insn
+        ] }
+        [ drop f ]
+    } cond ;
+
+M: ##andn-vector rewrite
+    dup src1>> vreg>expr vector-not? [
+        {
+            [ dst>> ]
+            [ src1>> vreg>expr vector-not-src ]
+            [ src2>> ]
+            [ rep>> ]
+        } cleave \ ##and-vector new-insn
+    ] [ drop f ] if ;
+
+M: scalar>vector-expr simplify*
+    src>> vn>expr {
+        { [ dup vector>scalar-expr? ] [ src>> ] }
+        [ drop f ]
+    } cond ;
+
+M: shuffle-vector-imm-expr simplify*
+    [ src>> ] [ shuffle>> ] [ rep>> rep-length iota ] tri
+    sequence= [ drop f ] unless ;
+

basis/compiler/cfg/value-numbering/simplify/simplify.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors combinators classes math layouts
-sequences math.vectors.simd.intrinsics
+sequences 
 compiler.cfg.instructions
 compiler.cfg.value-numbering.graph
 compiler.cfg.value-numbering.expressions ;
@@ -130,16 +130,6 @@ M: box-displaced-alien-expr simplify*
         [ 2drop f ]
     } cond ;
 
-M: scalar>vector-expr simplify*
-    src>> vn>expr {
-        { [ dup vector>scalar-expr? ] [ src>> ] }
-        [ drop f ]
-    } cond ;
-
-M: shuffle-vector-imm-expr simplify*
-    [ src>> ] [ shuffle>> ] [ rep>> rep-components iota ] tri
-    sequence= [ drop f ] unless ;
-
 M: expr simplify* drop f ;
 
 : simplify ( expr -- vn )

basis/compiler/cfg/value-numbering/value-numbering-tests.factor

@@ -4,7 +4,7 @@ cpu.architecture tools.test kernel math combinators.short-circuit
 accessors sequences compiler.cfg.predecessors locals compiler.cfg.dce
 compiler.cfg.ssa.destruction compiler.cfg.loop-detection
 compiler.cfg.representations compiler.cfg assocs vectors arrays
-layouts literals namespaces alien ;
+layouts literals namespaces alien compiler.cfg.value-numbering.simd ;
 IN: compiler.cfg.value-numbering.tests
 
 : trim-temps ( insns -- insns )

basis/compiler/codegen/codegen.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces make math math.order math.parser sequences accessors
 kernel kernel.private layouts assocs words summary arrays
@@ -40,7 +40,7 @@ SYMBOL: labels
     V{ } clone calls set ;
 
 : generate-insns ( asm -- code )
-    dup word>> [
+    dup label>> [
         init-generator
         instructions>> [
             [ class insn-counts get inc-at ]
@@ -61,9 +61,7 @@ SYMBOL: labels
 ! Special cases
 M: ##no-tco generate-insn drop ;
 
-M: ##call generate-insn
+M: ##call generate-insn word>> [ add-call ] [ %call ] bi ;
-    word>> dup sub-primitive>>
-    [ second first % ] [ [ add-call ] [ %call ] bi ] ?if ;
 
 M: ##jump generate-insn word>> [ add-call ] [ %jump ] bi ;
 
@@ -173,11 +171,15 @@ CODEGEN: ##add-sub-vector %add-sub-vector
 CODEGEN: ##sub-vector %sub-vector
 CODEGEN: ##saturated-sub-vector %saturated-sub-vector
 CODEGEN: ##mul-vector %mul-vector
+CODEGEN: ##mul-high-vector %mul-high-vector
+CODEGEN: ##mul-horizontal-add-vector %mul-horizontal-add-vector
 CODEGEN: ##saturated-mul-vector %saturated-mul-vector
 CODEGEN: ##div-vector %div-vector
 CODEGEN: ##min-vector %min-vector
 CODEGEN: ##max-vector %max-vector
+CODEGEN: ##avg-vector %avg-vector
 CODEGEN: ##dot-vector %dot-vector
+CODEGEN: ##sad-vector %sad-vector
 CODEGEN: ##sqrt-vector %sqrt-vector
 CODEGEN: ##horizontal-add-vector %horizontal-add-vector
 CODEGEN: ##horizontal-sub-vector %horizontal-sub-vector
@@ -281,7 +283,7 @@ M: ##gc generate-insn
         [ [ uninitialized-locs>> ] [ temp1>> ] bi wipe-locs ]
         [ data-values>> save-data-regs ]
         [ [ tagged-values>> ] [ temp1>> ] bi save-gc-roots ]
-        [ [ temp1>> ] [ temp2>> ] bi t %save-context ]
+        [ [ temp1>> ] [ temp2>> ] bi %save-context ]
         [ [ tagged-values>> length ] [ temp1>> ] bi %call-gc ]
         [ [ tagged-values>> ] [ temp1>> ] bi load-gc-roots ]
         [ data-values>> load-data-regs ]
@@ -378,11 +380,11 @@ M: c-type-name flatten-value-type c-type flatten-value-type ;
     [ [ parameter-offsets nip ] keep ] dip 2reverse-each ; inline
 
 : prepare-unbox-parameters ( parameters -- offsets types indices )
-    [ parameter-offsets nip ] [ ] [ length iota reverse ] tri ;
+    [ parameter-offsets nip ] [ ] [ length iota <reversed> ] tri ;
 
 : unbox-parameters ( offset node -- )
     parameters>> swap
-    '[ prepare-unbox-parameters [ %prepare-unbox [ _ + ] dip unbox-parameter ] 3each ]
+    '[ prepare-unbox-parameters [ %pop-stack [ _ + ] dip unbox-parameter ] 3each ]
     [ length neg %inc-d ]
     bi ;
 
@@ -405,7 +407,7 @@ M: c-type-name flatten-value-type c-type flatten-value-type ;
     ] with-param-regs ;
 
 : box-return* ( node -- )
-    return>> [ ] [ box-return ] if-void ;
+    return>> [ ] [ box-return %push-stack ] if-void ;
 
 : check-dlsym ( symbols dll -- )
     dup dll-valid? [
@@ -434,6 +436,16 @@ M: ##alien-invoke generate-insn
     dup %cleanup
     box-return* ;
 
+M: ##alien-assembly generate-insn
+    params>>
+    ! Unbox parameters
+    dup objects>registers
+    %prepare-var-args
+    ! Generate assembly
+    dup quot>> call( -- )
+    ! Box return value
+    box-return* ;
+
 ! ##alien-indirect
 M: ##alien-indirect generate-insn
     params>>
@@ -450,7 +462,7 @@ M: ##alien-indirect generate-insn
 
 ! ##alien-callback
 : box-parameters ( params -- )
-    alien-parameters [ box-parameter ] each-parameter ;
+    alien-parameters [ box-parameter %push-context-stack ] each-parameter ;
 
 : registers>objects ( node -- )
     ! Generate code for boxing input parameters in a callback.
@@ -462,7 +474,7 @@ M: ##alien-indirect generate-insn
 
 TUPLE: callback-context ;
 
-: current-callback ( -- id ) 2 getenv ;
+: current-callback ( -- id ) 2 special-object ;
 
 : wait-to-return ( token -- )
     dup current-callback eq? [
@@ -473,7 +485,7 @@ TUPLE: callback-context ;
 
 : do-callback ( quot token -- )
     init-catchstack
-    [ 2 setenv call ] keep
+    [ 2 set-special-object call ] keep
     wait-to-return ; inline
 
 : callback-return-quot ( ctype -- quot )
@@ -494,11 +506,6 @@ TUPLE: callback-context ;
         [ callback-context new do-callback ] %
     ] [ ] make ;
 
-M: ##callback-return generate-insn
-    #! All the extra book-keeping for %unwind is only for x86.
-    #! On other platforms its an alias for %return.
-    params>> %callback-return ;
-
 M: ##alien-callback generate-insn
     params>>
     [ registers>objects ]

basis/compiler/codegen/fixup/fixup.factor

@@ -1,15 +1,20 @@
-! Copyright (C) 2007, 2009 Slava Pestov.
+! Copyright (C) 2007, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays byte-arrays byte-vectors generic assocs hashtables
 io.binary kernel kernel.private math namespaces make sequences
 words quotations strings alien.accessors alien.strings layouts
-system combinators math.bitwise math.order
+system combinators math.bitwise math.order generalizations
-accessors growable fry generalizations compiler.constants ;
+accessors growable fry compiler.constants memoize ;
 IN: compiler.codegen.fixup
 
 ! Owner
 SYMBOL: compiling-word
 
+! Parameter table
+SYMBOL: parameter-table
+
+: add-parameter ( obj -- ) parameter-table get push ;
+
 ! Literal table
 SYMBOL: literal-table
 
@@ -29,13 +34,10 @@ TUPLE: label offset ;
     dup label? [ get ] unless
     compiled-offset >>offset drop ;
 
-: offset-for-class ( class -- n )
-    rc-absolute-cell = cell 4 ? compiled-offset swap - ;
-
 TUPLE: label-fixup { label label } { class integer } { offset integer } ;
 
 : label-fixup ( label class -- )
-    dup offset-for-class \ label-fixup boa label-table get push ;
+    compiled-offset \ label-fixup boa label-table get push ;
 
 ! Relocation table
 SYMBOL: relocation-table
@@ -48,28 +50,28 @@ SYMBOL: relocation-table
     { 0 24 28 } bitfield relocation-table get push-4 ;
 
 : rel-fixup ( class type -- )
-    swap dup offset-for-class add-relocation-entry ;
+    swap compiled-offset add-relocation-entry ;
 
-: add-dlsym-literals ( symbol dll -- )
+! Caching common symbol names reduces image size a bit
-    [ string>symbol add-literal ] [ add-literal ] bi* ;
+MEMO: cached-string>symbol ( symbol -- obj ) string>symbol ;
+
+: add-dlsym-parameters ( symbol dll -- )
+    [ cached-string>symbol add-parameter ] [ add-parameter ] bi* ;
 
 : rel-dlsym ( name dll class -- )
-    [ add-dlsym-literals ] dip rt-dlsym rel-fixup ;
+    [ add-dlsym-parameters ] dip rt-dlsym rel-fixup ;
 
 : rel-word ( word class -- )
-    [ add-literal ] dip rt-xt rel-fixup ;
+    [ add-literal ] dip rt-entry-point rel-fixup ;
 
 : rel-word-pic ( word class -- )
-    [ add-literal ] dip rt-xt-pic rel-fixup ;
+    [ add-literal ] dip rt-entry-point-pic rel-fixup ;
 
 : rel-word-pic-tail ( word class -- )
-    [ add-literal ] dip rt-xt-pic-tail rel-fixup ;
+    [ add-literal ] dip rt-entry-point-pic-tail rel-fixup ;
-
-: rel-primitive ( word class -- )
-    [ def>> first add-literal ] dip rt-primitive rel-fixup ;
 
 : rel-immediate ( literal class -- )
-    [ add-literal ] dip rt-immediate rel-fixup ;
+    [ add-literal ] dip rt-literal rel-fixup ;
 
 : rel-this ( class -- )
     rt-this rel-fixup ;
@@ -78,7 +80,7 @@ SYMBOL: relocation-table
     [ add-literal ] dip rt-here rel-fixup ;
 
 : rel-vm ( offset class -- )
-    [ add-literal ] dip rt-vm rel-fixup ;
+    [ add-parameter ] dip rt-vm rel-fixup ;
 
 : rel-cards-offset ( class -- )
     rt-cards-offset rel-fixup ;
@@ -105,6 +107,7 @@ SYMBOL: relocation-table
 
 : init-fixup ( word -- )
     compiling-word set
+    V{ } clone parameter-table set
     V{ } clone literal-table set
     V{ } clone label-table set
     BV{ } clone relocation-table set ;
@@ -114,7 +117,7 @@ SYMBOL: relocation-table
         init-fixup
         @
         label-table [ resolve-labels ] change
-        compiling-word get
+        parameter-table get >array
         literal-table get >array
         relocation-table get >byte-array
         label-table get

basis/compiler/compiler.factor

@@ -5,13 +5,16 @@ continuations vocabs assocs dlists definitions math graphs generic
 generic.single combinators deques search-deques macros
 source-files.errors combinators.short-circuit
 
-stack-checker stack-checker.state stack-checker.inlining stack-checker.errors
+stack-checker stack-checker.dependencies stack-checker.inlining
+stack-checker.errors
 
 compiler.errors compiler.units compiler.utilities
 
 compiler.tree.builder
 compiler.tree.optimizer
 
+compiler.crossref
+
 compiler.cfg
 compiler.cfg.builder
 compiler.cfg.optimizer
@@ -29,7 +32,6 @@ SYMBOL: compiled
         [ "forgotten" word-prop ]
         [ compiled get key? ]
         [ inlined-block? ]
-        [ primitive? ]
     } 1|| not ;
 
 : queue-compile ( word -- )
@@ -60,17 +62,23 @@ M: method-body no-compile? "method-generic" word-prop no-compile? ;
 M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
 
 M: word no-compile?
-    {
+    { [ macro? ] [ "special" word-prop ] [ "no-compile" word-prop ] } 1|| ;
-        [ macro? ]
+
-        [ inline? ]
+GENERIC: combinator? ( word -- ? )
-        [ "special" word-prop ]
+
-        [ "no-compile" word-prop ]
+M: method-body combinator? "method-generic" word-prop combinator? ;
-    } 1|| ;
+
+M: predicate-engine-word combinator? "owner-generic" word-prop combinator? ;
+
+M: word combinator? inline? ;
 
 : ignore-error? ( word error -- ? )
     #! Ignore some errors on inline combinators, macros, and special
     #! words such as 'call'.
-    [ no-compile? ] [ { [ do-not-compile? ] [ literal-expected? ] } 1|| ] bi* and ;
+    {
+        [ drop no-compile? ]
+        [ [ combinator? ] [ unknown-macro-input? ] bi* and ]
+    } 2|| ;
 
 : finish ( word -- )
     #! Recompile callers if the word's stack effect changed, then
@@ -117,7 +125,10 @@ M: word no-compile?
     } cond ;
 
 : optimize? ( word -- ? )
-    single-generic? not ;
+    {
+        [ single-generic? ]
+        [ primitive? ]
+    } 1|| not ;
 
 : contains-breakpoints? ( -- ? )
     dependencies get keys [ "break?" word-prop ] any? ;
@@ -193,6 +204,14 @@ M: optimizing-compiler recompile ( words -- alist )
     ] with-scope
     "--- compile done" compiler-message ;
 
+M: optimizing-compiler to-recompile ( -- words )
+    changed-definitions get compiled-usages
+    changed-generics get compiled-generic-usages
+    append assoc-combine keys ;
+
+M: optimizing-compiler process-forgotten-words
+    [ delete-compiled-xref ] each ;
+
 : with-optimizer ( quot -- )
     [ optimizing-compiler compiler-impl ] dip with-variable ; inline
 

basis/compiler/constants/constants.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math kernel layouts system strings words quotations byte-arrays
 alien arrays literals sequences ;
@@ -20,11 +20,18 @@ CONSTANT: deck-bits 18
 : alien-offset ( -- n ) 4 alien type-number slot-offset ; inline
 : underlying-alien-offset ( -- n ) 1 alien type-number slot-offset ; inline
 : tuple-class-offset ( -- n ) 1 tuple type-number slot-offset ; inline
-: word-xt-offset ( -- n ) 10 \ word type-number slot-offset ; inline
+: word-entry-point-offset ( -- n ) 10 \ word type-number slot-offset ; inline
-: quot-xt-offset ( -- n ) 4 quotation type-number slot-offset ; inline
+: quot-entry-point-offset ( -- n ) 4 quotation type-number slot-offset ; inline
 : word-code-offset ( -- n ) 11 \ word type-number slot-offset ; inline
 : array-start-offset ( -- n ) 2 array type-number slot-offset ; inline
 : compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
+: callstack-length-offset ( -- n ) 1 \ callstack type-number slot-offset ; inline
+: callstack-top-offset ( -- n ) 2 \ callstack type-number slot-offset ; inline
+: vm-context-offset ( -- n ) 0 bootstrap-cells ; inline
+: context-callstack-top-offset ( -- n ) 0 bootstrap-cells ; inline
+: context-callstack-bottom-offset ( -- n ) 1 bootstrap-cells ; inline
+: context-datastack-offset ( -- n ) 2 bootstrap-cells ; inline
+: context-retainstack-offset ( -- n ) 3 bootstrap-cells ; inline
 
 ! Relocation classes
 CONSTANT: rc-absolute-cell 0
@@ -37,23 +44,21 @@ CONSTANT: rc-relative-ppc-3 6
 CONSTANT: rc-relative-arm-3 7
 CONSTANT: rc-indirect-arm 8
 CONSTANT: rc-indirect-arm-pc 9
+CONSTANT: rc-absolute-2 10
 
 ! Relocation types
-CONSTANT: rt-primitive 0
+CONSTANT: rt-dlsym 0
-CONSTANT: rt-dlsym 1
+CONSTANT: rt-entry-point 1
-CONSTANT: rt-dispatch 2
+CONSTANT: rt-entry-point-pic 2
-CONSTANT: rt-xt 3
+CONSTANT: rt-entry-point-pic-tail 3
-CONSTANT: rt-xt-pic 4
+CONSTANT: rt-here 4
-CONSTANT: rt-xt-pic-tail 5
+CONSTANT: rt-this 5
-CONSTANT: rt-here 6
+CONSTANT: rt-literal 6
-CONSTANT: rt-this 7
+CONSTANT: rt-untagged 7
-CONSTANT: rt-immediate 8
+CONSTANT: rt-megamorphic-cache-hits 8
-CONSTANT: rt-stack-chain 9
+CONSTANT: rt-vm 9
-CONSTANT: rt-untagged 10
+CONSTANT: rt-cards-offset 10
-CONSTANT: rt-megamorphic-cache-hits 11
+CONSTANT: rt-decks-offset 11
-CONSTANT: rt-vm 12
-CONSTANT: rt-cards-offset 13
-CONSTANT: rt-decks-offset 14
 
 : rc-absolute? ( n -- ? )
     ${ rc-absolute-ppc-2/2 rc-absolute-cell rc-absolute } member? ;

basis/compiler/crossref/crossref.factor

@@ -0,0 +1,68 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs classes.algebra compiler.units definitions graphs
+grouping kernel namespaces sequences words
+stack-checker.dependencies ;
+IN: compiler.crossref
+
+SYMBOL: compiled-crossref
+
+compiled-crossref [ H{ } clone ] initialize
+
+SYMBOL: compiled-generic-crossref
+
+compiled-generic-crossref [ H{ } clone ] initialize
+
+: compiled-usage ( word -- assoc )
+    compiled-crossref get at ;
+
+: (compiled-usages) ( word -- assoc )
+    #! If the word is not flushable anymore, we have to recompile
+    #! all words which flushable away a call (presumably when the
+    #! word was still flushable). If the word is flushable, we
+    #! don't have to recompile words that folded this away.
+    [ compiled-usage ]
+    [ "flushable" word-prop inlined-dependency flushed-dependency ? ] bi
+    [ dependency>= nip ] curry assoc-filter ;
+
+: compiled-usages ( seq -- assocs )
+    [ drop word? ] assoc-filter
+    [ [ drop (compiled-usages) ] { } assoc>map ] keep suffix ;
+
+: compiled-generic-usage ( word -- assoc )
+    compiled-generic-crossref get at ;
+
+: (compiled-generic-usages) ( generic class -- assoc )
+    [ compiled-generic-usage ] dip
+    [
+        2dup [ valid-class? ] both?
+        [ classes-intersect? ] [ 2drop f ] if nip
+    ] curry assoc-filter ;
+
+: compiled-generic-usages ( assoc -- assocs )
+    [ (compiled-generic-usages) ] { } assoc>map ;
+
+: (compiled-xref) ( word dependencies word-prop variable -- )
+    [ [ concat ] dip set-word-prop ] [ get add-vertex* ] bi-curry* 2bi ;
+
+: compiled-xref ( word dependencies generic-dependencies -- )
+    [ [ drop crossref? ] { } assoc-filter-as ] bi@
+    [ "compiled-uses" compiled-crossref (compiled-xref) ]
+    [ "compiled-generic-uses" compiled-generic-crossref (compiled-xref) ]
+    bi-curry* bi ;
+
+: (compiled-unxref) ( word word-prop variable -- )
+    [ [ [ dupd word-prop 2 <groups> ] dip get remove-vertex* ] 2curry ]
+    [ drop [ remove-word-prop ] curry ]
+    2bi bi ;
+
+: compiled-unxref ( word -- )
+    [ "compiled-uses" compiled-crossref (compiled-unxref) ]
+    [ "compiled-generic-uses" compiled-generic-crossref (compiled-unxref) ]
+    bi ;
+
+: delete-compiled-xref ( word -- )
+    [ compiled-unxref ]
+    [ compiled-crossref get delete-at ]
+    [ compiled-generic-crossref get delete-at ]
+    tri ;

basis/compiler/tests/alien.factor

@@ -94,6 +94,8 @@ FUNCTION: TINY ffi_test_17 int x ;
 
 { 1 1 } [ indirect-test-1 ] must-infer-as
 
+[ B{ } indirect-test-1 ] [ { "kernel-error" 3 6 B{ } } = ] must-fail-with
+
 [ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
 
 : indirect-test-1' ( ptr -- )
@@ -162,7 +164,7 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3,
     { int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int }
     alien-invoke gc 3 ;
 
-[ 861 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
+[ 861 3 ] [ 42 [ ] each-integer ffi_test_31 ] unit-test
 
 : ffi_test_31_point_5 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result )
     float
@@ -170,7 +172,7 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3,
     { float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float }
     alien-invoke ;
 
-[ 861.0 ] [ 42 [ >float ] each ffi_test_31_point_5 ] unit-test
+[ 861.0 ] [ 42 [ >float ] each-integer ffi_test_31_point_5 ] unit-test
 
 FUNCTION: longlong ffi_test_21 long x long y ;
 
@@ -314,7 +316,7 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
 
 : callback-1 ( -- callback ) void { } "cdecl" [ ] alien-callback ;
 
-[ 0 1 ] [ [ callback-1 ] infer [ in>> ] [ out>> ] bi ] unit-test
+[ 0 1 ] [ [ callback-1 ] infer [ in>> length ] [ out>> length ] bi ] unit-test
 
 [ t ] [ callback-1 alien? ] unit-test
 
@@ -375,9 +377,7 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
 [ f ] [ namespace global eq? ] unit-test
 
 : callback-8 ( -- callback )
-    void { } "cdecl" [
+    void { } "cdecl" [ [ ] in-thread yield ] alien-callback ;
-        [ continue ] callcc0
-    ] alien-callback ;
 
 [ ] [ callback-8 callback_test_1 ] unit-test
 
@@ -588,5 +588,9 @@ FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
 ! Regression: calling an undefined function would raise a protection fault
 FUNCTION: void this_does_not_exist ( ) ;
 
-[ this_does_not_exist ] [ { "kernel-error" 10 f f } = ] must-fail-with
+[ this_does_not_exist ] [ { "kernel-error" 9 f f } = ] must-fail-with
 
+! More alien-assembly tests are in cpu.* vocabs
+: assembly-test-1 ( -- ) void { } "cdecl" [ ] alien-assembly ;
+
+[ ] [ assembly-test-1 ] unit-test

basis/compiler/tests/codegen.factor

@@ -116,7 +116,7 @@ unit-test
     1 1.0 2.5 try-breaking-dispatch "bye" = [ 3.5 = ] dip and ;
 
 [ t ] [
-    10000000 [ drop try-breaking-dispatch-2 ] all?
+    10000000 [ drop try-breaking-dispatch-2 ] all-integers?
 ] unit-test
 
 ! Regression
@@ -314,7 +314,7 @@ cell 4 = [
 
 ! Bug with ##return node construction
 : return-recursive-bug ( nodes -- ? )
-    { fixnum } declare [
+    { fixnum } declare iota [
         dup 3 bitand 1 = [ drop t ] [
             dup 3 bitand 2 = [
                 return-recursive-bug

basis/compiler/tests/float.factor

@@ -1,5 +1,5 @@
 USING: compiler.units compiler kernel kernel.private memory math
-math.private tools.test math.floats.private ;
+math.private tools.test math.floats.private math.order fry ;
 IN: compiler.tests.float
 
 [ 5.0 ] [ [ 5.0 ] compile-call gc gc gc ] unit-test
@@ -84,11 +84,6 @@ IN: compiler.tests.float
 
 [ 315 315.0 ] [ 313 [ 2 fixnum+fast dup fixnum>float ] compile-call ] unit-test
 
-[ 17.5 ] [ -11.3 17.5 [ float-max ] compile-call ] unit-test
-[ 17.5 ] [ 17.5 -11.3 [ float-max ] compile-call ] unit-test
-[ -11.3 ] [ -11.3 17.5 [ float-min ] compile-call ] unit-test
-[ -11.3 ] [ 17.5 -11.3 [ float-min ] compile-call ] unit-test
-
 [ t ] [ 0/0. 0/0. [ float-unordered? ] compile-call ] unit-test
 [ t ] [ 0/0. 1.0 [ float-unordered? ] compile-call ] unit-test
 [ t ] [ 1.0 0/0. [ float-unordered? ] compile-call ] unit-test
@@ -100,3 +95,23 @@ IN: compiler.tests.float
 [ 1 ] [ 1.0 0/0. [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test
 [ 2 ] [ 3.0 1.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test
 [ 2 ] [ 1.0 3.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test
+
+! Ensure that float-min and min, and float-max and max, have
+! consistent behavior with respect to NaNs
+
+: two-floats ( a b -- a b ) { float float } declare ; inline
+
+[ -11.3 ] [ -11.3 17.5 [ two-floats min ] compile-call ] unit-test
+[ -11.3 ] [ 17.5 -11.3 [ two-floats min ] compile-call ] unit-test
+[ 17.5 ] [ -11.3 17.5 [ two-floats max ] compile-call ] unit-test
+[ 17.5 ] [ 17.5 -11.3 [ two-floats max ] compile-call ] unit-test
+
+: check-compiled-binary-op ( a b word -- )
+    [ '[ [ [ two-floats _ execute ] compile-call ] call( a b -- c ) ] ]
+    [ '[ _ execute ] ]
+    bi 2bi fp-bitwise= ; inline
+
+[ t ] [ 0/0. 3.0 \ min check-compiled-binary-op ] unit-test
+[ t ] [ 3.0 0/0. \ min check-compiled-binary-op ] unit-test
+[ t ] [ 0/0. 3.0 \ max check-compiled-binary-op ] unit-test
+[ t ] [ 3.0 0/0. \ max check-compiled-binary-op ] unit-test

basis/compiler/tests/intrinsics.factor

@@ -21,7 +21,6 @@ IN: compiler.tests.intrinsics
 [ 2 1 3 ] [ 1 2 3 [ swapd ] compile-call ] unit-test
 [ 2 ] [ 1 2 [ nip ] compile-call ] unit-test
 [ 3 ] [ 1 2 3 [ 2nip ] compile-call ] unit-test
-[ 2 1 2 ] [ 1 2 [ tuck ] compile-call ] unit-test
 [ 1 2 1 ] [ 1 2 [ over ] compile-call ] unit-test
 [ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-call ] unit-test
 [ 2 1 ] [ 1 2 [ swap ] compile-call ] unit-test
@@ -55,8 +54,8 @@ IN: compiler.tests.intrinsics
 [ HEX: 123456 ] [ 1 [ "a\u123456c" string-nth ] compile-call ] unit-test
 [ HEX: 123456 ] [ [ 1 "a\u123456c" string-nth ] compile-call ] unit-test
 
-[ ] [ [ 0 getenv ] compile-call drop ] unit-test
+[ ] [ [ 0 special-object ] compile-call drop ] unit-test
-[ ] [ 1 getenv [ 1 setenv ] compile-call ] unit-test
+[ ] [ 1 special-object [ 1 set-special-object ] compile-call ] unit-test
 
 [ ] [ 1 [ drop ] compile-call ] unit-test
 [ ] [ [ 1 drop ] compile-call ] unit-test
@@ -338,7 +337,7 @@ ERROR: bug-in-fixnum* x y a b ;
 
 [ ] [
     10000 [
-        5 random [ drop 32 random-bits ] map product >bignum
+        5 random iota [ drop 32 random-bits ] map product >bignum
         dup [ bignum>fixnum ] keep compiled-bignum>fixnum =
         [ drop ] [ "Oops" throw ] if
     ] times
@@ -586,16 +585,16 @@ TUPLE: alien-accessor-regression { b byte-array } { i fixnum } ;
     swap [
         { tuple } declare 1 slot
     ] [
-        0 slot
+        1 slot
     ] if ;
 
-[ t ] [ f B{ } mutable-value-bug-1 byte-array type-number = ] unit-test
+[ 0 ] [ f { } mutable-value-bug-1 ] unit-test
 
 : mutable-value-bug-2 ( a b -- c )
     swap [
-        0 slot
+        1 slot
     ] [
         { tuple } declare 1 slot
     ] if ;
 
-[ t ] [ t B{ } mutable-value-bug-2 byte-array type-number = ] unit-test
+[ 0 ] [ t { } mutable-value-bug-2 ] unit-test

basis/compiler/tests/optimizer.factor

@@ -4,7 +4,7 @@ sbufs strings tools.test vectors words sequences.private
 quotations classes classes.algebra classes.tuple.private
 continuations growable namespaces hints alien.accessors
 compiler.tree.builder compiler.tree.optimizer sequences.deep
-compiler definitions generic.single shuffle ;
+compiler definitions generic.single shuffle math.order ;
 IN: compiler.tests.optimizer
 
 GENERIC: xyz ( obj -- obj )
@@ -90,7 +90,7 @@ TUPLE: pred-test ;
 : double-label-2 ( a -- b )
     dup array? [ ] [ ] if 0 t double-label-1 ;
 
-[ 0 ] [ 10 double-label-2 ] unit-test
+[ 0 ] [ 10 iota double-label-2 ] unit-test
 
 ! regression
 GENERIC: void-generic ( obj -- * )
@@ -208,7 +208,7 @@ USE: binary-search.private
     ] if ; inline recursive
 
 [ 10 ] [
-    10 20 >vector <flat-slice>
+    10 20 iota <flat-slice>
     [ [ - ] swap old-binsearch ] compile-call 2nip
 ] unit-test
 
@@ -349,7 +349,7 @@ TUPLE: some-tuple x ;
 [ 5 ] [ { 1 2 { 3 { 4 5 } } } deep-find-test ] unit-test
 [ f ] [ { 1 2 { 3 { 4 } } } deep-find-test ] unit-test
 
-[ B{ 0 1 2 3 4 5 6 7 } ] [ [ 8 [ ] B{ } map-as ] compile-call ] unit-test
+[ B{ 0 1 2 3 4 5 6 7 } ] [ [ 8 iota [ ] B{ } map-as ] compile-call ] unit-test
 
 [ 0 ] [ 1234 [ { fixnum } declare -64 shift ] compile-call ] unit-test
 
@@ -445,5 +445,17 @@ M: object bad-dispatch-position-test* ;
 
 [ 1024 bignum ] [ 10 [ 1 >bignum swap >fixnum shift ] compile-call dup class ] unit-test
 
-! Not sure if I want to fix this...
+TUPLE: grid-mesh-tuple { length read-only } { step read-only } ;
-! [ t [ [ f ] [ 3 ] if >fixnum ] compile-call ] [ no-method? ] must-fail-with
+
+: grid-mesh-test-case ( -- vertices )
+    1.0 1.0 { 2 } first /f [ /i 1 + ] keep grid-mesh-tuple boa
+    1 f <array>
+    [
+        [ drop length>> >fixnum 2 min ] 2keep
+        [
+            [ step>> 1 * ] dip
+            0 swap set-nth-unsafe
+        ] 2curry times
+    ] keep ;
+
+[ { 0.5 } ] [ grid-mesh-test-case ] unit-test

basis/compiler/tests/redefine3.factor

@@ -1,6 +1,6 @@
 USING: accessors compiler compiler.units tools.test math parser
 kernel sequences sequences.private classes.mixin generic
-definitions arrays words assocs eval ;
+definitions arrays words assocs eval grouping ;
 IN: compiler.tests.redefine3
 
 GENERIC: sheeple ( obj -- x )
@@ -13,20 +13,23 @@ M: empty-mixin sheeple drop "wake up" ; inline
 
 : sheeple-test ( -- string ) { } sheeple ;
 
+: compiled-use? ( key word -- ? )
+    "compiled-uses" word-prop 2 <groups> key? ;
+
 [ "sheeple" ] [ sheeple-test ] unit-test
 [ t ] [ \ sheeple-test optimized? ] unit-test
-[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
+[ t ] [ object \ sheeple method \ sheeple-test compiled-use? ] unit-test
-[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
+[ f ] [ empty-mixin \ sheeple method \ sheeple-test compiled-use? ] unit-test
 
 [ ] [ "IN: compiler.tests.redefine3 USE: arrays INSTANCE: array empty-mixin" eval( -- ) ] unit-test
 
 [ "wake up" ] [ sheeple-test ] unit-test
-[ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
+[ f ] [ object \ sheeple method \ sheeple-test compiled-use? ] unit-test
-[ t ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
+[ t ] [ empty-mixin \ sheeple method \ sheeple-test compiled-use? ] unit-test
 
 [ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
 
 [ "sheeple" ] [ sheeple-test ] unit-test
 [ t ] [ \ sheeple-test optimized? ] unit-test
-[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
+[ t ] [ object \ sheeple method \ sheeple-test compiled-use? ] unit-test
-[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
+[ f ] [ empty-mixin \ sheeple method \ sheeple-test compiled-use? ] unit-test

basis/compiler/tree/builder/builder.factor

@@ -39,7 +39,7 @@ M: word (build-tree)
     [
         <recursive-state> recursive-state set
         V{ } clone stack-visitor set
-        [ [ >vector \ meta-d set ] [ length d-in set ] bi ]
+        [ [ >vector \ meta-d set ] [ length input-count set ] bi ]
         [ (build-tree) ]
         bi*
     ] with-infer nip ;

basis/compiler/tree/checker/checker.factor

@@ -185,9 +185,7 @@ M: #recursive check-stack-flow*
 
 M: #copy check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
 
-M: #alien-invoke check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
+M: #alien-node check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
-
-M: #alien-indirect check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
 
 M: #alien-callback check-stack-flow* drop ;
 

basis/compiler/tree/cleanup/cleanup-tests.factor

@@ -339,28 +339,23 @@ cell-bits 32 = [
 ] unit-test
 
 [ t ] [
-    [ { fixnum } declare length [ drop ] each-integer ]
+    [ { fixnum } declare iota [ drop ] each ]
     { < <-integer-fixnum +-integer-fixnum + } inlined?
 ] unit-test
 
 [ t ] [
-    [ { fixnum } declare [ drop ] each ]
+    [ { fixnum } declare iota 0 [ + ] reduce ]
-    { < <-integer-fixnum +-integer-fixnum + } inlined?
-] unit-test
-
-[ t ] [
-    [ { fixnum } declare 0 [ + ] reduce ]
     { < <-integer-fixnum nth-unsafe } inlined?
 ] unit-test
 
 [ f ] [
-    [ { fixnum } declare 0 [ + ] reduce ]
+    [ { fixnum } declare iota 0 [ + ] reduce ]
     \ +-integer-fixnum inlined?
 ] unit-test
 
 [ f ] [
     [
-        { integer } declare [ ] map
+        { integer } declare iota [ ] map
     ] \ >fixnum inlined?
 ] unit-test
 
@@ -403,7 +398,7 @@ cell-bits 32 = [
 
 [ t ] [
     [
-        { integer } declare [ 0 >= ] map
+        { integer } declare iota [ 0 >= ] map
     ] { >= fixnum>= } inlined?
 ] unit-test
 

basis/compiler/tree/cleanup/cleanup.factor

@@ -3,7 +3,7 @@
 USING: kernel accessors sequences combinators fry
 classes.algebra namespaces assocs words math math.private
 math.partial-dispatch math.intervals classes classes.tuple
-classes.tuple.private layouts definitions stack-checker.state
+classes.tuple.private layouts definitions stack-checker.dependencies
 stack-checker.branches
 compiler.utilities
 compiler.tree

basis/compiler/tree/dead-code/branches/branches.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: sequences namespaces kernel accessors assocs sets fry
 arrays combinators columns stack-checker.backend
@@ -36,7 +36,7 @@ M: #branch remove-dead-code*
 
 : drop-indexed-values ( values indices -- node )
     [ drop filter-live ] [ swap nths ] 2bi
-    [ make-values ] keep
+    [ length make-values ] keep
     [ drop ] [ zip ] 2bi
     #data-shuffle ;
 

basis/compiler/tree/dead-code/recursive/recursive.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs sequences kernel locals fry
 combinators stack-checker.backend
@@ -24,7 +24,7 @@ M: #call-recursive compute-live-values*
 
 :: drop-dead-inputs ( inputs outputs -- #shuffle )
     inputs filter-live
-    outputs inputs filter-corresponding make-values
+    outputs inputs filter-corresponding length make-values
     outputs
     inputs
     drop-values ;
@@ -39,7 +39,7 @@ M: #enter-recursive remove-dead-code*
     2bi ;
 
 :: (drop-call-recursive-outputs) ( inputs outputs -- #shuffle )
-    inputs outputs filter-corresponding make-values :> new-live-outputs
+    inputs outputs filter-corresponding length make-values :> new-live-outputs
     outputs filter-live :> live-outputs
     new-live-outputs
     live-outputs

basis/compiler/tree/dead-code/simple/simple.factor

@@ -1,8 +1,8 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors words assocs sequences arrays namespaces
 fry locals definitions classes classes.algebra generic
-stack-checker.state
+stack-checker.dependencies
 stack-checker.backend
 compiler.tree
 compiler.tree.propagation.info
@@ -28,9 +28,7 @@ M: method-body flushable? "method-generic" word-prop flushable? ;
 M: #call mark-live-values*
     dup flushable-call? [ drop ] [ look-at-inputs ] if ;
 
-M: #alien-invoke mark-live-values* look-at-inputs ;
+M: #alien-node mark-live-values* look-at-inputs ;
-
-M: #alien-indirect mark-live-values* look-at-inputs ;
 
 M: #return mark-live-values* look-at-inputs ;
 
@@ -47,9 +45,7 @@ M: #call compute-live-values* nip look-at-inputs ;
 M: #shuffle compute-live-values*
     mapping>> at look-at-value ;
 
-M: #alien-invoke compute-live-values* nip look-at-inputs ;
+M: #alien-node compute-live-values* nip look-at-inputs ;
-
-M: #alien-indirect compute-live-values* nip look-at-inputs ;
 
 : filter-mapping ( assoc -- assoc' )
     live-values get '[ drop _ key? ] assoc-filter ;
@@ -71,7 +67,7 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
     filter-corresponding zip #data-shuffle ; inline
 
 :: drop-dead-values ( outputs -- #shuffle )
-    outputs make-values :> new-outputs
+    outputs length make-values :> new-outputs
     outputs filter-live :> live-outputs
     new-outputs
     live-outputs
@@ -127,8 +123,5 @@ M: #terminate remove-dead-code*
     [ filter-live ] change-in-d
     [ filter-live ] change-in-r ;
 
-M: #alien-invoke remove-dead-code*
+M: #alien-node remove-dead-code*
-    maybe-drop-dead-outputs ;
-
-M: #alien-indirect remove-dead-code*
     maybe-drop-dead-outputs ;

basis/compiler/tree/debugger/debugger.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2006, 2009 Slava Pestov.
+! Copyright (C) 2006, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel assocs match fry accessors namespaces make effects
 sequences sequences.private quotations generic macros arrays
@@ -51,7 +51,6 @@ MATCH-VARS: ?a ?b ?c ;
         { { { ?b ?a } { ?a ?b } } [ swap ] }
         { { { ?b ?a ?c } { ?a ?b ?c } } [ swapd ] }
         { { { ?a ?b } { ?a ?a ?b } } [ dupd ] }
-        { { { ?a ?b } { ?b ?a ?b } } [ tuck ] }
         { { { ?a ?b ?c } { ?a ?b ?c ?a } } [ pick ] }
         { { { ?a ?b ?c } { ?c ?a ?b } } [ -rot ] }
         { { { ?a ?b ?c } { ?b ?c ?a } } [ rot ] }
@@ -65,7 +64,7 @@ TUPLE: shuffle-node { effect effect } ;
 M: shuffle-node pprint* effect>> effect>string text ;
  
 : (shuffle-effect) ( in out #shuffle -- effect )
-    mapping>> '[ _ at ] map <effect> ;
+    mapping>> '[ _ at ] map [ >array ] bi@ <effect> ;
 
 : shuffle-effect ( #shuffle -- effect )
     [ in-d>> ] [ out-d>> ] [ ] tri (shuffle-effect) ;
@@ -127,6 +126,8 @@ M: #alien-invoke node>quot params>> , \ #alien-invoke , ;
 
 M: #alien-indirect node>quot params>> , \ #alien-indirect , ;
 
+M: #alien-assembly node>quot params>> , \ #alien-assembly , ;
+
 M: #alien-callback node>quot params>> , \ #alien-callback , ;
 
 M: node node>quot drop ;

basis/compiler/tree/escape-analysis/escape-analysis-tests.factor

@@ -7,7 +7,7 @@ math.private kernel tools.test accessors slots.private
 quotations.private prettyprint classes.tuple.private classes
 classes.tuple namespaces
 compiler.tree.propagation.info stack-checker.errors
-compiler.tree.checker
+compiler.tree.checker compiler.tree.def-use compiler.tree.dead-code
 kernel.private vectors ;
 IN: compiler.tree.escape-analysis.tests
 
@@ -37,6 +37,8 @@ M: node count-unboxed-allocations* drop ;
     cleanup
     escape-analysis
     dup check-nodes
+    compute-def-use
+    remove-dead-code
     0 swap [ count-unboxed-allocations* ] each-node ;
 
 [ 0 ] [ [ [ + ] curry ] count-unboxed-allocations ] unit-test
@@ -173,12 +175,6 @@ TUPLE: cons { car read-only } { cdr read-only } ;
     [ 10 [ drop ] each-integer ] count-unboxed-allocations
 ] unit-test
 
-[ 2 ] [
-    [
-        1 2 cons boa 10 [ 2drop 1 2 cons boa ] each-integer car>>
-    ] count-unboxed-allocations
-] unit-test
-
 [ 0 ] [
     [
         1 2 cons boa 10 [ drop 2 cons boa ] each-integer car>>
@@ -304,14 +300,6 @@ C: <ro-box> ro-box
 
 [ 0 ] [ [ 1 cons boa "x" get slot ] count-unboxed-allocations ] unit-test
 
-: impeach-node ( quot: ( node -- ) -- )
-    [ call ] keep impeach-node ; inline recursive
-
-: bleach-node ( quot: ( node -- ) -- )
-    [ bleach-node ] curry [ ] compose impeach-node ; inline recursive
-
-[ 3 ] [ [ [ ] bleach-node ] count-unboxed-allocations ] unit-test
-
 [ 0 ] [
     [ dup -1 over >= [ 0 >= [ "A" throw ] unless ] [ drop ] if ]
     count-unboxed-allocations
@@ -322,10 +310,6 @@ C: <ro-box> ro-box
     count-unboxed-allocations
 ] unit-test
 
-[ 0 ] [
-    [ { null } declare [ 1 ] [ 2 ] if ] count-unboxed-allocations
-] unit-test
-
 ! Doug found a regression
 
 TUPLE: empty-tuple ;